Merge branch 'master' into ep/upgrade-hackage

* agent: batch loading of connections with PostgreSQL client

* batch more

* optimize getPendingCommandServers

* fix Bool conversion

* enable all tests

* cleanup

.github/workflows/build.yml

@@ -58,11 +58,11 @@ jobs:
 # =============================
 
   build:
-    name: "ubuntu-${{ matrix.os }}, GHC: ${{ matrix.ghc }}"
+    name: "ubuntu-${{ matrix.os }}-${{ matrix.arch }}, GHC: ${{ matrix.ghc }}"
     needs: maybe-release
     env:
       apps: "smp-server xftp-server ntf-server xftp"
-    runs-on: ubuntu-${{ matrix.os }}
+    runs-on: ${{ matrix.runner }}
     services:
       postgres:
         image: postgres:15
@@ -81,16 +81,34 @@ jobs:
       matrix:
         include:
           - os: 22.04
+            os_underscore: 22_04
+            arch: x86-64
+            runner: "ubuntu-22.04"
             ghc: "8.10.7"
-            platform_name: 22_04-8.10.7
             should_run: ${{ !(github.ref == 'refs/heads/stable' || startsWith(github.ref, 'refs/tags/v')) }}
           - os: 22.04
+            os_underscore: 22_04
+            arch: x86-64
+            runner: "ubuntu-22.04"
             ghc: "9.6.3"
-            platform_name: 22_04-x86-64
             should_run: true
           - os: 24.04
+            os_underscore: 24_04
+            arch: x86-64
+            runner: "ubuntu-24.04"
+            ghc: "9.6.3"
+            should_run: true
+          - os: 22.04
+            os_underscore: 22_04
+            arch: aarch64
+            runner: "ubuntu-22.04-arm"
+            ghc: "9.6.3"
+            should_run: true
+          - os: 24.04
+            os_underscore: 24_04
+            arch: aarch64
+            runner: "ubuntu-24.04-arm"
             ghc: "9.6.3"
-            platform_name: 24_04-x86-64
             should_run: true
     steps:
       - name: Clone project
@@ -127,11 +145,7 @@ jobs:
           context: .
           load: true
           file: Dockerfile.build
-          tags: build/${{ matrix.platform_name }}:latest
-          cache-from: |
-            type=gha
-            type=gha,scope=master
-          cache-to: type=gha,mode=max
+          tags: build/${{ matrix.os }}:latest
           build-args: |
             TAG=${{ matrix.os }}
             GHC=${{ matrix.ghc }}
@@ -143,23 +157,28 @@ jobs:
           path: |
             ~/.cabal/store
             dist-newstyle
-          key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
+          key: ubuntu-${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
 
       - name: Start container
         if: matrix.should_run == true
         shell: bash
         run: |
           docker run -t -d \
+            --device /dev/fuse \
+            --cap-add SYS_ADMIN \
+            --security-opt apparmor:unconfined \
             --name builder \
             -v ~/.cabal:/root/.cabal \
             -v /home/runner/work/_temp:/home/runner/work/_temp \
             -v ${{ github.workspace }}:/project \
-            build/${{ matrix.platform_name }}:latest
+            build/${{ matrix.os }}:latest
 
       - name: Build smp-server (postgresql) and tests
         if: matrix.should_run == true
         shell: docker exec -t builder sh -eu {0}
         run: |
+          chmod -R 777 dist-newstyle ~/.cabal && git config --global --add safe.directory '*'
+          cabal clean
           cabal update
           cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
           mkdir -p /out
@@ -181,7 +200,7 @@ jobs:
         id: prepare-postgres
         shell: bash
         run: |
-          name="smp-server-postgres-ubuntu-${{ matrix.platform_name }}"
+          name="smp-server-postgres-ubuntu-${{ matrix.os_underscore }}-${{ matrix.arch }}"
           docker cp builder:/out/smp-server $name
 
           path="${{ github.workspace }}/$name"
@@ -213,9 +232,9 @@ jobs:
           printf 'bins<<EOF\n' > bins.output
           printf 'hashes<<EOF\n' > hashes.output
           for i in ${{ env.apps }}; do
-            mv ./out/$i ./$i-ubuntu-${{ matrix.platform_name }}
+            name="$i-ubuntu-${{ matrix.os_underscore }}-${{ matrix.arch }}"
 
-            name="$i-ubuntu-${{ matrix.platform_name }}"
+            mv ./out/$i ./$name
 
             path="${{ github.workspace }}/$name"
             hash="SHA2-256($name)= $(openssl sha256 $path | cut -d' ' -f 2)"
@@ -246,7 +265,7 @@ jobs:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
       - name: Test
-        if: matrix.should_run == true
+        if: matrix.should_run == true && matrix.arch == 'x86-64'
         timeout-minutes: 120
         shell: bash
         env:

.github/workflows/reproduce-schedule.yml

@@ -25,7 +25,7 @@ jobs:
 
       - name: Execute reproduce script
         run: |
-          ${GITHUB_WORKSPACE}/scripts/reproduce-builds.sh "$TAG"
+          ${GITHUB_WORKSPACE}/scripts/simplexmq-reproduce-builds.sh "$TAG" || :
 
       - name: Check if build has been reproduced
         env:
@@ -33,7 +33,7 @@ jobs:
           user: ${{ secrets.STATUS_SIMPLEX_WEBHOOK_USER }}
           pass: ${{ secrets.STATUS_SIMPLEX_WEBHOOK_PASS }}
         run: |
-          if [ -f "${GITHUB_WORKSPACE}/$TAG/_sha256sums" ]; then
+          if [ -f "${GITHUB_WORKSPACE}/${TAG}-simplexmq/_sha256sums" ]; then
             exit 0
           else
             curl --proto '=https' --tlsv1.2 -sSf \

CHANGELOG.md

@@ -1,3 +1,61 @@
+# 6.4.4
+
+Servers:
+- fix server pages when source code is not specified.
+- include commit SHA in printed version and in web page (#1608).
+
+SMP server:
+- support short SimpleX addresses in server information page (#1600).
+- wrap all queries in transactions (#1603).
+
+SMP agent:
+- chat relay address type for short links (#1602).
+- extend xrcp certificate validity 1 hour in the past, to allow out of sync clocks (#1601).
+
+# 6.4.3
+
+SMP agent:
+- fix some connection errors by updating contact request server hosts to match server in short link (#1597).
+
+SMP server:
+- support short link URI as queue identifier in control port commands (#1596).
+
+# 6.4.2
+
+SMP server:
+- fix memory leak when connection interrupts straight after client connects.
+- do not include repeated queue blocking into stats/quota.
+
+XFTP server:
+- prometheus metrics
+
+# 6.4.1
+
+SMP protocol:
+- create notification credentials via NEW command that creates the queue (#1586)
+
+SMP server:
+- control port session improvements (#1591)
+- additional stat counter for ntf credentials created together with the queue (#1589)
+
+# 6.4.0
+
+SMP protocol (server/client):
+- support associated queue data and short connection links (see [RFC](./rfcs/2025-03-16-smp-queues.md)).
+- service certificates to optimize subscriptions.
+
+SMP agent:
+- support retries for interactive connection handshakes.
+- use web port 443 by default for preset servers.
+- use static RNG function to avoid creating dynamic C stubs when generating sntrup keys (it was detected as Dynamic Code Loading in GrapheneOS).
+- different timeouts for interactive and background operations.
+
+Ntf server:
+- PostgreSQL storage.
+- Prometheus metrics.
+- use service certificates.
+- fix repeat token registration.
+
 # 6.3.2
 
 Servers:
@@ -18,7 +76,7 @@ Servers:
 - update script (simplex-servers-update) downloads scripts from the specified or the latest stable tag.
 
 SMP server:
-- support for PostrgreSQL database for queue records for higher traffic servers.
+- support for PostgreSQL database for queue records for higher traffic servers.
 - fix old clients sending messages to new servers (#1443)
 - remove empty journals when opening message queues and expiring idle queues (#1456, #1458).
 - additional start options (#1465):
@@ -74,7 +132,7 @@ Servers: more reliable restoring of state.
 
 SMP server: reduced memory usage and faster start.
 
-Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378):
+Notifications: compensate for iOS notifications being dropped by Apple while device is offline (#1378):
 - Ntf server: send multiple SMP notifications in one iOS notification.
 - Agent: get multiple messages for one iOS notification.
 

README.md

@@ -1,6 +1,6 @@
 # SimpleXMQ
 
-[![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild)
+[![GitHub build](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml/badge.svg)](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml)
 [![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplexmq)](https://github.com/simplex-chat/simplexmq/releases)
 
 📢 SimpleXMQ v1 is released - with many security, privacy and efficiency improvements, new functionality - see [release notes](https://github.com/simplex-chat/simplexmq/releases/tag/v1.0.0).
@@ -116,7 +116,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
 2. Run your Docker container.
 
    - `smp-server`
-   
+
      You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
      ```sh
      docker run -d \
@@ -129,7 +129,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
      ```
 
    - `xftp-server`
-   
+
      You must change **your_ip_or_domain** and **maximum_storage**.
      ```sh
      docker run -d \
@@ -187,7 +187,7 @@ On Linux, you can build smp server using Docker.
 3. Run your Docker container.
 
    - `smp-server`
-   
+
      You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
      ```sh
      docker run -d \
@@ -200,7 +200,7 @@ On Linux, you can build smp server using Docker.
      ```
 
    - `xftp-server`
-   
+
      You must change **your_ip_or_domain** and **maximum_storage**.
      ```sh
      docker run -d \
@@ -247,7 +247,7 @@ On Linux, you can build smp server using Docker.
 
    `xftp-server`
    ```sh
-   cabal list-bin exe:xftp-server 
+   cabal list-bin exe:xftp-server
    ```
 
 - Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.

apps/smp-server/static/index.html

@@ -223,11 +223,14 @@
             <table id="public-info">
               <tr class="text-grey-black dark:text-white text-base">
                 <td>Server version:</td>
-                <td>${version}</td>
+                <td>${version}<x-commit> / <a href="${commitSourceCode}/commit/${commit}" target="_blank">${shortCommit}</a></x-commit></td>
               </tr>
               <tr class="text-grey-black dark:text-white text-base">
                 <td>Source code:</td>
-                <td><a href="${sourceCode}" target="_blank">${sourceCode}</a></td>
+                <td>
+                  <x-sourceCode><a href="${sourceCode}" target="_blank">${sourceCode}</a></x-sourceCode>
+                  <x-noSourceCode>add to smp-server.ini (required by <a href="https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE" target="_blank">AGPLv3</a>)</x-noSourceCode>
+                </td>
               </tr>
               <x-website>
                 <tr class="text-grey-black dark:text-white text-base">

apps/smp-server/static/link.html

@@ -512,6 +512,8 @@
         element.innerHTML = 'This is a one-time link of the SimpleX network user'
       } else if (url.includes('/c')) {
         element.innerHTML = 'This is a public channel address on SimpleX network'
+      } else if (url.includes('/r')) {
+        element.innerHTML = 'This is a chat relay address on SimpleX network'
       }
     }
   </script>

apps/smp-server/web/Static.hs

@@ -12,6 +12,7 @@ import Data.Char (toUpper)
 import Data.IORef (readIORef)
 import Data.Maybe (fromMaybe)
 import Data.String (fromString)
+import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Network.Socket (getPeerName)
 import Network.Wai (Application, Request (..))
@@ -22,8 +23,9 @@ import qualified Network.Wai.Handler.Warp.Internal as WI
 import qualified Network.Wai.Handler.WarpTLS as WT
 import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Server (AttachHTTP)
+import Simplex.Messaging.Server.CLI (simplexmqCommit)
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..))
+import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..), simplexmqSource)
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util (tshow)
@@ -103,6 +105,7 @@ generateSite si onionHost sitePath = do
   createLinkPage "a"
   createLinkPage "c"
   createLinkPage "g"
+  createLinkPage "r"
   createLinkPage "i"
   logInfo $ "Generated static site contents at " <> tshow sitePath
   where
@@ -116,7 +119,7 @@ generateSite si onionHost sitePath = do
 serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
 serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
   where
-    substs = substConfig <> maybe [] substInfo information <> [("onionHost", strEncode <$> onionHost)]
+    substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)]
     substConfig =
       [ ( "persistence",
           Just $ case persistence config of
@@ -131,7 +134,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
       ]
     yesNo True = "Yes"
     yesNo False = "No"
-    substInfo spi =
+    substInfo =
       concat
         [ basic,
           maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
@@ -143,10 +146,16 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
         ]
       where
         basic =
-          [ ("sourceCode", Just . encodeUtf8 $ sourceCode spi),
+          [ ("sourceCode", if T.null sc then Nothing else Just (encodeUtf8 sc)),
+            ("noSourceCode", if T.null sc then Just "none" else Nothing),
             ("version", Just $ B.pack simplexMQVersion),
+            ("commitSourceCode", Just $ encodeUtf8 $ maybe (T.pack simplexmqSource) sourceCode information),
+            ("shortCommit", Just $ B.pack $ take 7 simplexmqCommit),
+            ("commit", Just $ B.pack simplexmqCommit),
             ("website", encodeUtf8 <$> website spi)
           ]
+        spi = fromMaybe (emptyServerInfo "") information
+        sc = sourceCode spi
         conds ServerConditions {conditions, amendments} =
           [ ("usageConditions", Just $ encodeUtf8 conditions),
             ("usageAmendments", encodeUtf8 <$> amendments)
@@ -228,8 +237,8 @@ section_ label content' src =
         (inside, next') ->
           let next = B.drop (B.length endMarker) next'
            in case content' of
-                Nothing -> before <> next -- collapse section
-                Just content -> before <> item_ label content inside <> section_ label content' next
+                Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next
+                _ -> before <> next -- collapse section
   where
     startMarker = "<x-" <> label <> ">"
     endMarker = "</x-" <> label <> ">"

cabal.project

@@ -13,7 +13,7 @@ packages: .
    -- coverage: False
    -- library-coverage: False
 
-index-state: 2023-12-12T00:00:00Z
+index-state: 2025-07-01T00:00:00Z
 
 package cryptostore
     flags: +use_crypton
@@ -51,3 +51,11 @@ source-repository-package
     location: https://github.com/simplex-chat/wai.git
     tag: 2f6e5aa5f05ba9140ac99e195ee647b4f7d926b0
     subdir: warp
+
+source-repository-package
+    type: git
+    location: https://github.com/haskell-tls/hs-tls.git
+    tag: 7f060799ea762c5d7ff058d264dae5f0294fac79
+-- passes 7f060799ea762c5d7ff058d264dae5f0294fac79
+-- fails 1927590272ada1e0a32c29ca29ae9cc8d5ed3595
+    subdir: tls

rfcs/2025-03-16-smp-queues.md

@@ -5,22 +5,19 @@
 This change is related to these problems:
 - differentiating queue retention time,
 - supporting MITM-resistant short connection links,
-- improving notifications.
 
 This RFC is based on the previous discussions about short links, blob storage and notifications ([1](./2024-06-21-short-links.md), [2](./2024-09-09-smp-blobs.md), [3](./2024-11-25-queue-blobs-2.md), [4](./2024-09-25-ios-notifications-2.md)).
 
-SMP protocol supports two types of queues - queues to communicate over and queues to send invitations. While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
+SMP protocol supports two types of queues - queues to send messages (messaging queues) and queues to send invitations to connect (contact queues). While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
 
 Simply designating queue types would allow to use this information to decide for how long to retain queues, and potentially extending it:
 - unsecured 1-time invitation queues with sndSecure (support of securing by sender) - e.g., 3 months.
 - contact address queues without sndSecure - e.g., 3 years without activity.
-- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and superpeer addresses for the group.
-
-This proposal also combines NEW and NKEY command to streamline notifications in preparation to reworking of the notifications protocol.
+- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and super-peer addresses for the group.
 
 ## Design objectives
 
-We want to achieve these objectives:
+We want to achieve these objectives for short links and associated queue data:
 1. no possibility to provide incorrect SenderId inside link data (e.g. from another queue).
 2. link data cannot be accessed by the server unless it has the link.
 3. prevent MITM attack by the server, including the server that obtained the link.
@@ -28,17 +25,17 @@ We want to achieve these objectives:
 5. for one-time links, prevent accessing link data by link observers who did not compromise the server.
 6. allow changing the user-defined part of link data.
 7. avoid changing the link when user-defined part of link data changes, while preventing MITM attack by the server on user-defined part, even if it has the link.
-8. retain the quality that it is impossible to check the existense of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
+8. retain the quality that it is impossible to check the existence of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
 
-To achieve these objectives the queue data must have immutable part and mutable part.
+To achieve these objectives the queue data will include fixed (immutable) and user-defined (mutable) parts.
 
-Immutable part would include:
-- full conection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
+Fixed part would include:
+- full connection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
 - public signature key to verify mutable part of link data.
 
-Signed mutable part would inlcude:
-- any links to chat relays that should be contacted instead of this queue (not in this RFC), but would allow delegating group connections and contact request connections to prevent spam, hiding online presense, etc.
-- and user-defined data - user profile or group profile.
+Signed mutable part would include:
+- any links to chat relays that should be contacted instead of this queue (not in this RFC), to allow delegating group connections and contact request connections to prevent spam, hiding online presence, etc.
+- and user-defined data - user profile or group profile, chat preferences, welcome message, etc.
 
 The link itself should include both the key and auth tag from the encryption of immutable part. Accessing one-time link data should require providing sender key and signing the command (`LKEY`).
 
@@ -49,8 +46,6 @@ Current NEW and NKEY commands:
 ```haskell
 NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
 
-NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
-
 -- | Queue IDs and keys, returned in IDS response
 data QueueIdsKeys = QIK
   { rcvId :: RecipientId,
@@ -70,43 +65,48 @@ data NewQueueReq = NewQueueReq
     rcvDhKey :: RcvPublicDhKey,
     auth_ :: Maybe BasicAuth,
     subMode :: SubscriptionMode,
-    queueData :: Maybe QueueReqData,
-    ntfCreds :: Maybe NewNtfCreds
+    queueReqData :: Maybe QueueReqData,
   }
 
--- Replaces NKEY command
--- This avoids additional command required from the client to enable notifications.
--- Further changes would move NotifierId generation to the client, and including a signed and encrypted command to be forwarded by SMP server to notification server.
-data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey
-
 -- QRMessaging implies that sender can secure the queue.
 -- LinkId is not used with QRMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used.
 -- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists.
-data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, QueueLinkData))
+data QueueReqData
+  = QRMessaging (Maybe (SenderId, QueueLinkData))
+  | QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
 
 -- SenderId should be computed client-side as the first 24 bytes of sha3-384(correlation_id),
 -- The server must verify it and reject if it is not.
-type QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes)
+-- It allows to include sender ID inside encrypted associated link data as part of full connection URI without requesting it from the server, but prevents checking if a given sender ID exists (queue creation would fail for a duplicate sender ID), as sha3-384 derivation is not reversible.
+type QueueLinkData = (EncFixedLinkData, EncUserDataBytes)
 
-type EncImmutableDataBytes = ByteString
+type EncFixedLinkData = ByteString
 
 type EncUserDataBytes = ByteString
 
--- We need to use binary encoding for AConnectionRequestUri to reduce its size
--- connReq including the full link allows connection redundancy.
--- The clients would reject changed immutable data (based on auth tag in the link) and
--- AConnectionRequestUri where SenderId of the queue does not match.
-data ImmutableLinkData = ImmutableLinkData
-  { signature :: SignatureEd25519, -- signature of the remaining part of immutable data
-    connReq :: AConnectionRequestUri,
-    sigKey :: PublicKeyEd25519
+-- We need to use binary encoding for ConnectionRequestUri to reduce its size
+-- The clients would reject changed immutable data and
+-- ConnectionRequestUri where server or SenderId of the queue do not match.
+data FixedLinkData c = FixedLinkData
+  { agentVRange :: VersionRangeSMPA,
+    rootKey :: C.PublicKeyEd25519,
+    connReq :: ConnectionRequestUri c
   }
 
--- This part of link data can also include any relays, but possibly we need a separate blob for it
-data UserLinkData = UserLinkData
-  { signature :: SignatureEd25519, -- signs the remaining part of the data
-    userData :: ByteString -- the max size needs to be estimated, but it is likely to be ~ 14kb
-  }
+data ConnLinkData c where
+  InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
+  ContactLinkData ::
+    { agentVRange :: VersionRangeSMPA,
+      -- direct connection via connReq in fixed data is allowed.
+      direct :: Bool,
+      -- additional owner keys to sign changes of mutable data.
+      owners :: [OwnerAuth],
+      -- alternative addresses of chat relays that receive requests for this contact address.
+      relays :: [ConnShortLink 'CMContact],
+      userData :: UserLinkData
+    } -> ConnLinkData 'CMContact
+
+newtype UserLinkData = UserLinkData ByteString
 
 -- | Updated queue IDs and keys, returned in IDS response
 data QueueIdsKeys = QIK
@@ -114,17 +114,14 @@ data QueueIdsKeys = QIK
     sndId :: SenderId, -- server-generated
     rcvPublicDhKey :: RcvPublicDhKey,
     sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied?
-    linkId :: Maybe LinkId, -- server-generated
-    serverNtfCreds :: Maybe ServerNtfCreds -- currently returned in NID response
+    linkId :: Maybe LinkId -- server-generated
   }
-
-data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId is server-generated.
 ```
 
-In addition to that we add the command allowing to update and also to retrieve and, optionally, secure the queue and get link data in one request, to have only one request:
+In addition to that we add the command allowing to update and also to retrieve and secure the queue and get link data in one request, to have only one request:
 
 ```haskell
--- This command allows to set all data or to update mutlable part of contact address queue.
+-- This command allows to set all data or to update mutable part of contact address queue.
 -- This command should fail on queues that support sndSecure and also on new queues created with QRMessaging.
 -- This should fail if LinkId or immutable part of data is changed with the update, but will succeed if only mutable part is updated, so it can be retried.
 -- Entity ID is RecipientId.
@@ -147,58 +144,43 @@ LKEY :: SndPublicAuthKey -> Command Sender
 -- Entity ID is LinkId
 LGET :: Command Sender
 
--- Response to LGET, LSKEY and LSGET
+-- Response to LGET and LSET
 -- Entity ID is the same as in the command
 LNK :: SenderId -> QueueLinkData -> BrokerMsg
 ```
 
-To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID.
+To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existence, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID.
 
-To allow retries and to avoid regenerating all queue data, NEW command must be idempotent, and `correlation_id` must be preserved in command for queue creation, so that the same `correlation_id` and all other data is used in retries. `correlation_id` should be removed after queue creation success.
+To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` (and for contact queue, also `link_id`, which would be random as it is derived from hash of fixed link data that includes a random signature key) should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used.
 
-To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` / `link_id` should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used.
-
-Alternative solutions considered and rejected:
+Alternative solutions that would allow retries that were considered and rejected:
 - additional request to save queue data, after `sender_id` is returned by the server. The scenarios that require short links are interactive - creating user addresses and 1-time invitations - so making two requests instead of one would make the UX worse.
 - include empty sender_id in the immutable data and have it replaced by the accepting party with `sender_id` received in `LINK` response - both a weird design, and might create possibility for some attacks via server, especially for contact addresses.
 - making NEW commands idempotent. Doing it would require generating all IDs client-side, not only `sender_id`. It increases complexity, and it is not really necessary as the only scenarios when retries are needed are async NEW commands, that do not require short links. For future short links of chat relays the retries are much less likely, as chat relays will have good network connections.
 
 ## Algorithm to prepare and to interpret queue link data.
 
-For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existense checks.
+For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existence checks (oracle attack).
 
-**Prepare queue link data**
+This scheme results in 32 byte binary size for contact addresses and 56 bytes for 1-time invitation links.
 
-- the queue owner generates a random 256 bit `link_key` that will be used in the link URI.
-- for 1-time links: crypto_box key and 2 nonces to encrypt link data are derived from link_uri using HKDF: `cb_key <> nonce1 <> nonce2 = HKDF(link_key, 80 bytes)` (nonce1 is used for immutable and nonce2 for user-defined parts).
-- for contact address links: key and 2 nonces and linkId will be derived: `link_id <> cb_key <> nonce1 <> nonce2 = HKDF(link_key, 104 bytes)`
-- both parts of link data are encrypted with crypto_box, and included into `NEW` or `LNEW` commands.
+For fixed link data.
 
-**Retrieving queue link data**
-
-- the sender uses `LinkId` from URI (or derived from URI) as entity ID to retrieve link data.
-- for one time links the sender must authorize the request to retrieve the data, the key is provided with the first request, preventing undetected access by link observers.
-- having received the link data, the client can now decrypt it using secret_box.
-
-## Improved algorithm to prepare and to interpret queue link data.
-
-This scheme reduces the size of the binary in the link from 48 bytes (72 in case of 1-time links) to 32 bytes (56 bytes for 1-time links).
-
-For immutable data.
-
-1. `link_key = SHA3-256(immutable_data)` - used as part of link, and to encrypt content.
-2. HKDF:
+1. Generate random `nonce` (also used as a correlation ID for server command) and signature key (public `rootKey` included in fixed data).
+2. Compute sender ID from `nonce` as the first 24 bytes of sha3-384 of `nonce`.
+3. Generate other keys for queue address, including queue e2e encryption keys and double ratchet connection e2e encryption keys.
+4. Construct the full connection address to be included in fixed data.
+5. `link_key = SHA3-256(fixed_data)` - used as part of the link, and to derive the key to encrypt content.
+6. HKDF:
   1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
-  2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated. 
-3. 
-3. Random `nonce1` (for immutable data), to be stored with the link data.
-4. Encrypt: `(ct1, tag1) = secret_box(immutable_data, key, nonce1)`.
-5. Store: `(nonce1, ct1, tag1)` stored as immutable link data.
+  2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated.
+7. Encrypt: `(ct1, tag1) = secret_box(fixed_data, key, nonce1)`, where `nonce1` is a random nonce
+5. Store: `(nonce1, ct1, tag1)` stored as fixed link data.
 
 For mutable user data:
 
 1. Random `nonce2` and the same key are used.
-2. Sign `user_data` with key included in `immutable_data`.
+2. Sign `user_data` with key included in `fixed_data`.
 3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`.
 4. Store: `(nonce2, ct2, tag2)`
 
@@ -208,13 +190,15 @@ Link recipient:
 2. HKDF:
   1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
   2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`.
-3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`.
-4. Decrypt: `immutable_data = decrypt (nonce1, ct1, tag1)`.
-5. Verify: `SHA3-256(immutable_data) == link_key`, abort if not.
-6. Decrypt: `signed_used_data = decrypt(nonce2, ct2, tag2)`
-7. Verify signature with key in immutable data.
+3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`:
+  1) contact address: `LGET` command, that allows retrieving link data multiple times.
+  2) 1-time invitation: `LKEY` command, that non-optionally secures the queue, and only allows repeated link data retrievals if the same sender's key is provided and signs the transmission. This prevents link data retrieval by link observers.
+4. Decrypt: `(signature1, fixed_data) = decrypt (nonce1, ct1, tag1)`.
+5. Verify: `SHA3-256(fixed_data) == link_key`, abort if not.
+6. Decrypt: `(signature2, used_data) = decrypt(nonce2, ct2, tag2)`.
+7. Verify signatures using key in the fixed data, abort if they don't match.
 
-While using content hash as encryption key is unconventional, it is not completely unheard of - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `immutable_data` contains mostly random keys.
+While using content hash as encryption key is unconventional, it is not completely unusual - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `fixed_data` contains mostly random keys.
 
 ## Threat model
 
@@ -222,10 +206,10 @@ While using content hash as encryption key is unconventional, it is not complete
 
 can:
 - delete link data.
-- hide link selectively from some requests.
+- hide link data selectively for some or for all requests.
 
 cannot:
-- undetectably replace link data, even if they have the link (objective 3).
+- undetectably replace link data, even if it has the link (objective 3).
 - access unencrypted link data, whether it was or was not accessed by the accepting party, provided it has no link (objective 2).
 - observe IP addresses of the users accessing link data, if private routing is used.
 
@@ -236,10 +220,10 @@ can:
 
 cannot:
 - undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5).
-- undetectbly check the existense of messaging queue or 1-time link (objective 8).
+- undetectably check the existence of messaging queue or 1-time link (objective 8).
 - replace or delete the link data.
 
-**Queue owner who did not comprmise the server**:
+**Queue owner who did not compromise the server**:
 
 cannot:
 - redirect connecting user to another queue, on the same or on another server (objective 1).
@@ -247,40 +231,42 @@ cannot:
 
 ## Correlation of design objectives with design elements
 
-1. The presense of `SenderId` in `LINK` response from the server.
+1. The presence of `SenderId` in `LNK` response from the server.
 2. Encryption of link data with crypto_box.
-3. Auth tag in the link prevents server modification of immutable part of link data. Signature verification key in immutable part, and signing of mutable part prevents server modification of mutable part of link data.
-4. No server command to change immutable part of link data once it's set.
+3. Deriving encryption key from the hash of fixed data prevents it being modified by the server - any change would be detected and rejected by the client, as the hash of fixed data won't match the link. Signature verification with the key from fixed data, and signing of mutable data prevents server modification of mutable data.
+4. No server command to change fixed data once it's set. Also, changing fixed data would require changing the link.
 5. 1-time link data can only be accessed with `LKEY` command, that while allows retries to mitigate network failures, will require the same key for retries.
 6. `LSET` command.
-7. The link only includes auth tag for immutable part, mutable part includes signature.
-8. Temporarily public IDs (SenderId and LinkId for 1-time invitations) are generated server-side, and cannot be provided by the clients when creating the queues to check if these IDs are free.
+7. The link is derived from fixed data only, so it does not change when mutable link data changes. Mutable part is signed preventing server MITM attacks.
+8. SenderId is derived from request correlation ID, so it cannot be arbitrary defined to check existence of some known queue. LinkId for 1-time invitation is generated server-side, so it cannot be provided by the client when creating the queues to check if these IDs are used.
 
 ## Syntax for short links
 
-The proposed syntax:
+The syntax:
 
 ```abnf
-shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ]
+shortConnectionLink = uriAuthority "/" linkUri [ "?" param *( "&" param ) ]
+uriAuthority = %s"https://" smpServerHost / "simplex:" ; using simplex: scheme requires including host in the parameter hostParam
 smpServerHost = <hostname> ; RFC1123, RFC5891
-linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes
-oneTimeLinkBytes = <base64url(linkId | linkKey)> ; 56 bytes / 75 base64 encoded characters
-contactLinkBytes = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
-; linkId - 96 bits/24 bytes
+linkUri = %s"i#" oneTimeLink / contactType "#" contactLink
+contactType = %s"a" / %s"g" / %s"c" ; contact / group / channel address, respectively
+oneTimeLink = <base64url(linkId)> "/" <base64url(linkKey)> ; 56 bytes / 75 base64 encoded characters
+contactLink = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
+; linkId - 192 bits/24 bytes
 ; linkKey - 256 bits/32 bytes
 
-serverInfo = [fingerprint "@" [hostnames "/"]] ; not needed for preset servers, required otherwise - the clients must refuse to connect if they don't have fingerprint in the code.
-
-fingerprint = <base64url(server offline certificate fingerprint)>
-hostnames = "h=" <hostname> *( "," <hostname> ) ; additional hostnames, e.g. onion
+param = hostsParam / portParam / certHashParam
+hostsParam = %s"h=" host *("," host) ; additional hostnames, e.g. onion
+portParam = %s"p=" 1*DIGIT ; server port
+certHashParam = %s"c=" <base64url(server offline certificate fingerprint)>
 ```
 
-To have shorter links fingerpring and additional server hostnames do not need to be specified for preconfigured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint.
+To have shorter links fingerprint and additional server hostnames do not need to be specified for pre-configured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint.
 
-Example one-time link for preset server (103 characters):
+Example one-time link for preset server (104 characters):
 
 ```
-https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234
+https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij01/23456789abcdefghij0123456789abcdefghij01234
 ```
 
 Example contact link for preset server (71 characters):
@@ -289,16 +275,16 @@ Example contact link for preset server (71 characters):
 https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc
 ```
 
-Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters):
+Example contact link for user-defined server (with fingerprint, but without onion hostname - 117 characters):
 
 ```
-https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc
+https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU
 ```
 
-Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters):
+Example contact link for user-defined server (with fingerprint ant onion hostname - 182 characters):
 
 ```
-https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
+https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU&h=beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion
 ```
 
 For the links to work in the browser the servers must provide server pages.

rfcs/2025-07-15-multi-device.md

@@ -0,0 +1,104 @@
+# Using the same profile from multiple devices
+
+## Problem
+
+Double Ratchet algorithm makes it hard to send/receive messages sent to the user from different devices, as each message changes the state of Double Ratchet keys, and these state changes must be strictly sequential and they cannot be reversed (although skipping is possible).
+
+Traditional approach for multi-device converts each direct conversation into a group, where each device participates as a member. Likewise, for group conversations each device also participates as a member. While these members *look* as if they are the same user to others, a very simple client app modification may show device ID for each message, and the communication peers, both in direct chats and in groups would know how many devices a user has and which device the user sent the message from. In addition to that, with this approach communication peers can send different messages to different devices (it can be prevented by provider who would request that only message key is encrypted with DR, while the encrypted message is the same) or withheld from some devices (it cannot be prevented by provider, as it cannot add key to the communication in case it is missing, and cannot withhold the message completely too). These opens various vectors for targeted attacks, e.g.:
+- tracking movements of the user: once each devices is identified as "desk" and "phone" it would allow to know where the user is at a given time.
+- manipulating information by sending messages to one device (to have proof it was sent) and withholding from others, or sending different messages if the protocol allows it.
+
+In addition to that, the specific implementation of this approach in Signal compromises break-in recovery property (aka post-compromise security) of Double-Ratchet algorithm, making its design ineffective - the only reason to have the second ratchet in DR algorithm is to provide break-in recovery, without it a much simpler design with a single ratchet is sufficient. See [this paper](https://eprint.iacr.org/2021/626.pdf) for details.
+
+While this limitation can be addressed with notifications when a new device is added and per-device keys, we still find the remaining attack vectors on user security and privacy to be unacceptable, and opening unsuspecting users to various criminal actions - and it is wrong to say that would only affect security conscious users, and most people would not be affected by these risks. Allowing potential criminals in groups to know which device you are currently using is a real risk for all users.
+
+Another approach was offered by Threema that is ["mediator" server](https://threema.com/en/blog/md-architectural-overview) where the state of encryption ratchets is stored server-side. While it protects the user from their communication peers, it increases required level of trust to the servers, and in case of SimpleX network it would expose the knowledge of who communicates to whom. So while the idea of server-side storage of encryption state is promising, it has to be per-connection, to retain "no-accounts" property of SimpleX messaging network.
+
+Also see [FAQ](https://simplex.chat/faq/#why-cant-i-use-the-same-profile-on-different-devices) and [this issue](https://github.com/simplex-chat/simplex-chat/issues/444#issuecomment-3066968358).
+
+## Proposed solution
+
+One of the ideas presented in FAQ - to store the state of Double Ratchet algorithm in the encrypted container on the server seems promising. The RFC develops this idea.
+
+### Considerations for the design
+
+1. The largest ratchet state size with the current implementation is less than 8kb (which is achieved when both sides shared PQ keys and ciphertexts), so while it cannot fit in the same transport blocks together with sent and received messages, it would fit in one transport block.
+
+2. Protocol commands and events may be changed (even if at the cost of slightly reducing message size) can fit the hash of the ratchet state (32 bytes sha256 would be sufficient), so that the client can determine whether it has the most recent ratchet state or if it needs to retrieve the latest copy. Message size reduction won't affect the users because we use compression, and there is a substantial reserve.
+
+3. Client commands that modify ratchet state would include the hash of the previous ratchet state so that the server can reject or ignore the command in case the previous ratchet state is different or in case command is repeated in case of lost response).
+
+4. The client does not need to retrieve message state for each encryption and decryption operation - it can "speculatively" use the ratchet state it has, and receive correct ratchet state in the "error" response after attempting encryption based on incorrect ratchet state.
+
+## Proposed protocol design
+
+Ratchet state will be stored on the same server that stores message queue, as part of message queue record. 8kb is a sufficient size for this blob (the actual max size is 7800 bytes). The server would also store the hashes of the current and, possibly, the previous ratchet states (TBC).
+
+While ratchet is used for duplex connection, the connection still has primary queue, and with redundancy the same ratchet state can be stored on all secondary queues.
+
+Ratchet state will be encrypted using secret_box - a symmetric encryption scheme, so PQ-resistant. If ratchet state is stored on more than one server, it has to be encrypted with a different key for each server.
+
+Questions: how to rotate the key used to store ratchet? Should key used to encrypt ratchet rotate at the same time when queue is rotated? The latter is a logical option, as it prevents additional complexity and solves the problem anyway. A possible option is to have "ratchet version" that will be used to advance the key used to encrypt ratchet via HKDF.
+
+Security considerations: the scheme may reduce break-in recovery to the points queues are rotated, unless there is some randomness mixed-in into the key derivation (the key used to encrypt ratchet state). But including randomness would defeat the purpose, as other devices wouldn't be able to access the ratchets. Another approach would be to have each device use its own key for encryption, and encrypt to all keys of all devices (or to encrypt key, to avoid size increase). Having multiple encryptions would show how many devices use the queue, but servers already can observe it, so it is a better tradeoff. Another idea would be to rotate the key used to authorize queue commands - we already support multiple recipient keys, and it can be used for multi-device scenario. That would partially mitigate break-in attacks as the attacker who obtained the key from ratchet state would be able to decrypt it, but won't be able to decrypt it (the attacker collusion with the server is not mitigated). Yet another idea would be for each party (device) to share its private (or encapsulation) key and to have a symmetric key (used to encrypt the ratchet state) encrypted (encapsulated) separately for each device. This would reduce the size of the stored data to `ratchet size` + `encrypted key size` * N, so even in case of PQ encryption (e.g. sntrup) the size required to store the ratchet would be under transport block size, while limiting it to say 4-8 devices, which is sufficient.
+
+To participate in multi-device scheme the devices would join the usual group that will be used to share public (encapsulation) device keys and to communicate updates to conversations that were received by the currently "active" device. "Active" means the device that received or sent and processed the message, and while only one device can receive messages from a given queue, device "active" state may be determined per queue, allowing concurrent usage.
+
+The scheme must be resilient to state updates being lost, and in case of direct messages it would result in some messages not being shown (or shown as skipped), while conversation preference and profile updates can be re-requested from peers, while the current profile of the user would become the latest. Likewise, for groups state updates ca be requested from super-peers or for decentralized groups - from owners. Maintaining chat state consistency is an important consideration, but is not a focus of this RFC - the focus is managing message delivery and DR encryption for multiple devices. Other multi-device schemes have the same issues with state consistency. Partially, the profile state consistency can be improved by using a single shared queue (or set of queues) to store user's profile and chat preferences to synchronize profile updates asynchronously between the devices.
+
+## The protocol to send the message
+
+`rsi` - ratchet state on device `i`.
+
+`enc(rs)` - current authoritative ratchet state on the server.
+
+`pt` and `ct` - plaintext and ciphertext messages.
+
+Encryption is a state transition function ratchetEnc: `(ct, rs') = ratchetEnc(pt, rs)`.
+
+1. Device encrypts the message using the stored ratchet state: `(ct, rsi') = ratchetEnc(pt, rsi)`
+
+2. Device sends modified encrypted ratchet state and the hash of the previous encrypted state to the server that stores the queue: `RSET (hash(enc(rsi)), enc(rsi'))`.
+
+3. If the hash of the previous state matches state stored on the server (`hash(enc(rsi)) == hash(enc(rs))`), the server updates the state and responds with `ratchet_ok` (that may include the current state or it's hash, for validation). If the hash is different, the server responds with `bad_ratchet(enc(rs))` message that includes the correct ratchet state. These updates must be atomic. In this case device has to update the local ratchet state (provided it can decrypt it), and repeat encryption attempt. If device cannot decrypt the provided ratchet state, it means that the connection is disrupted (possibly, device is removed from device group, but missed the notifications).
+
+4. After successful state update in primary receiving queue, the device would update it in secondary receiving queues.
+
+5. Device sends encrypted message as usual, via proxy that must be different both from the server that stores the ratchet and from the destination server.
+
+6. Device broadcasts sent message and new ratchet state to other devices in the device group.
+
+This protocol is simple, and it minimizes requests when sending the message to one additional request to update ratchet state in most cases, only requiring two requests when device state was not updated via device group prior to message sending attempt.
+
+## The protocol to receive the message
+
+Decryption is also a state transition function: `(pt, rs') = ratchetDec(ct, rs)`
+
+1. Server sends the message to the device (can be in response to SUB or ACK commands, or with active subscription). Pushed message would include the hash of the currently stored ratchet state: `hash(enc(rs))`.
+
+2. If device has the ratchet state with the same hash (`hash(enc(rs)) == hash(enc(rsi))`), it decrypts the message: `(pt, rsi') = ratchetDec(ct, rsi)`.
+
+3. If device has ratchet state with a different hash, it requests ratchet from the server with additional protocol command `RGET` with response `RCHT (enc(rs))` and updates the local state.
+
+4. Device decrypts the message `(pt, rsi') = ratchetDec(ct, rsi)` and processes it as usual.
+
+5. Device sends acknowledgement to the server as usual, but now it includes the new ratchet state and the hash of the previous state: `ACK msgId (hash(enc(rsi)), enc(rsi'))`
+
+6. The server compares ratchet state with stored state hash, and in case it matches it processes `ACK` and responds with `OK` as usual (or `NO_MSG` in case msgId is incorrect, also as usual - it would happen in repeated ACK requests). If ratchet state hash does not match, the server would respond with `bad_ratchet(enc(rs))` - which means that the message was already processed by another device and ratchet was advanced. This is a complex scenario, as the client has to either revert the change from message processing or somehow combine the change with the updates communicated via device group (as a side note, device group can simply re-broadcast messages, not state updates, but it will result in state divergence between devices when different messages are lost).
+
+Unlike sending messages, this flow does not require any additional requests in most cases, only requiring requesting message state reconciliation when the same message was received and processed by more than one client, but it does not require re-acknowledgement.
+
+## Challenges
+
+This is an idea of the design rather than the actual design, as it requires more thinking about:
+- how to handle concurrent ratchet state updates,
+- "active" status transitions per queue,
+- avoiding concurrent subscriptions to queues from multiple devices,
+- state updates and synchronization between devices,
+- handling skipped messages,
+- costs to update ratchets in bulk send scenario - this scheme would substantially increase costs of preparing large broadcasts, and it makes this scheme not acceptable for chat relays. Which means that "profile" on desktop used as chat relay won't be synched to other devices.
+- etc.
+
+## Advantages
+
+The communication peers won't know how many devices the user has, and which device was used to send the message. Also, the communication peers won't be able to send different messages to different user's devices, or to withhold messages from some devices.

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.4.0.10.1
+version:        6.5.0.0.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -162,6 +162,7 @@ library
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -208,6 +209,14 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
+  if flag(client_postgres) || flag(server_postgres)
+      exposed-modules:
+          Simplex.Messaging.Agent.Store.Postgres
+          Simplex.Messaging.Agent.Store.Postgres.Common
+          Simplex.Messaging.Agent.Store.Postgres.DB
+          Simplex.Messaging.Agent.Store.Postgres.Migrations
+          Simplex.Messaging.Agent.Store.Postgres.Util
   if !flag(client_library)
       exposed-modules:
           Simplex.FileTransfer.Client.Main
@@ -215,6 +224,7 @@ library
           Simplex.FileTransfer.Server.Control
           Simplex.FileTransfer.Server.Env
           Simplex.FileTransfer.Server.Main
+          Simplex.FileTransfer.Server.Prometheus
           Simplex.FileTransfer.Server.Stats
           Simplex.FileTransfer.Server.Store
           Simplex.FileTransfer.Server.StoreLog
@@ -224,6 +234,7 @@ library
           Simplex.Messaging.Server.Env.STM
           Simplex.Messaging.Server.Information
           Simplex.Messaging.Server.Main
+          Simplex.Messaging.Server.Main.GitCommit
           Simplex.Messaging.Server.Main.Init
           Simplex.Messaging.Server.MsgStore
           Simplex.Messaging.Server.MsgStore.Journal
@@ -240,14 +251,6 @@ library
           Simplex.Messaging.Server.StoreLog.ReadWrite
           Simplex.Messaging.Server.StoreLog.Types
           Simplex.Messaging.Transport.WebSockets
-      if flag(client_postgres) || flag(server_postgres)
-          exposed-modules:
-              Simplex.Messaging.Agent.Store.Postgres
-              Simplex.Messaging.Agent.Store.Postgres.Common
-              Simplex.Messaging.Agent.Store.Postgres.DB
-              Simplex.Messaging.Agent.Store.Postgres.Migrations
-              Simplex.Messaging.Agent.Store.Postgres.Util
-
       if flag(server_postgres)
           exposed-modules:
               Simplex.Messaging.Notifications.Server
@@ -263,6 +266,7 @@ library
               Simplex.Messaging.Notifications.Server.Store.Postgres
               Simplex.Messaging.Notifications.Server.Store.Types
               Simplex.Messaging.Notifications.Server.StoreLog
+              Simplex.Messaging.Server.MsgStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres.Migrations
   other-modules:
@@ -290,7 +294,7 @@ library
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
-    , crypton ==0.34.*
+    , crypton ==1.0.*
     , crypton-x509 ==1.7.*
     , crypton-x509-store ==1.6.*
     , crypton-x509-validation ==1.6.*
@@ -316,7 +320,7 @@ library
     , stm ==2.5.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls ==2.1.6.*
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -352,10 +356,12 @@ library
   if impl(ghc >= 9.6.2)
     build-depends:
         bytestring ==0.11.*
+      , template-haskell ==2.20.*
       , text >=2.0.1 && <2.2
   if impl(ghc < 9.6.2)
     build-depends:
         bytestring ==0.10.*
+      , template-haskell ==2.16.*
       , text >=1.2.3.0 && <1.3
 
 executable ntf-server
@@ -559,7 +565,7 @@ test-suite simplexmq-test
     build-depends:
         memory
       , sqlcipher-simple
-  if !flag(client_postgres) || flag(server_postgres)
+  if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres)
     build-depends:
         deepseq ==1.4.*
       , process

src/Simplex/FileTransfer/Agent.hs

@@ -75,7 +75,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (strDecode, strEncode)
 import Simplex.Messaging.Protocol (ProtocolServer, ProtocolType (..), XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
+import Simplex.Messaging.Util (allFinally, catchAll_, catchAllErrors, liftError, tshow, unlessM, whenM)
 import System.FilePath (takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Directory
@@ -198,10 +198,10 @@ runXFTPRcvWorker c srv Worker {doWork} = do
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv downloadAttempts
             downloadFileChunk fc replica approvedRelays
-              `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAllErrors` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAgentError (\_ -> pure ()) $ do
+              flip catchAllErrors (\_ -> pure ()) $ do
                 when (serverHostError e) $ notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFWARN e)
                 liftIO $ closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
@@ -280,7 +280,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
     runXFTPOperation AgentConfig {rcvFilesTTL} =
       withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
         \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath, redirect} ->
-          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
+          decryptFile f `catchAllErrors` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
     decryptFile :: RcvFile -> AM ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
       let CryptoFile savePath cfArgs = saveFile
@@ -307,7 +307,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
           liftIO $ 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)
+          yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `allFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
           next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
             -- TODO switch to another error constructor
             Left _ -> throwE . FILE $ REDIRECT "decode error"
@@ -399,7 +399,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
     runXFTPOperation cfg@AgentConfig {sndFilesTTL} =
       withWork c doWork (`getNextSndFileToPrepare` sndFilesTTL) $
         \f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
-          prepareFile cfg f `catchAgentError` sndWorkerInternalError c sndFileId sndFileEntityId prefixPath
+          prepareFile cfg f `catchAllErrors` sndWorkerInternalError c sndFileId sndFileEntityId prefixPath
     prepareFile :: AgentConfig -> SndFile -> AM ()
     prepareFile _ SndFile {prefixPath = Nothing} =
       throwE $ INTERNAL "no prefix path"
@@ -468,11 +468,11 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
                 liftIO $ waitForUserNetwork c
                 let triedAllSrvs = n > userSrvCount
                 createWithNextSrv triedHosts
-                  `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
+                  `catchAllErrors` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
               where
                 -- we don't do closeXFTPServerClient here to not risk closing connection for concurrent chunk upload
                 retryLoop loop triedAllSrvs e = do
-                  flip catchAgentError (\_ -> pure ()) $ do
+                  flip catchAllErrors (\_ -> pure ()) $ do
                     when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e
                   liftIO $ assertAgentForeground c
                   loop
@@ -508,10 +508,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv uploadAttempts
             uploadFileChunk cfg fc replica
-              `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAllErrors` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAgentError (\_ -> pure ()) $ do
+              flip catchAllErrors (\_ -> pure ()) $ do
                 when (serverHostError e) $ notify c sndFileEntityId $ SFWARN e
                 liftIO $ closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
@@ -681,10 +681,10 @@ runXFTPDelWorker c srv Worker {doWork} = do
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv deleteAttempts
             deleteChunkReplica
-              `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAllErrors` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAgentError (\_ -> pure ()) $ do
+              flip catchAllErrors (\_ -> pure ()) $ do
                 when (serverHostError e) $ notify c "" $ SFWARN e
                 liftIO $ closeXFTPServerClient c userId server chunkDigest
                 withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay

src/Simplex/FileTransfer/Client.hs

@@ -31,18 +31,22 @@ import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
+import Network.Socket (HostName)
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
+    NetworkRequestMode (..),
     ProtocolClientError (..),
     TransportSession,
+    netTimeoutInt,
     chooseTransportHost,
     defaultNetworkConfig,
     transportClientConfig,
     clientSocksCredentials,
     unexpectedResponse,
+    useWebPort,
   )
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -55,6 +59,8 @@ import Simplex.Messaging.Protocol
     RecipientId,
     SenderId,
     pattern NoEntity,
+    NetworkError (..),
+    toNetworkError,
   )
 import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
@@ -102,12 +108,13 @@ defaultXFTPClientConfig =
       clientALPN = Just alpnSupportedXFTPhandshakes
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
+      useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN
+  let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False useALPN
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -119,7 +126,8 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
       thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
-    Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
+    Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
+      xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
     _ -> pure thParams0
   logDebug $ "Client negotiated protocol: " <> tshow thVersion
   let c = XFTPClient {http2Client, thParams, transportSession, config}
@@ -178,14 +186,14 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = defaultSupportedParams,
-      connTimeout = tcpConnectTimeout,
+      connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
       transportConfig
     }
 
 xftpClientError :: HTTP2ClientError -> XFTPClientError
 xftpClientError = \case
   HCResponseTimeout -> PCEResponseTimeout
-  HCNetworkError -> PCENetworkError
+  HCNetworkError e -> PCENetworkError e
   HCIOError e -> PCEIOError e
 
 sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
@@ -255,9 +263,9 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
         ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwE PCEResponseTimeout) pure
         where
           errors =
-            [ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError,
-              Handler $ \(e :: IOException) -> pure $ Left (PCEIOError e),
-              Handler $ \(_e :: SomeException) -> pure $ Left PCENetworkError
+            [ Handler $ \(e :: H.HTTP2Error) -> pure $ Left $ PCENetworkError $ NEConnectError $ displayException e,
+              Handler $ \(e :: IOException) -> pure $ Left $ PCEIOError e,
+              Handler $ \(e :: SomeException) -> pure $ Left $ PCENetworkError $ toNetworkError e
             ]
           download cbState =
             runExceptT . withExceptT PCEResponseError $
@@ -268,11 +276,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
 
 xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
 xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
-  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
+  maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
 
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
 chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
-  tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
+  netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
 
 deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse

src/Simplex/FileTransfer/Client/Agent.hs

@@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Simplex.FileTransfer.Client
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
+import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
 import Simplex.Messaging.TMap (TMap)
@@ -71,7 +71,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
     connectClient =
       ExceptT $
         first (XFTPClientAgentError srv)
-          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected
+          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt clientDisconnected
 
     clientDisconnected :: XFTPClient -> IO ()
     clientDisconnected _ = do
@@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
       let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
-      client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
+      client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
       liftEither $ case client_ of
         Just (Right c) -> Right c
         Just (Left e) -> Left e
@@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
   where
     closeClient cVar = do
       let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
-      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+      netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
         _ -> pure ()

src/Simplex/FileTransfer/Server.hs

@@ -45,6 +45,7 @@ import Network.Socket
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Server.Control
 import Simplex.FileTransfer.Server.Env
+import Simplex.FileTransfer.Server.Prometheus
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
@@ -54,7 +55,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
-import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
+import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
@@ -69,6 +70,7 @@ import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.Server (runLocalTCPServer)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import System.Environment (lookupEnv)
 import System.Exit (exitFailure)
 import System.FilePath ((</>))
 import System.IO (hPrint, hPutStrLn, universalNewlineMode)
@@ -105,7 +107,14 @@ xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
 xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
   mapM_ (expireServerFiles Nothing) fileExpiration
   restoreServerStats
-  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
+  raceAny_
+    ( runServer
+        : expireFilesThread_ cfg
+          <> serverStatsThread_ cfg
+          <> prometheusMetricsThread_ cfg
+          <> controlPortThread_ cfg
+    )
+    `finally` stopServer
   where
     runServer :: M ()
     runServer = do
@@ -124,7 +133,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
             req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
         flip runReaderT env $ case sessionALPN of
           Nothing -> processRequest req0
-          Just "xftp/1" ->
+          Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
             xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
               Nothing -> pure () -- handshake response sent
               Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
@@ -240,6 +249,30 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               ]
         liftIO $ threadDelay' interval
 
+    prometheusMetricsThread_ :: XFTPServerConfig -> [M ()]
+    prometheusMetricsThread_ XFTPServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} =
+      [savePrometheusMetrics interval prometheusMetricsFile]
+    prometheusMetricsThread_ _ = []
+
+    savePrometheusMetrics :: Int -> FilePath -> M ()
+    savePrometheusMetrics saveInterval metricsFile = do
+      labelMyThread "savePrometheusMetrics"
+      liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile
+      ss <- asks serverStats
+      rtsOpts <- liftIO $ maybe ("set " <> rtsOptionsEnv) T.pack <$> lookupEnv (T.unpack rtsOptionsEnv)
+      let interval = 1000000 * saveInterval
+      liftIO $ forever $ do
+        threadDelay interval
+        ts <- getCurrentTime
+        sm <- getFileServerMetrics ss rtsOpts
+        T.writeFile metricsFile $ xftpPrometheusMetrics sm ts
+
+    getFileServerMetrics :: FileServerStats -> T.Text -> IO FileServerMetrics
+    getFileServerMetrics ss rtsOptions = do
+      d <- getFileServerStatsData ss
+      let fd = periodStatDataCounts $ _filesDownloaded d
+      pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions}
+
     controlPortThread_ :: XFTPServerConfig -> [M ()]
     controlPortThread_ XFTPServerConfig {controlPort = Just port} = [runCPServer port]
     controlPortThread_ _ = []
@@ -277,12 +310,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+              CPAuth auth -> controlPortAuth h user admin role auth
                 where
-                  newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
-                    | Just auth == admin = CPRAdmin
-                    | Just auth == user = CPRUser
-                    | otherwise = CPRNone
+                  XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
               CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
               CPDelete fileId -> withUserRole $ unliftIO u $ do
                 fs <- asks store

src/Simplex/FileTransfer/Server/Env.hs

@@ -64,6 +64,8 @@ data XFTPServerConfig = XFTPServerConfig
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
+    prometheusInterval :: Maybe Int,
+    prometheusMetricsFile :: FilePath,
     transportConfig :: TransportServerConfig,
     responseDelay :: Int
   }

src/Simplex/FileTransfer/Server/Main.hs

@@ -27,10 +27,10 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
-import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -60,7 +60,7 @@ xftpServerCLI cfgPath logPath = do
       putStrLn "Deleted configuration and log files"
   where
     iniFile = combine cfgPath "file-server.ini"
-    serverVersion = "SimpleX XFTP server v" <> simplexMQVersion
+    serverVersion = "SimpleX XFTP server v" <> simplexmqVersionCommit
     defaultServerPort = "443"
     executableName = "file-server"
     storeLogFilePath = combine logPath "file-server-store.log"
@@ -89,6 +89,9 @@ xftpServerCLI cfgPath logPath = do
             <> "# Expire files after the specified number of hours.\n"
             <> ("expire_files_hours: " <> tshow defFileExpirationHours <> "\n\n")
             <> "log_stats: off\n\
+               \\n\
+               \# Log interval for real-time Prometheus metrics\n\
+               \# prometheus_interval: 60\n\
                \\n\
                \[AUTH]\n\
                \# Set new_files option to off to completely prohibit uploading new files.\n\
@@ -188,10 +191,12 @@ xftpServerCLI cfgPath logPath = do
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "file-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
+              prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
+              prometheusMetricsFile = combine logPath "xftp-server-metrics.txt",
               transportConfig =
                 mkTransportServerConfig
                   (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just alpnSupportedXFTPhandshakes)
+                  (Just $ alpnSupportedXFTPhandshakes <> httpALPN)
                   False,
               responseDelay = 0
             }

src/Simplex/FileTransfer/Server/Prometheus.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
+
+module Simplex.FileTransfer.Server.Prometheus where
+
+import Data.Int (Int64)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime (..), diffUTCTime)
+import Data.Time.Clock.System (systemEpochDay)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Simplex.FileTransfer.Server.Stats
+import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
+import Simplex.Messaging.Transport (simplexMQVersion)
+import Simplex.Messaging.Util (tshow)
+
+data FileServerMetrics = FileServerMetrics
+  { statsData :: FileServerStatsData,
+    filesDownloadedPeriods :: PeriodStatCounts,
+    rtsOptions :: Text
+  }
+
+rtsOptionsEnv :: Text
+rtsOptionsEnv = "XFTP_RTS_OPTIONS"
+
+{-# FOURMOLU_DISABLE\n#-}
+xftpPrometheusMetrics :: FileServerMetrics -> UTCTime -> Text
+xftpPrometheusMetrics sm ts =
+  time <> files <> info
+  where
+    FileServerMetrics {statsData, filesDownloadedPeriods, rtsOptions} = sm
+    FileServerStatsData
+      { _fromTime,
+        _filesCreated,
+        _fileRecipients,
+        _filesUploaded,
+        _filesExpired,
+        _filesDeleted,
+        _filesBlocked,
+        _fileDownloads,
+        _fileDownloadAcks,
+        _filesCount,
+        _filesSize
+      } = statsData
+    time =
+      "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
+      \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\
+      \\n"
+    files =
+      "# Files\n\
+      \# -----\n\
+      \\n\
+      \# HELP simplex_xftp_files_created Created files\n\
+      \# TYPE simplex_xftp_files_created counter\n\
+      \simplex_xftp_files_created " <> mshow _filesCreated <> "\n\
+      \# filesCreated\n\
+      \\n\
+      \# HELP simplex_xftp_files_recipients Files recipients\n\
+      \# TYPE simplex_xftp_files_recipients counter\n\
+      \simplex_xftp_files_recipients " <> mshow _fileRecipients <> "\n\
+      \# fileRecipients\n\
+      \\n\
+      \# HELP simplex_xftp_files_uploaded Uploaded files\n\
+      \# TYPE simplex_xftp_files_uploaded counter\n\
+      \simplex_xftp_files_uploaded " <> mshow _filesUploaded <> "\n\
+      \# filesUploaded\n\
+      \\n\
+      \# HELP simplex_xftp_files_expired Expired files\n\
+      \# TYPE simplex_xftp_files_expired counter\n\
+      \simplex_xftp_files_expired " <> mshow _filesExpired <> "\n\
+      \# filesExpired\n\
+      \\n\
+      \# HELP simplex_xftp_files_deleted Deleted files\n\
+      \# TYPE simplex_xftp_files_deleted counter\n\
+      \simplex_xftp_files_deleted " <> mshow _filesDeleted <> "\n\
+      \# filesDeleted\n\
+      \\n\
+      \# HELP simplex_xftp_files_blocked Blocked files\n\
+      \# TYPE simplex_xftp_files_blocked counter\n\
+      \simplex_xftp_files_blocked " <> mshow _filesBlocked <> "\n\
+      \# filesBlocked\n\
+      \\n\
+      \# HELP simplex_xftp_file_downloads File downloads\n\
+      \# TYPE simplex_xftp_file_downloads counter\n\
+      \simplex_xftp_file_downloads " <> mshow _fileDownloads <> "\n\
+      \# fileDownloads\n\
+      \\n\
+      \# HELP simplex_xftp_file_download_acks File download ACKs\n\
+      \# TYPE simplex_xftp_file_download_acks counter\n\
+      \simplex_xftp_file_download_acks " <> mshow _fileDownloadAcks <> "\n\
+      \# fileDownloadAcks\n\
+      \\n\
+      \# HELP simplex_xftp_files_count_total Total files count \n\
+      \# TYPE simplex_xftp_files_count_total gauge\n\
+      \simplex_xftp_files_count_total " <> mshow _filesCount <> "\n\
+      \# filesCount\n\
+      \\n\
+      \# HELP simplex_xftp_files_size Size of files \n\
+      \# TYPE simplex_xftp_files_size gauge\n\
+      \simplex_xftp_files_size " <> mshow _filesSize <> "\n\
+      \# filesSize \n\
+      \\n\
+      \# HELP simplex_xftp_files_count_daily Daily files count\n\
+      \# TYPE simplex_xftp_files_count_daily gauge\n\
+      \simplex_xftp_files_count_daily " <> mstr (dayCount filesDownloadedPeriods) <> "\n\
+      \# filesDownloaded.dayCount\n\
+      \\n\
+      \# HELP simplex_xftp_files_count_weekly Weekly files count\n\
+      \# TYPE simplex_xftp_files_count_weekly gauge\n\
+      \simplex_xftp_files_count_weekly " <> mstr (weekCount filesDownloadedPeriods) <> "\n\
+      \# filesDownloaded.weekCount\n\
+      \\n\
+      \# HELP simplex_xftp_files_count_monthly Monthly files count\n\
+      \# TYPE simplex_xftp_files_count_monthly gauge\n\
+      \simplex_xftp_files_count_monthly " <> mstr (monthCount filesDownloadedPeriods) <> "\n\
+      \# filesDownloaded.monthCount\n\
+      \\n"
+    info =
+      "# Info\n\
+      \# ----\n\
+      \\n\
+      \# HELP simplex_xftp_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
+      \# TYPE simplex_xftp_info gauge\n\
+      \simplex_xftp_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
+      \\n"
+    mstr a = a <> " " <> tsEpoch
+    mshow :: Show a => a -> Text
+    mshow = mstr . tshow
+    tsEpoch = tshow @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    epoch = UTCTime systemEpochDay 0
+{-# FOURMOLU_ENABLE\n#-}

src/Simplex/FileTransfer/Transport.hs

@@ -14,6 +14,7 @@ module Simplex.FileTransfer.Transport
     blockedFilesXFTPVersion,
     xftpClientHandshakeStub,
     alpnSupportedXFTPhandshakes,
+    xftpALPNv1,
     XFTPClientHandshake (..),
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
@@ -105,7 +106,10 @@ xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> V
 xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion
 
 alpnSupportedXFTPhandshakes :: [ALPN]
-alpnSupportedXFTPhandshakes = ["xftp/1"]
+alpnSupportedXFTPhandshakes = [xftpALPNv1]
+
+xftpALPNv1 :: ALPN
+xftpALPNv1 = "xftp/1"
 
 data XFTPServerHandshake = XFTPServerHandshake
   { xftpVersionRange :: VersionRangeXFTP,

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

@@ -27,11 +27,6 @@ module Simplex.Messaging.Agent.Env.SQLite
     serverHosts,
     defaultAgentConfig,
     defaultReconnectInterval,
-    tryAgentError,
-    tryAgentError',
-    catchAgentError,
-    catchAgentError',
-    agentFinally,
     Env (..),
     newSMPAgentEnv,
     createAgentStore,
@@ -45,7 +40,6 @@ module Simplex.Messaging.Agent.Env.SQLite
 where
 
 import Control.Concurrent (ThreadId)
-import Control.Exception (BlockedIndefinitelyOnSTM (..), SomeException, fromException)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -70,7 +64,7 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (createStore)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import Simplex.Messaging.Agent.Store.Interface (DBOpts)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -83,7 +77,6 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
@@ -273,7 +266,7 @@ newSMPAgentEnv config store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 
 data NtfSupervisor = NtfSupervisor
@@ -312,33 +305,6 @@ newXFTPAgent = do
   xftpDelWorkers <- TM.emptyIO
   pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
 
-tryAgentError :: AM a -> AM (Either AgentErrorType a)
-tryAgentError = tryAllErrors mkInternal
-{-# INLINE tryAgentError #-}
-
--- unlike runExceptT, this ensures we catch IO exceptions as well
-tryAgentError' :: AM a -> AM' (Either AgentErrorType a)
-tryAgentError' = tryAllErrors' mkInternal
-{-# INLINE tryAgentError' #-}
-
-catchAgentError :: AM a -> (AgentErrorType -> AM a) -> AM a
-catchAgentError = catchAllErrors mkInternal
-{-# INLINE catchAgentError #-}
-
-catchAgentError' :: AM a -> (AgentErrorType -> AM' a) -> AM' a
-catchAgentError' = catchAllErrors' mkInternal
-{-# INLINE catchAgentError' #-}
-
-agentFinally :: AM a -> AM b -> AM a
-agentFinally = allFinally mkInternal
-{-# INLINE agentFinally #-}
-
-mkInternal :: SomeException -> AgentErrorType
-mkInternal e = case fromException e of
-  Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
-  _ -> INTERNAL $ show e
-{-# INLINE mkInternal #-}
-
 data Worker = Worker
   { workerId :: Int,
     doWork :: TMVar (),

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -14,6 +14,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     nsUpdateToken,
     nsRemoveNtfToken,
     sendNtfSubCommand,
+    hasInstantNotifications,
     instantNotifications,
     deleteToken,
     closeNtfSupervisor,
@@ -45,12 +46,13 @@ import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.AgentStore
 import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Client (NetworkRequestMode (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
+import Simplex.Messaging.Util (catchAllErrors, diffToMicroseconds, threadDelay', tryAllErrors, tshow, whenM)
 import System.Random (randomR)
 import UnliftIO
 import UnliftIO.Concurrent (forkIO)
@@ -215,7 +217,7 @@ runNtfWorker c srv Worker {doWork} =
     runNtfOperation :: AM ()
     runNtfOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems c doWork (withStore' c $ \db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
         logInfo $ "runNtfWorker - length nextSubs = " <> tshow (length nextSubs)
         currTs <- liftIO getCurrentTime
         let (creates, checks, deletes, rotates) = splitActions currTs nextSubs
@@ -355,7 +357,7 @@ runNtfWorker c srv Worker {doWork} =
     runCatching :: (NtfSubscription -> AM (Maybe NtfSubscription)) -> NtfSubscription -> AM' (Maybe NtfSubscription)
     runCatching action sub@NtfSubscription {connId} =
       fromRight Nothing
-        <$> runExceptT (action sub `catchAgentError` \e -> workerInternalError c connId (show e) $> Nothing)
+        <$> runExceptT (action sub `catchAllErrors` \e -> workerInternalError c connId (show e) $> Nothing)
     -- deleteNtfSub is only used in NSADelete and NSARotate, so also deprecated
     deleteNtfSub :: NtfSubscription -> AM () -> AM (Maybe NtfSubscription)
     deleteNtfSub sub@NtfSubscription {userId, ntfSubId} continue = case ntfSubId of
@@ -363,7 +365,7 @@ runNtfWorker c srv Worker {doWork} =
         lift getNtfToken >>= \case
           Just tkn@NtfToken {ntfServer} -> do
             atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
-            tryAgentError (agentNtfDeleteSubscription c nSubId tkn) >>= \case
+            tryAllErrors (agentNtfDeleteSubscription c nSubId tkn) >>= \case
               Right _ -> do
                 atomically $ incNtfServerStat c userId ntfServer ntfDeleted
                 continue'
@@ -383,7 +385,7 @@ runNtfSMPWorker c srv Worker {doWork} = forever $ do
     runNtfSMPOperation :: AM ()
     runNtfSMPOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems c doWork (withStore' c $ \db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
         logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
         let (creates, deletes) = splitActions nextSubs
         retrySubActions c creates createNotifierKeys
@@ -525,15 +527,19 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
 nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
-sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
-sendNtfSubCommand ns cmd = do
-  tkn <- readTVar (ntfTkn ns)
-  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
+sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
+sendNtfSubCommand ns cmd =
+  whenM (hasInstantNotifications ns) $ atomically $ writeTBQueue (ntfSubQ ns) cmd
 
-instantNotifications :: Maybe NtfToken -> Bool
-instantNotifications = \case
-  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
-  _ -> False
+hasInstantNotifications :: NtfSupervisor -> IO Bool
+hasInstantNotifications ns = do
+  tkn <- readTVarIO $ ntfTkn ns
+  pure $ maybe False instantNotifications tkn
+
+instantNotifications :: NtfToken -> Bool
+instantNotifications NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} = True
+instantNotifications _ = False
+{-# INLINE instantNotifications #-}
 
 deleteToken :: AgentClient -> NtfToken -> AM ()
 deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
@@ -561,7 +567,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
           withRetryInterval ri $ \_ loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            processTknToDelete nextTknToDelete `catchAgentError` retryTmpError loop nextTknToDelete
+            processTknToDelete nextTknToDelete `catchAllErrors` retryTmpError loop nextTknToDelete
     retryTmpError :: AM () -> NtfTokenToDelete -> AgentErrorType -> AM ()
     retryTmpError loop (tknDbId, _, _) e = do
       logError $ "ntf tkn del error: " <> tshow e
@@ -572,7 +578,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
           notifyInternalError' c (show e)
     processTknToDelete :: NtfTokenToDelete -> AM ()
     processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
-      agentNtfDeleteToken c srv ntfPrivKey tknId
+      agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
       withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()

src/Simplex/Messaging/Agent/Protocol.hs

@@ -173,6 +173,7 @@ module Simplex.Messaging.Agent.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Exception (BlockedIndefinitelyOnSTM (..), fromException)
 import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?))
 import qualified Data.Aeson as J'
 import qualified Data.Aeson.Encoding as JE
@@ -1129,7 +1130,7 @@ instance StrEncoding AConnectionRequestUri where
 
 connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri
 connReqUriP overrideScheme = do
-  crScheme <- (`fromMaybe` overrideScheme) <$> strP
+  crScheme <- (`fromMaybe` overrideScheme) <$> strP -- always parse, but use the passed one if any
   crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
   query <- strP
   aVRange <- queryParam "v" query
@@ -1153,22 +1154,39 @@ connReqUriP overrideScheme = do
 
 instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
   parseJSON = strParseJSON "ConnectionRequestUri"
+  {-# INLINE parseJSON #-}
 
 instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where
   toJSON = strToJSON
+  {-# INLINE toJSON #-}
   toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
 
 instance FromJSON AConnectionRequestUri where
   parseJSON = strParseJSON "ConnectionRequestUri"
+  {-# INLINE parseJSON #-}
 
 instance ToJSON AConnectionRequestUri where
   toJSON = strToJSON
+  {-# INLINE toJSON #-}
   toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
 
 instance ConnectionModeI m => FromJSON (ConnShortLink m) where
   parseJSON = strParseJSON "ConnShortLink"
+  {-# INLINE parseJSON #-}
 
 instance ConnectionModeI m => ToJSON (ConnShortLink m) where
+  toJSON = strToJSON
+  {-# INLINE toJSON #-}
+  toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
+
+instance FromJSON AConnShortLink where
+  parseJSON = strParseJSON "AConnShortLink"
+  {-# INLINE parseJSON #-}
+
+instance ToJSON AConnShortLink where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
@@ -1428,10 +1446,17 @@ instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField
 
 instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
 
-data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
+data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
 
 data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
 
+instance Eq AConnShortLink where
+  ACSL m sl == ACSL m' sl' = case testEquality m m' of
+    Just Refl -> sl == sl'
+    Nothing -> False
+
+deriving instance Show AConnShortLink
+
 instance ToField AConnShortLink where toField = toField . Binary . strEncode
 
 instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode
@@ -1569,6 +1594,7 @@ ctTypeP = \case
   'A' -> pure CCTContact
   'C' -> pure CCTChannel
   'G' -> pure CCTGroup
+  'R' -> pure CCTRelay
   _ -> fail "unknown contact address type"
 {-# INLINE ctTypeP #-}
 
@@ -1577,6 +1603,7 @@ ctTypeChar = \case
   CCTContact -> 'A'
   CCTChannel -> 'C'
   CCTGroup -> 'G'
+  CCTRelay -> 'R'
 {-# INLINE ctTypeChar #-}
 
 -- the servers passed to this function should be all preset servers, not servers configured by the user.
@@ -1813,7 +1840,7 @@ data AgentErrorType
   = -- | command or response error
     CMD {cmdErr :: CommandErrorType, errContext :: String}
   | -- | connection errors
-    CONN {connErr :: ConnectionErrorType}
+    CONN {connErr :: ConnectionErrorType, errContext :: String}
   | -- | user not found in database
     NO_USER
   | -- | SMP protocol errors forwarded to agent clients
@@ -1840,6 +1867,12 @@ data AgentErrorType
     INACTIVE
   deriving (Eq, Show, Exception)
 
+instance AnyError AgentErrorType where
+  fromSomeException e = case fromException e of
+    Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
+    _ -> INTERNAL $ show e
+  {-# INLINE fromSomeException #-}
+
 -- | SMP agent protocol command or response error.
 data CommandErrorType
   = -- | command is prohibited in this context

src/Simplex/Messaging/Agent/Store.hs

@@ -29,10 +29,11 @@ import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State)
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Common
 import Simplex.Messaging.Agent.Store.Interface (createDBStore)
 import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
 import Simplex.Messaging.Encoding.String
@@ -52,9 +53,9 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Agent.Store.Entity
+import Simplex.Messaging.Util (AnyError (..), bshow)
 
-createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createStore dbOpts = createDBStore dbOpts appMigrations
 
 -- * Queue types
@@ -119,6 +120,10 @@ rcvQueueInfo :: RcvQueue -> RcvQueueInfo
 rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
   RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
 
+rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
+rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
+  SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
+
 canAbortRcvSwitch :: RcvQueue -> Bool
 canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
   where
@@ -511,7 +516,7 @@ data NewInvitation = NewInvitation
 
 data Invitation = Invitation
   { invitationId :: InvitationId,
-    contactConnId :: ConnId,
+    contactConnId_ :: Maybe ConnId,
     connReq :: ConnectionRequestUri 'CMInvitation,
     recipientConnInfo :: ConnInfo,
     ownConnInfo :: Maybe ConnInfo,
@@ -662,13 +667,13 @@ data StoreError
     SESndQueueExists
   | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.
     -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.
-    SEBadConnType ConnType
+    SEBadConnType String ConnType
   | -- | Confirmation not found.
     SEConfirmationNotFound
   | -- | Invitation not found
     SEInvitationNotFound String InvitationId
   | -- | Message not found
-    SEMsgNotFound
+    SEMsgNotFound String
   | -- | Command not found
     SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
@@ -688,7 +693,20 @@ data StoreError
   | -- | XFTP Deleted snd chunk replica not found.
     SEDeletedSndChunkReplicaNotFound
   | -- | Error when reading work item that suspends worker - do not use!
-    SEWorkItemError ByteString
+    SEWorkItemError {errContext :: String}
   | -- | Servers stats not found.
     SEServersStatsNotFound
   deriving (Eq, Show, Exception)
+
+instance AnyError StoreError where
+  fromSomeException = SEInternal . bshow
+
+class (Show e, AnyError e) => AnyStoreError e where
+  isWorkItemError :: e -> Bool
+  mkWorkItemError :: String -> e
+
+instance AnyStoreError StoreError where
+  isWorkItemError = \case
+    SEWorkItemError {} -> True
+    _ -> False
+  mkWorkItemError errContext = SEWorkItemError {errContext}

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

@@ -43,7 +43,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     getDeletedConn,
     getConns,
     getDeletedConns,
-    getConnData,
+    getConnsData,
     setConnDeleted,
     setConnUserId,
     setConnAgentVersion,
@@ -237,6 +237,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
     firstRow',
     maybeFirstRow,
     fromOnlyBI,
+    getWorkItem,
+    getWorkItems,
   )
 where
 
@@ -255,8 +257,9 @@ import Data.List (foldl', sortBy)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Ord (Down (..))
+import qualified Data.Set as S
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
 import Data.Word (Word32)
@@ -285,12 +288,14 @@ import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
+import Simplex.Messaging.Util
 import Simplex.Messaging.Version.Internal
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 #if defined(dbPostgres)
-import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..))
+import Data.List (sortOn)
+import Data.Map.Strict (Map)
+import Database.PostgreSQL.Simple (In (..), Only (..), Query, SqlError, (:.) (..))
 import Database.PostgreSQL.Simple.Errors (constraintViolation)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 #else
@@ -387,7 +392,7 @@ updateNewConnRcv db connId rq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
     (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
-    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
   where
     updateConn :: IO (Either StoreError RcvQueue)
     updateConn = Right <$> addConnRcvQueue_ db connId rq
@@ -396,7 +401,7 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr
 updateNewConnSnd db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
-    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c
   where
     updateConn :: IO (Either StoreError SndQueue)
     updateConn = Right <$> addConnSndQueue_ db connId sq
@@ -424,15 +429,12 @@ deleteConnRecord :: DB.Connection -> ConnId -> IO ()
 deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId)
 
 checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
-checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1"
-          (host server, port server, sndId, New)
-      )
+checkConfirmedSndQueueExists_ db SndQueue {server, sndId} =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1"
+      (host server, port server, sndId, New)
 
 getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
 getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
@@ -472,14 +474,14 @@ upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either S
 upgradeRcvConnToDuplex db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
-    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
 
 -- TODO [certs rcv] store clientServiceId from NewRcvQueue
 upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 upgradeSndConnToDuplex db connId rq =
   getConn db connId >>= \case
     Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 -- TODO [certs rcv] store clientServiceId from NewRcvQueue
@@ -487,7 +489,7 @@ addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreErr
 addConnRcvQueue db connId rq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
@@ -499,7 +501,7 @@ addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreErr
 addConnSndQueue db connId sq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
@@ -728,7 +730,7 @@ createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInf
       db
       [sql|
         INSERT INTO conn_invitations
-        (invitation_id,  contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
+        (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
       |]
       (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo)
 
@@ -745,8 +747,8 @@ getInvitation db cxt invitationId =
       |]
       (Only (Binary invitationId))
   where
-    invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
-      Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}
+    invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
+      Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted}
 
 acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO ()
 acceptInvitation db invitationId ownConnInfo =
@@ -764,12 +766,9 @@ unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
 unacceptInvitation db invitationId =
   DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId))
 
-deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
-deleteInvitation db contactConnId invId =
-  getConn db contactConnId $>>= \case
-    SomeConn SCContact _ ->
-      Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
-    _ -> pure $ Left SEConnNotFound
+deleteInvitation :: DB.Connection -> InvitationId -> IO ()
+deleteInvitation db invId =
+  DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId))
 
 getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
 getInvShortLink db server linkId =
@@ -894,7 +893,7 @@ createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
 
 getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
 getSndMsgViaRcpt db connId sndMsgId =
-  firstRow toSndMsg SEMsgNotFound $
+  firstRow toSndMsg (SEMsgNotFound "getSndMsgViaRcpt") $
     DB.query
       db
       [sql|
@@ -969,28 +968,25 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
                 _ -> Left $ SEInternal "unexpected snd msg data"
     markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
 
-getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
+getWorkItem :: (Show i, AnyStoreError e) => String -> IO (Maybe i) -> (i -> IO (Either e a)) -> (i -> IO ()) -> IO (Either e (Maybe a))
 getWorkItem itemName getId getItem markFailed =
   runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed)
 
-getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a])
+getWorkItems :: (Show i, AnyStoreError e) => String -> IO [i] -> (i -> IO (Either e a)) -> (i -> IO ()) -> IO (Either e [Either e a])
 getWorkItems itemName getIds getItem markFailed =
   runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
 
-tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
-tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
+tryGetItem :: (Show i, AnyStoreError e) => String -> (i -> IO (Either e a)) -> (i -> IO ()) -> i -> ExceptT e IO a
+tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchAllErrors` \e -> mark >> throwE e
   where
-    mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
-
-catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
-catchStoreError = catchAllErrors (SEInternal . bshow)
+    mark = handleWrkErr itemName ("markFailed ID " <> show itemId) $ markFailed itemId
 
 -- Errors caught by this function will suspend worker as if there is no more work,
-handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
+handleWrkErr :: forall e a. AnyStoreError e => String -> String -> IO a -> ExceptT e IO a
 handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
   where
-    mkError :: E.SomeException -> StoreError
-    mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
+    mkError :: E.SomeException -> e
+    mkError e = mkWorkItemError $ itemName <> " " <> opName <> " error: " <> show e
 
 updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
 updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
@@ -1030,7 +1026,7 @@ getExpiredSndMessages db connId SndQueue {dbQueueId} expireTs = do
 setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId))
 setMsgUserAck db connId agentMsgId = runExceptT $ do
   (dbRcvId, srvMsgId) <-
-    ExceptT . firstRow id SEMsgNotFound $
+    ExceptT . firstRow id (SEMsgNotFound "setMsgUserAck") $
       DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
   rq <- ExceptT $ getRcvQueueById db connId dbRcvId
   liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (BI True, connId, agentMsgId)
@@ -1038,7 +1034,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do
 
 getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg)
 getRcvMsg db connId agentMsgId =
-  firstRow toRcvMsg SEMsgNotFound $
+  firstRow toRcvMsg (SEMsgNotFound "getRcvMsg") $
     DB.query
       db
       [sql|
@@ -1076,19 +1072,16 @@ toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity,
    in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck}
 
 checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
-checkRcvMsgHashExists db connId hash = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-          (connId, Binary hash)
-      )
+checkRcvMsgHashExists db connId hash =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
+      (connId, Binary hash)
 
 getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
 getRcvMsgBrokerTs db connId msgId =
-  firstRow fromOnly SEMsgNotFound $
+  firstRow fromOnly (SEMsgNotFound "getRcvMsgBrokerTs") $
     DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId)
 
 deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
@@ -1308,21 +1301,26 @@ insertedRowId db = fromOnly . head <$> DB.query_ db q
     q = "SELECT last_insert_rowid()"
 #endif
 
-getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer]
-getPendingCommandServers db connId = do
+getPendingCommandServers :: DB.Connection -> [ConnId] -> IO [(ConnId, NonEmpty (Maybe SMPServer))]
+getPendingCommandServers db connIds =
   -- TODO review whether this can break if, e.g., the server has another key hash.
-  map smpServer
-    <$> DB.query
+  mapMaybe connServers . groupOn' rowConnId
+    <$> DB.query_
       db
       [sql|
-        SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
+        SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
         FROM commands c
         LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
-        WHERE conn_id = ?
+        ORDER BY c.conn_id
       |]
-      (Only connId)
   where
+    rowConnId (Only connId :. _) = connId
+    connServers rs =
+      let connId = rowConnId $ L.head rs
+          srvs = L.map (\(_ :. r) -> smpServer r) rs
+       in if connId `S.member` conns then Just (connId, srvs) else Nothing
     smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
+    conns = S.fromList connIds
 
 getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
 getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
@@ -1972,15 +1970,22 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
       INSERT INTO rcv_queues
         ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
           snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
-          link_id, link_key, link_priv_sig_key, link_enc_fixed_data
-        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
+          link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
+          ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
+        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
         :. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
         :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
+        :. ntfCredsFields
     )
   -- TODO [certs rcv] save client service
   pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
+  where
+    ntfCredsFields = case clientNtfCreds of
+      Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
+        (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
+      Nothing -> (Nothing, Nothing, Nothing, Nothing)
 
 -- * createSndConn helpers
 
@@ -2033,21 +2038,19 @@ getDeletedConn = getAnyConn True
 {-# INLINE getDeletedConn #-}
 
 getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getAnyConn deleted' dbConn connId =
-  getConnData dbConn connId >>= \case
+getAnyConn deleted' db connId =
+  getConnData deleted' db connId >>= \case
+    Just (cData, cMode) -> do
+      rQ <- getRcvQueuesByConnId_ db connId
+      sQ <- getSndQueuesByConnId_ db connId
+      pure $ case (rQ, sQ, cMode) of
+        (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
+        (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
+        (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
+        (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
+        (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
+        _ -> Left SEConnNotFound
     Nothing -> pure $ Left SEConnNotFound
-    Just (cData@ConnData {deleted}, cMode)
-      | deleted /= deleted' -> pure $ Left SEConnNotFound
-      | otherwise -> do
-          rQ <- getRcvQueuesByConnId_ dbConn connId
-          sQ <- getSndQueuesByConnId_ dbConn connId
-          pure $ case (rQ, sQ, cMode) of
-            (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
-            (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
-            (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
-            (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
-            (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
-            _ -> Left SEConnNotFound
 
 getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getConns = getAnyConns_ False
@@ -2057,28 +2060,84 @@ getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getDeletedConns = getAnyConns_ True
 {-# INLINE getDeletedConns #-}
 
+#if defined(dbPostgres)
 getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
+getAnyConns_ deleted' db connIds = do
+  cs <- getConnsData_ deleted' db connIds
+  let connIds' = M.keys cs
+  rQs :: Map ConnId (NonEmpty RcvQueue) <- getRcvQueuesByConnIds_ connIds'
+  sQs :: Map ConnId (NonEmpty SndQueue) <- getSndQueuesByConnIds_ connIds'
+  pure $ map (result cs rQs sQs) connIds
   where
-    handleDBError :: E.SomeException -> IO (Either StoreError SomeConn)
-    handleDBError = pure . Left . SEInternal . bshow
+    getRcvQueuesByConnIds_ connIds' =
+      toQueueMap primaryFirst toRcvQueue
+        <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id IN ? AND q.deleted = 0") (Only (In connIds'))
+      where
+        primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
+          compare (Down p) (Down p') <> compare i i'
+    getSndQueuesByConnIds_ connIds' =
+      toQueueMap primaryFirst toSndQueue
+        <$> DB.query db (sndQueueQuery <> " WHERE q.conn_id IN ?") (Only (In connIds'))
+      where
+        primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
+          compare (Down p) (Down p') <> compare i i'
+    toQueueMap primaryFst toQueue =
+      M.fromList . map (\qs@(q :| _) -> (qConnId q, L.sortBy primaryFst qs)) . groupOn' qConnId . sortOn qConnId . map toQueue
+    result cs rQs sQs connId = case M.lookup connId cs of
+      Just (cData, cMode) -> case (M.lookup connId rQs, M.lookup connId sQs, cMode) of
+        (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
+        (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
+        (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
+        (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
+        (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
+        _ -> Left SEConnNotFound
+      Nothing -> Left SEConnNotFound
 
-getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
-getConnData db connId' =
-  maybeFirstRow cData $
+getConnsData :: DB.Connection -> [ConnId] -> IO [Either StoreError (Maybe (ConnData, ConnectionMode))]
+getConnsData db connIds = do
+  cs <- getConnsData_ False db connIds
+  pure $ map (Right . (`M.lookup` cs)) connIds
+
+getConnsData_ :: Bool -> DB.Connection -> [ConnId] -> IO (Map ConnId (ConnData, ConnectionMode))
+getConnsData_ deleted' db connIds =
+  M.fromList . map ((\c@(ConnData {connId}, _) -> (connId, c)) . rowToConnData) <$>
     DB.query
       db
       [sql|
-        SELECT
-          user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
+        SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
           last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support
         FROM connections
-        WHERE conn_id = ?
+        WHERE conn_id IN ? AND deleted = ?
       |]
-      (Only connId')
-  where
-    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) =
-      (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode)
+      (In connIds, BI deleted')
+
+#else
+getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
+
+getConnsData :: DB.Connection -> [ConnId] -> IO [Either StoreError (Maybe (ConnData, ConnectionMode))]
+getConnsData db connIds = forM connIds $ E.handle handleDBError . fmap Right . getConnData False db
+
+handleDBError :: E.SomeException -> IO (Either StoreError a)
+handleDBError = pure . Left . SEInternal . bshow
+#endif
+
+getConnData :: Bool -> DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData deleted' db connId' =
+  maybeFirstRow rowToConnData $
+    DB.query
+      db
+      [sql|
+        SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
+          last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support
+        FROM connections
+        WHERE conn_id = ? AND deleted = ?
+      |]
+      (connId', BI deleted')
+
+rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport) -> (ConnData, ConnectionMode)
+rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) =
+  (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode)
 
 setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
 setConnDeleted db waitDelivery connId
@@ -2116,15 +2175,12 @@ addProcessedRatchetKeyHash db connId hash =
   DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary hash)
 
 checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
-checkRatchetKeyHashExists db connId hash = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-          (connId, Binary hash)
-      )
+checkRatchetKeyHashExists db connId hash =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
+      (connId, Binary hash)
 
 deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
 deleteRatchetKeyHashesExpired db ttl = do
@@ -2902,8 +2958,8 @@ deleteSndFile' db sndFileId =
 
 getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool
 getSndFileDeleted db sndFileId =
-  fromMaybe True
-    <$> maybeFirstRow fromOnlyBI (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId))
+  maybeFirstRow' True fromOnlyBI $
+    DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)
 
 createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO ()
 createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId

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

@@ -15,7 +15,7 @@ where
 import Control.Monad
 import Data.Char (toLower)
 import Data.Functor (($>))
-import Data.Maybe (isNothing, mapMaybe)
+import Data.Maybe (isJust, isNothing, mapMaybe)
 import Simplex.Messaging.Agent.Store.Shared
 import System.Exit (exitFailure)
 import System.IO (hFlush, stdout)
@@ -37,7 +37,7 @@ data DBMigrate = DBMigrate
   { initialize :: IO (),
     getCurrent :: IO [Migration],
     run :: MigrationsToRun -> IO (),
-    backup :: IO ()
+    backup :: Maybe (IO ())
   }
 
 sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
@@ -54,20 +54,20 @@ sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
       | otherwise -> case confirmMigrations of
           MCYesUp -> runWithBackup ms
           MCYesUpDown -> runWithBackup ms
-          MCConsole -> confirm err >> runWithBackup ms
+          MCConsole -> confirm' err >> runWithBackup ms
           MCError -> pure $ Left err
       where
         err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
     Right ms@(MTRDown dms) -> case confirmMigrations of
       MCYesUpDown -> runWithBackup ms
-      MCConsole -> confirm err >> runWithBackup ms
+      MCConsole -> confirm' err >> runWithBackup ms
       MCYesUp -> pure $ Left err
       MCError -> pure $ Left err
       where
         err = MEDowngrade $ map downName dms
   where
-    runWithBackup ms = backup dbm >> run dbm ms $> Right ()
-    confirm err = confirmOrExit $ migrationErrorDescription err
+    runWithBackup ms = sequence (backup dbm) >> run dbm ms $> Right ()
+    confirm' err = confirmOrExit $ migrationErrorDescription (isJust $ backup dbm) err
 
 confirmOrExit :: String -> IO ()
 confirmOrExit s = do

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

@@ -30,15 +30,15 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
 import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Exit (exitFailure)
 
 -- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
 -- If passed schema does not exist in connectInfo database, it will be created.
 -- Applies necessary migrations to schema.
-createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore opts migrations confirmMigrations = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
+createDBStore opts migrations MigrationConfig {confirm} = do
   st <- connectPostgresStore opts
   r <- migrateSchema st `onException` closeDBStore st
   case r of
@@ -48,15 +48,16 @@ createDBStore opts migrations confirmMigrations = do
     migrateSchema st =
       let initialize = Migrations.initialize st
           getCurrent = withTransaction st Migrations.getCurrentMigrations
-          dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
-       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+          dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = Nothing}
+       in sharedMigrateSchema dbm (dbNew st) migrations confirm
 
 connectPostgresStore :: DBOpts -> IO DBStore
 connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do
   dbPriorityPool <- newDBStorePool poolSize
   dbPool <- newDBStorePool poolSize
   dbClosed <- newTVarIO True
-  let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbNew = False, dbClosed}
+  let dbConnect = fst <$> connectDB connstr schema False
+      st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbConnect, dbNew = False, dbClosed}
   dbNew <- connectStore st createSchema
   pure st {dbNew}
 

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Common
@@ -19,7 +20,7 @@ where
 
 import Control.Concurrent.MVar
 import Control.Concurrent.STM
-import Control.Exception (bracket)
+import qualified Control.Exception as E
 import Data.ByteString (ByteString)
 import qualified Database.PostgreSQL.Simple as PSQL
 import Numeric.Natural (Natural)
@@ -32,11 +33,7 @@ data DBStore = DBStore
     dbPoolSize :: Int,
     dbPriorityPool :: DBStorePool,
     dbPool :: DBStorePool,
-    -- dbPoolSize :: Int,
-    -- dbPool :: TBQueue PSQL.Connection,
-    -- -- MVar is needed for fair pool distribution, without STM retry contention.
-    -- -- Only one thread can be blocked on STM read.
-    -- dbSem :: MVar (),
+    dbConnect :: IO PSQL.Connection,
     dbClosed :: TVar Bool,
     dbNew :: Bool
   }
@@ -55,15 +52,23 @@ data DBStorePool = DBStorePool
   }
 
 withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
-withConnectionPriority DBStore {dbPriorityPool, dbPool} priority =
-  withConnectionPool $ if priority then dbPriorityPool else dbPool
+withConnectionPriority DBStore {dbPriorityPool, dbPool, dbConnect} priority =
+  withConnectionPool (if priority then dbPriorityPool else dbPool) dbConnect
 {-# INLINE withConnectionPriority #-}
 
-withConnectionPool :: DBStorePool -> (PSQL.Connection -> IO a) -> IO a
-withConnectionPool DBStorePool {dbPoolConns, dbSem} =
-  bracket
-    (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPoolConns)
-    (atomically . writeTBQueue dbPoolConns)
+withConnectionPool :: DBStorePool -> IO PSQL.Connection -> (PSQL.Connection -> IO a) -> IO a
+withConnectionPool DBStorePool {dbPoolConns, dbSem} dbConnect action =
+  E.mask $ \restore -> do
+    conn <- withMVar dbSem $ \_ -> atomically $ readTBQueue dbPoolConns
+    r <- restore (action conn) `E.onException` reset conn
+    atomically $ writeTBQueue dbPoolConns conn
+    pure r
+  where
+    reset conn = do
+      conn' <- E.try dbConnect >>= \case
+        Right conn' -> PSQL.close conn >> pure conn'
+        Left (_ :: E.SomeException) -> pure conn
+      atomically $ writeTBQueue dbPoolConns conn'
 
 withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withConnection st = withConnectionPriority st False

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs

@@ -7,13 +7,15 @@ import Data.Text (Text)
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Text, Maybe Text)]
 schemaMigrations =
   [ ("20241210_initial", m20241210_initial, Nothing),
     ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
-    ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
+    ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
+    ("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.RawString.QQ (r)
+
+m20250702_conn_invitations_remove_cascade_delete :: Text
+m20250702_conn_invitations_remove_cascade_delete =
+  T.pack
+    [r|
+ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
+
+ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id DROP NOT NULL;
+
+ALTER TABLE conn_invitations
+  ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
+  FOREIGN KEY (contact_conn_id)
+  REFERENCES connections(conn_id)
+  ON DELETE SET NULL;
+|]
+
+down_m20250702_conn_invitations_remove_cascade_delete :: Text
+down_m20250702_conn_invitations_remove_cascade_delete =
+  T.pack
+    [r|
+ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
+
+ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id SET NOT NULL;
+
+ALTER TABLE conn_invitations
+  ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
+  FOREIGN KEY (contact_conn_id)
+  REFERENCES connections(conn_id)
+  ON DELETE CASCADE;
+|]

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

@@ -57,18 +57,18 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.SQLite.Common
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
-import System.FilePath (takeDirectory)
+import System.FilePath (takeDirectory, takeFileName, (</>))
 import UnliftIO.Exception (bracketOnError, onException)
 import UnliftIO.MVar
 import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
+createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations MigrationConfig {confirm, backupPath} = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
   st <- connectSQLiteStore dbFilePath dbKey keepKey track
@@ -81,9 +81,12 @@ createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations conf
       let initialize = Migrations.initialize st
           getCurrent = withTransaction st Migrations.getCurrentMigrations
           run = Migrations.run st vacuum
-          backup = copyFile dbFilePath (dbFilePath <> ".bak")
+          backup = mkBackup <$> backupPath
+          mkBackup bp =
+            let f = if null bp then dbFilePath else bp </> takeFileName dbFilePath
+             in copyFile dbFilePath $ f <> ".bak"
           dbm = DBMigrate {initialize, getCurrent, run, backup}
-       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+       in sharedMigrateSchema dbm (dbNew st) migrations confirm
 
 connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore
 connectSQLiteStore dbFilePath key keepKey track = do

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

@@ -52,7 +52,7 @@ import Simplex.Messaging.Util (diffToMicroseconds, tshow)
 newtype BoolInt = BI {unBI :: Bool}
   deriving newtype (FromField, ToField)
 
-newtype Binary = Binary {fromBinary :: ByteString}
+newtype Binary a = Binary {fromBinary :: a}
   deriving newtype (FromField, ToField)
 
 data Connection = Connection

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

@@ -43,6 +43,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -85,7 +86,8 @@ schemaMigrations =
     ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
     ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
     ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
-    ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
+    ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
+    ("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -5,6 +5,7 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs w
 import Database.SQLite.Simple (Query)
 import Database.SQLite.Simple.QQ (sql)
 
+-- TODO move date forward, create migration for postgres
 m20250517_service_certs :: Query
 m20250517_service_certs =
   [sql|

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

@@ -0,0 +1,38 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20250702_conn_invitations_remove_cascade_delete :: Query
+m20250702_conn_invitations_remove_cascade_delete =
+  [sql|
+PRAGMA writable_schema=1;
+
+UPDATE sqlite_master
+SET sql = replace(
+            sql,
+            'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE',
+            'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL'
+          )
+WHERE name = 'conn_invitations' AND type = 'table';
+
+PRAGMA writable_schema=0;
+|]
+
+down_m20250702_conn_invitations_remove_cascade_delete :: Query
+down_m20250702_conn_invitations_remove_cascade_delete =
+  [sql|
+PRAGMA writable_schema=1;
+
+UPDATE sqlite_master
+SET sql = replace(
+            sql,
+            'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL',
+            'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE'
+          )
+WHERE name = 'conn_invitations' AND type = 'table';
+
+PRAGMA writable_schema=0;
+|]

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

@@ -154,7 +154,7 @@ CREATE TABLE conn_confirmations(
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
-  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL,
   cr_invitation BLOB NOT NULL,
   recipient_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL DEFAULT 0,

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

@@ -9,6 +9,7 @@ module Simplex.Messaging.Agent.Store.Shared
     DownMigration (..),
     MTRError (..),
     mtrErrorDescription,
+    MigrationConfig (..),
     MigrationConfirmation (..),
     MigrationError (..),
     UpMigration (..),
@@ -55,13 +56,15 @@ data MigrationError
   | MigrationError {mtrError :: MTRError}
   deriving (Eq, Show)
 
-migrationErrorDescription :: MigrationError -> String
-migrationErrorDescription = \case
+migrationErrorDescription :: Bool -> MigrationError -> String
+migrationErrorDescription withBackup = \case
   MEUpgrade ums ->
-    "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
+    "The app has a newer version than the database.\nConfirm to " <> backupStr <> "upgrade using these migrations: " <> intercalate ", " (map upName ums)
   MEDowngrade dms ->
-    "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms
+    "Database version is newer than the app.\nConfirm to " <> backupStr <> "downgrade using these migrations: " <> intercalate ", " dms
   MigrationError err -> mtrErrorDescription err
+  where
+    backupStr = if withBackup then "back up and " else ""
 
 data UpMigration = UpMigration {upName :: String, withDown :: Bool}
   deriving (Eq, Show)
@@ -69,6 +72,11 @@ data UpMigration = UpMigration {upName :: String, withDown :: Bool}
 upMigration :: Migration -> UpMigration
 upMigration Migration {name, down} = UpMigration name $ isJust down
 
+data MigrationConfig = MigrationConfig
+  { confirm :: MigrationConfirmation,
+    backupPath :: Maybe FilePath -- Nothing - no backup, empty string - the same folder
+  }
+
 data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError
   deriving (Eq, Show)
 

src/Simplex/Messaging/Client.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
@@ -37,6 +38,7 @@ module Simplex.Messaging.Client
     protocolClientServer',
     transportHost',
     transportSession',
+    useWebPort,
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -81,12 +83,16 @@ module Simplex.Messaging.Client
     unexpectedResponse,
     ProtocolClientConfig (..),
     NetworkConfig (..),
+    NetworkTimeout (..),
+    NetworkRequestMode (..),
+    pattern NRMInteractive,
     TransportSessionMode (..),
     HostMode (..),
     SocksMode (..),
     SMPProxyMode (..),
     SMPProxyFallback (..),
     SMPWebPortServers (..),
+    netTimeoutInt,
     defaultClientConfig,
     defaultSMPClientConfig,
     defaultNetworkConfig,
@@ -154,7 +160,8 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN11)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
@@ -175,8 +182,8 @@ data PClient v err msg = PClient
   { connected :: TVar Bool,
     transportSession :: TransportSession msg,
     transportHost :: TransportHost,
-    tcpConnectTimeout :: Int,
-    tcpTimeout :: Int,
+    tcpConnectTimeout :: NetworkTimeout,
+    tcpTimeout :: NetworkTimeout,
     sendPings :: TVar Bool,
     lastReceived :: TVar UTCTime,
     timeoutErrorCount :: TVar Int,
@@ -198,6 +205,7 @@ smpClientStub g sessionId thVersion thAuth = do
   timeoutErrorCount <- newTVarIO 0
   sndQ <- newTBQueueIO 100
   rcvQ <- newTBQueueIO 100
+  let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig
   return
     ProtocolClient
       { action = Nothing,
@@ -219,8 +227,8 @@ smpClientStub g sessionId thVersion thAuth = do
             { connected,
               transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
               transportHost = "localhost",
-              tcpConnectTimeout = 20_000_000,
-              tcpTimeout = 15_000_000,
+              tcpConnectTimeout,
+              tcpTimeout,
               sendPings,
               lastReceived,
               timeoutErrorCount,
@@ -298,9 +306,9 @@ data NetworkConfig = NetworkConfig
     -- | use web port 443 for SMP protocol
     smpWebPortServers :: SMPWebPortServers,
     -- | timeout for the initial client TCP/TLS connection (microseconds)
-    tcpConnectTimeout :: Int,
+    tcpConnectTimeout :: NetworkTimeout,
     -- | timeout of protocol commands (microseconds)
-    tcpTimeout :: Int,
+    tcpTimeout :: NetworkTimeout,
     -- | additional timeout per kilobyte (1024 bytes) to be sent
     tcpTimeoutPerKb :: Int64,
     -- | break response timeouts into groups, so later responses get later deadlines
@@ -315,6 +323,28 @@ data NetworkConfig = NetworkConfig
   }
   deriving (Eq, Show)
 
+data NetworkTimeout = NetworkTimeout {backgroundTimeout :: Int, interactiveTimeout :: Int}
+  deriving (Eq, Show)
+
+data NetworkRequestMode
+  = NRMBackground
+  | NRMInteractive' {retryCount :: Int}
+
+pattern NRMInteractive :: NetworkRequestMode
+pattern NRMInteractive = NRMInteractive' 0
+
+netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
+netTimeoutInt NetworkTimeout {backgroundTimeout, interactiveTimeout} = \case
+  NRMBackground -> backgroundTimeout
+  NRMInteractive' n
+    | n <= 0 -> interactiveTimeout
+    | otherwise ->
+        let (m, d)
+              | n == 1 = (3, 2)
+              | n == 2 = (9, 4)
+              | otherwise = (27, 8)
+         in (interactiveTimeout * m) `div` d
+
 data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
   deriving (Eq, Show)
 
@@ -387,8 +417,8 @@ defaultNetworkConfig =
       smpProxyMode = SPMNever,
       smpProxyFallback = SPFAllow,
       smpWebPortServers = SWPPreset,
-      tcpConnectTimeout = defaultTcpConnectTimeout,
-      tcpTimeout = 15_000_000,
+      tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000},
+      tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000},
       tcpTimeoutPerKb = 5_000,
       rcvConcurrency = 8,
       tcpKeepAlive = Just defaultKeepAliveOpts,
@@ -397,10 +427,11 @@ defaultNetworkConfig =
       logTLSErrors = False
     }
 
-transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
-transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN =
-  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
+transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} nm host useSNI clientALPN =
+  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout = tOut, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
   where
+    tOut = netTimeoutInt tcpConnectTimeout nm
     socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
     useSocksProxy SMAlways = socksProxy'
     useSocksProxy SMOnion = case host of
@@ -523,15 +554,15 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
+getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
-    NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
     mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
     mkProtocolClient transportHost ts = do
       connected <- newTVarIO False
@@ -562,30 +593,30 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
     runClient (port', ATransport t) useHost c = do
       cVar <- newEmptyTMVarIO
-      let tcConfig = (transportClientConfig networkConfig useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
+      let tcConfig = (transportClientConfig networkConfig nm useHost useSNI useALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
           socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
       tId <-
         runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
-          `forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
-      c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
+          `forkFinally` \r ->
+            let err = either toNetworkError (const NEFailedError) r
+             in void $ atomically $ tryPutTMVar cVar $ Left $ PCENetworkError err
+      c_ <- netTimeoutInt tcpConnectTimeout nm `timeout` atomically (takeTMVar cVar)
       case c_ of
         Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'}
         Just (Left e) -> pure $ Left e
-        Nothing -> killThread tId $> Left PCENetworkError
+        Nothing -> killThread tId $> Left (PCENetworkError NETimeoutError)
 
     useTransport :: (ServiceName, ATransport 'TClient)
     useTransport = case port srv of
       "" -> case protocolTypeI @(ProtoType msg) of
-        SPSMP | smpWebPort -> ("443", transport @TLS)
+        SPSMP | web -> ("443", transport @TLS)
         _ -> defaultTransport cfg
       p -> (p, transport @TLS)
-      where
-        smpWebPort = case smpWebPortServers of
-          SWPAll -> True
-          SWPPreset -> case srv of
-            ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
-            _ -> False
-          SWPOff -> False
+
+    useALPN :: Maybe [ALPN]
+    useALPN = if web then Just [httpALPN11] else clientALPN
+
+    web = useWebPort networkConfig presetDomains srv
 
     client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
     client _ c cVar h = do
@@ -631,7 +662,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 NRMBackground Nothing NoEntity (protocolPing @v @err @msg)
               -- sendProtocolCommand/getResponse updates counter for each command
               cnt <- readTVarIO timeoutErrorCount
               -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
@@ -680,6 +711,14 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
               Left e -> logError $ "SMP client error: " <> tshow e
               Right _ -> logWarn "SMP client unprocessed event"
 
+useWebPort :: NetworkConfig -> [HostName] -> ProtocolServer p -> Bool
+useWebPort cfg presetDomains srv = case smpWebPortServers cfg of
+  SWPAll -> True
+  SWPPreset -> case srv of
+    ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
+    _ -> False
+  SWPOff -> False
+
 unexpectedResponse :: Show r => r -> ProtocolClientError err
 unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
 
@@ -706,7 +745,7 @@ data ProtocolClientError err
     PCEResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
-    PCENetworkError
+    PCENetworkError NetworkError
   | -- | No host compatible with network configuration
     PCEIncompatibleHost
   | -- | Service is unavailable for command that requires service connection
@@ -724,7 +763,7 @@ type SMPClientError = ProtocolClientError ErrorType
 
 temporaryClientError :: ProtocolClientError err -> Bool
 temporaryClientError = \case
-  PCENetworkError -> True
+  PCENetworkError _ -> True
   PCEResponseTimeout -> True
   PCEIOError _ -> True
   _ -> False
@@ -745,7 +784,7 @@ smpProxyError = \case
   PCEResponseError e -> PROXY $ BROKER $ RESPONSE $ B.unpack $ strEncode e
   PCEUnexpectedResponse e -> PROXY $ BROKER $ UNEXPECTED $ B.unpack e
   PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
-  PCENetworkError -> PROXY $ BROKER NETWORK
+  PCENetworkError e -> PROXY $ BROKER $ NETWORK e
   PCEIncompatibleHost -> PROXY $ BROKER HOST
   PCEServiceUnavailable -> PROXY $ BROKER $ NO_SERVICE -- for completeness, it cannot happen.
   PCETransportError t -> PROXY $ BROKER $ TRANSPORT t
@@ -757,38 +796,41 @@ smpProxyError = \case
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
 createSMPQueue ::
   SMPClient ->
+  NetworkRequestMode ->
   Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
   C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
   RcvPublicDhKey ->
   Maybe BasicAuth ->
   SubscriptionMode ->
   QueueReqData ->
-  -- TODO [notifications]
-  -- Maybe NewNtfCreds ->
+  Maybe NewNtfCreds ->
   ExceptT SMPClientError IO QueueIdsKeys
-createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd =
-  sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
+createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
+  sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
     IDS qik -> pure qik
     r -> throwE $ unexpectedResponse r
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
+-- This command is always sent in background request mode
 subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
 subscribeSMPQueue c rpKey rId = do
   liftIO $ enablePings c
-  sendSMPCommand c (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
+  sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
 
 -- | Subscribe to multiple SMP queues batching commands if supported.
+-- This command is always sent in background request mode
 subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
 subscribeSMPQueues c qs = do
   liftIO $ enablePings c
-  sendProtocolCommands c cs >>= mapM (processSUBResponse c)
+  sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c)
   where
     cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
 
+-- This command is always sent in background request mode
 streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
-streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
+streamSubscribeSMPQueues c qs cb = streamProtocolCommands c NRMBackground cs $ mapM process >=> cb
   where
     cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
     process r@(Response rId _) = (rId,) <$> processSUBResponse c r
@@ -813,9 +855,10 @@ serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionI
 -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
 --
 -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
+-- This command is always sent in interactive request mode, as NSE has limited time
 getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
 getSMPMessage c rpKey rId =
-  sendSMPCommand c (Just rpKey) rId GET >>= \case
+  sendSMPCommand c NRMInteractive (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
     cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
     r -> throwE $ unexpectedResponse r
@@ -824,16 +867,18 @@ getSMPMessage c rpKey rId =
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
+-- This command is always sent in background request mode
 subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
 subscribeSMPQueueNotifications c npKey nId = do
   liftIO $ enablePings c
-  sendSMPCommand c (Just npKey) nId NSUB >>= except . nsubResponse_
+  sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_
 
 -- | Subscribe to multiple SMP queues notifications batching commands if supported.
+-- This command is always sent in background request mode
 subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
 subscribeSMPQueuesNtfs c qs = do
   liftIO $ enablePings c
-  L.map nsubResponse <$> sendProtocolCommands c cs
+  L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs
   where
     cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
 
@@ -848,11 +893,12 @@ nsubResponse_ = \case
   r' -> Left $ unexpectedResponse r'
 {-# INLINE nsubResponse_ #-}
 
+-- This command is always sent in background request mode
 subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
 subscribeService c party = case smpClientService c of
   Just THClientService {serviceId, serviceKey} -> do
     liftIO $ enablePings c
-    sendSMPCommand c (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
+    sendSMPCommand c NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
       SOKS n -> pure n
       r -> throwE $ unexpectedResponse r
     where
@@ -873,53 +919,54 @@ enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeT
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
-secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
-secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
+secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
+secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKey rId
 {-# INLINE secureSMPQueue #-}
 
 -- | Secure the SMP queue via sender queue ID.
-secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
-secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
+secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
+secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId
 {-# INLINE secureSndSMPQueue #-}
 
-proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
+proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
+proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY senderKey)
 {-# INLINE proxySecureSndSMPQueue #-}
 
 -- | Add or update date for queue link
-addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
-addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId
+addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
+addSMPQueueLink c nm rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c nm rpKey rId
 {-# INLINE addSMPQueueLink #-}
 
 -- | Delete queue link
-deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
+deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueueLink = okSMPCommand LDEL
 {-# INLINE deleteSMPQueueLink #-}
 
 -- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
-secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
-secureGetSMPQueueLink c spKey lnkId senderKey =
-  sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case
+secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
+secureGetSMPQueueLink c nm spKey lnkId senderKey =
+  sendSMPCommand c nm (Just spKey) lnkId (LKEY senderKey) >>= \case
     LNK sId d -> pure (sId, d)
     r -> throwE $ unexpectedResponse r
 
-proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
-proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey =
-  proxySMPCommand  c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
+proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
+proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey =
+  proxySMPCommand  c nm proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
     Right (LNK sId d) -> pure $ Right (sId, d)
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e
 
 -- | Get contact address SMP queue link data.
-getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
-getSMPQueueLink c lnkId =
-  sendSMPCommand c Nothing lnkId LGET >>= \case
+getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
+getSMPQueueLink c nm lnkId =
+  sendSMPCommand c nm Nothing lnkId LGET >>= \case
     LNK sId d -> pure (sId, d)
     r -> throwE $ unexpectedResponse r
 
-proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
-proxyGetSMPQueueLink c proxiedRelay lnkId =
-  proxySMPCommand  c proxiedRelay Nothing lnkId LGET >>= \case
+-- LGET command - get short link data
+proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
+proxyGetSMPQueueLink c nm proxiedRelay lnkId =
+  proxySMPCommand c nm proxiedRelay Nothing lnkId LGET >>= \case
     Right (LNK sId d) -> pure $ Right (sId, d)
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e
@@ -929,13 +976,14 @@ proxyGetSMPQueueLink c proxiedRelay lnkId =
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
 enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
 enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
-  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
+  sendSMPCommand c NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
     NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
     r -> throwE $ unexpectedResponse r
 
 -- | Enable notifications for the multiple queues for push notifications server.
+-- This command is always sent in background request mode
 enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
-enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
+enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackground cs
   where
     cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
     process (Response _ r) = case r of
@@ -946,33 +994,36 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
 -- | Disable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
+-- This command is always sent in background request mode
 disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
-disableSMPQueueNotifications = okSMPCommand NDEL
+disableSMPQueueNotifications c = okSMPCommand NDEL c NRMBackground
 {-# INLINE disableSMPQueueNotifications #-}
 
 -- | Disable notifications for multiple queues for push notifications server.
+-- This command is always sent in background request mode
 disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
-disableSMPQueuesNtfs = okSMPCommands NDEL
+disableSMPQueuesNtfs c = okSMPCommands NDEL c NRMBackground
 {-# INLINE disableSMPQueuesNtfs #-}
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
-sendSMPMessage c spKey sId flags msg =
-  sendSMPCommand c spKey sId (SEND flags msg) >>= \case
+sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
+sendSMPMessage c nm spKey sId flags msg =
+  sendSMPCommand c nm spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
     r -> throwE $ unexpectedResponse r
 
-proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySMPMessage c proxiedRelay spKey sId flags msg = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg)
+proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
+proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg)
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
+-- This command is always sent in background request mode
 ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
 ackSMPMessage c rpKey rId msgId =
-  sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
+  sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
     cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE $ unexpectedResponse r
@@ -981,28 +1032,28 @@ ackSMPMessage c rpKey rId msgId =
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
+suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
 suspendSMPQueue = okSMPCommand OFF
 {-# INLINE suspendSMPQueue #-}
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
+deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 {-# INLINE deleteSMPQueue #-}
 
 -- | Delete multiple SMP queues batching commands if supported.
-deleteSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
+deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
 deleteSMPQueues = okSMPCommands DEL
 {-# INLINE deleteSMPQueues #-}
 
 -- 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
+connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
+connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm 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 nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
         PKEY sId vr (CertChainPubKey chain key) ->
           case supportedClientSMPRelayVRange `compatibleVersion` vr of
             Nothing -> throwE $ transportErr TEVersion
@@ -1010,7 +1061,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
         r -> throwE $ unexpectedResponse r
   | otherwise = throwE $ PCETransportError TEVersion
   where
-    tOut = Just $ tcpConnectTimeout + tcpTimeout
+    tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm
     transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
     validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
     validateRelay (X.CertificateChain cert) exact = do
@@ -1076,9 +1127,9 @@ instance StrEncoding ProxyClientError where
 -- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
 
 -- This function proxies Sender commands that return OK or ERR
-proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxyOKSMPCommand c proxiedRelay spKey sId command =
-  proxySMPCommand  c proxiedRelay spKey sId command >>= \case
+proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
+proxyOKSMPCommand c nm proxiedRelay spKey sId command =
+  proxySMPCommand  c nm proxiedRelay spKey sId command >>= \case
     Right OK -> pure $ Right ()
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e
@@ -1087,6 +1138,7 @@ proxySMPCommand ::
   forall p.
   PartyI p =>
   SMPClient ->
+  NetworkRequestMode ->
   -- proxy session from PKEY
   ProxiedRelay ->
   -- message to deliver
@@ -1094,7 +1146,7 @@ proxySMPCommand ::
   SenderId ->
   Command p ->
   ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
-proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
+proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
   -- prepare params
   let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
       serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
@@ -1112,8 +1164,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
     TBTransmissions s _ _ : _ -> pure s
   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
+  let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
+  tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
     Right r -> case r of
       PRES (EncResponse er) -> do
         -- server interaction errors are thrown directly
@@ -1137,6 +1189,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
 -- sends RFWD :: EncFwdTransmission -> Command Sender
 -- receives RRES :: EncFwdResponse -> BrokerMsg
 -- proxy should send PRES to the client with EncResponse
+-- Always uses background timeout mode
 forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
 forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
   -- prepare params
@@ -1148,7 +1201,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 SProxyService (RFWD eft)) >>= \case
+  sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
     RRES (EncFwdResponse efr) -> do
       -- unwrap
       r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -1156,20 +1209,21 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
       pure fwdResponse
     r -> throwE $ unexpectedResponse r
 
-getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
-getSMPQueueInfo c pKey qId =
-  sendSMPCommand c (Just pKey) qId QUE >>= \case
+-- get queue information - always sent interactively
+getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
+getSMPQueueInfo c nm pKey qId =
+  sendSMPCommand c nm (Just pKey) qId QUE >>= \case
     INFO info -> pure info
     r -> throwE $ unexpectedResponse r
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
-okSMPCommand cmd c pKey qId =
-  sendSMPCommand c (Just pKey) qId cmd >>= \case
+okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
+okSMPCommand cmd c nm pKey qId =
+  sendSMPCommand c nm (Just pKey) qId cmd >>= \case
     OK -> return ()
     r -> throwE $ unexpectedResponse r
 
-okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
-okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
+okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs
   where
     aCmd = Cmd sParty cmd
     cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
@@ -1179,17 +1233,17 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
       Left e -> Left e
 
 -- | Send SMP command
-sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
-sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
+sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> Command p -> ExceptT SMPClientError IO BrokerMsg
+sendSMPCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (Cmd sParty cmd)
 {-# INLINE sendSMPCommand #-}
 
 type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
 
 -- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
-sendProtocolCommands c@ProtocolClient {thParams} cs = do
+sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
+sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
   bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
-  validate . concat =<< mapM (sendBatch c) bs
+  validate . concat =<< mapM (sendBatch c nm) bs
   where
     validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
     validate rs
@@ -1203,13 +1257,13 @@ sendProtocolCommands c@ProtocolClient {thParams} cs = do
       where
         diff = L.length cs - length rs
 
-streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
-streamProtocolCommands c@ProtocolClient {thParams} cs cb = do
+streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
+streamProtocolCommands c@ProtocolClient {thParams} nm cs cb = do
   bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
-  mapM_ (cb <=< sendBatch c) bs
+  mapM_ (cb <=< sendBatch c nm) bs
 
-sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
-sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
+sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
+sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
   case b of
     TBError e Request {entityId} -> do
       putStrLn "send error: large message"
@@ -1217,15 +1271,15 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
     TBTransmissions s n rs
       | n > 0 -> do
           nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
-          mapConcurrently (getResponse c Nothing) rs
+          mapConcurrently (getResponse c nm Nothing) rs
       | otherwise -> pure []
     TBTransmission s r -> do
       nonBlockingWriteTBQueue sndQ (Nothing, s)
-      (: []) <$> getResponse c Nothing r
+      (: []) <$> getResponse c nm Nothing r
 
 -- | Send Protocol command
-sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
-sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
+sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
+sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing
 
 -- Currently there is coupling - batch commands do not expire, and individually sent commands do.
 -- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
@@ -1233,8 +1287,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
 -- But a better solution is to process delayed delete responses.
 --
 -- Please note: if nonce is passed it is also used as a correlation ID
-sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
-sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nonce_ tOut pKey entId cmd =
+sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
+sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd =
   ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd)
   where
     -- two separate "atomically" needed to avoid blocking
@@ -1245,7 +1299,7 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
         | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
         | otherwise -> do
             nonBlockingWriteTBQueue sndQ (Just r, s)
-            response <$> getResponse c tOut r
+            response <$> getResponse c nm tOut r
         where
           s
             | batch = tEncodeBatch1 serviceAuth t
@@ -1256,9 +1310,9 @@ nonBlockingWriteTBQueue q x = do
   sent <- atomically $ tryWriteTBQueue q x
   unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
 
-getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg)
-getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do
-  r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar)
+getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg)
+getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do
+  r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar)
   response <- atomically $ do
     writeTVar pending False
     -- Try to read response again in case it arrived after timeout expired
@@ -1345,6 +1399,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
 
 $(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)
 
+$(J.deriveJSON defaultJSON ''NetworkTimeout)
+
 $(J.deriveJSON defaultJSON ''NetworkConfig)
 
 $(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)

src/Simplex/Messaging/Client/Agent.hs

@@ -203,7 +203,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
     waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
     waitForSMPClient v = do
       let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
+      smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
       case smpClient_ of
         Just (Right smpClient) -> pure smpClient
         Just (Left (e, ts_)) -> case ts_ of
@@ -249,7 +249,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
 -- | Run an SMP client for SMPClientVar
 connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
 connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
-  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
+  getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
   where
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected smp = do
@@ -313,7 +313,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
         subs <- getPending TM.lookupIO readTVarIO
         unless (noPending subs) $ whenM (readTVarIO active) $ do
-          void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv subs)
+          void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
           loop
     ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
     noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs
@@ -391,7 +391,7 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE
   where
     logSMPError :: SMPClientError -> ExceptT SMPClientError IO a
     logSMPError e = do
-      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host srv) <> "): " <> tshow e
+      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode srv) <> "): " <> tshow e
       throwE e
 
 subscribeQueuesNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -55,6 +55,7 @@ module Simplex.Messaging.Crypto.Ratchet
     supportedE2EEncryptVRange,
     generateRcvE2EParams,
     generateSndE2EParams,
+    mkRcvE2ERatchetParams,
     initialPQEncryption,
     connPQEncryption,
     joinContactInitialKeys,
@@ -196,6 +197,8 @@ data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RK
 
 deriving instance Show ARKEMParams
 
+type RcvRKEMParams = RKEMParams 'RKSProposed
+
 instance RatchetKEMStateI s => Encoding (RKEMParams s) where
   smpEncode = \case
     RKParamsProposed k -> smpEncode ('P', k)
@@ -406,6 +409,12 @@ data UseKEM (s :: RatchetKEMState) where
 
 data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
 
+mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
+mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem)
+  where
+    mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
+    mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k
+
 generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
 generateE2EParams g v useKEM_ = do
   (k1, pk1) <- atomically $ generateKeyPair g

src/Simplex/Messaging/Notifications/Client.hs

@@ -28,39 +28,39 @@ defaultNTFClientConfig =
     {defaultTransport = ("443", transport @TLS)}
 {-# INLINE defaultNTFClientConfig #-}
 
-ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
-ntfRegisterToken c pKey newTkn =
-  sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
+ntfRegisterToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
+ntfRegisterToken c nm pKey newTkn =
+  sendNtfCommand c nm (Just pKey) NoEntity (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE $ unexpectedResponse r
 
-ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
-ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
+ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
+ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId
 
-ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
-ntfCheckToken c pKey tknId =
-  sendNtfCommand c (Just pKey) tknId TCHK >>= \case
+ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
+ntfCheckToken c nm pKey tknId =
+  sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case
     NRTkn stat -> pure stat
     r -> throwE $ unexpectedResponse r
 
-ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
-ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
+ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
+ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
 
-ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
+ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
 
 -- set to 0 to disable
-ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
-ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
+ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
+ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm 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 NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
     r -> throwE $ unexpectedResponse r
 
 ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
-ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
+ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs
   where
     cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs
     process (Response _ r) = case r of
@@ -70,12 +70,12 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c
 
 ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
-  sendNtfCommand c (Just pKey) subId SCHK >>= \case
+  sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case
     NRSub stat -> pure stat
     r -> throwE $ unexpectedResponse r
 
 ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
-ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
+ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c NRMBackground cs
   where
     cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds
     process (Response _ r) = case r of
@@ -84,14 +84,14 @@ ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c c
       Left e -> Left e
 
 ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
-ntfDeleteSubscription = okNtfCommand SDEL
+ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground
 
 -- | Send notification server command
-sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
-sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
+sendNtfCommand :: NtfEntityI e => NtfClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
+sendNtfCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (NtfCmd sNtfEntity cmd)
 
-okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
-okNtfCommand cmd c pKey entId =
-  sendNtfCommand c (Just pKey) entId cmd >>= \case
+okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
+okNtfCommand cmd c nm pKey entId =
+  sendNtfCommand c nm (Just pKey) entId cmd >>= \case
     NROk -> return ()
     r -> throwE $ unexpectedResponse r

src/Simplex/Messaging/Notifications/Server.hs

@@ -364,12 +364,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+              CPAuth auth -> controlPortAuth h user admin role auth
                 where
-                  newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
-                    | Just auth == admin = CPRAdmin
-                    | Just auth == user = CPRUser
-                    | otherwise = CPRNone
+                  NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
               CPStats -> withUserRole $ do
                 ss <- unliftIO u $ asks serverStats
                 let getStat :: (NtfServerStats -> IORef a) -> IO a
@@ -480,8 +477,8 @@ subscribeSrvSubs ca st batchSize (srv, srvId, service_) = do
 
 -- this function is concurrency-safe - only onle subscriber per server can be created at a time,
 -- other threads would wait for the first thread to create it.
-subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> ServerNtfSub -> IO ()
-subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer ntfSub =
+subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> Int64 -> ServerNtfSub -> IO ()
+subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer srvId ntfSub =
   getSubscriberVar
     >>= either createSMPSubscriber waitForSMPSubscriber
     >>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSub)
@@ -493,8 +490,8 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
     createSMPSubscriber v =
       E.handle (\(e :: SomeException) -> logError ("SMP subscriber exception: " <> tshow e) >> removeSubscriber v) $ do
         q <- newTQueueIO
-        tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber q)
-        let sub = SMPSubscriber {smpServer, subscriberSubQ = q, subThreadId = tId}
+        tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber smpServer srvId q)
+        let sub = SMPSubscriber {smpServer, smpServerId = srvId, subscriberSubQ = q, subThreadId = tId}
         atomically $ putTMVar (sessionVar v) sub -- this makes it available for other threads
         pure $ Just sub
 
@@ -510,13 +507,13 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
       atomically $ removeSessVar v smpServer smpSubscribers
       pure Nothing
 
-    runSMPSubscriber :: TQueue ServerNtfSub -> IO ()
-    runSMPSubscriber q = forever $ do
+    runSMPSubscriber :: SMPServer -> Int64 -> TQueue ServerNtfSub -> IO ()
+    runSMPSubscriber smpServer' srvId' q = forever $ do
       -- TODO [ntfdb] possibly, the subscriptions can be batched here and sent every say 5 seconds
       -- this should be analysed once we have prometheus stats
       (nId, sub) <- atomically $ readTQueue q
-      void $ updateSubStatus st nId NSPending
-      subscribeQueuesNtfs ca smpServer [sub]
+      void $ updateSubStatus st srvId' nId NSPending
+      subscribeQueuesNtfs ca smpServer' [sub]
 
 ntfSubscriber :: NtfSubscriber -> M ()
 ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
@@ -616,7 +613,7 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
       PCEIncompatibleHost -> Just $ NSErr "IncompatibleHost"
       PCEServiceUnavailable -> Just NSService -- this error should not happen on individual subscriptions
       PCEResponseTimeout -> Nothing
-      PCENetworkError -> Nothing
+      PCENetworkError _ -> Nothing
       PCEIOError _ -> Nothing
       where
         -- Note on moving to PostgreSQL: the idea of logging errors without e is removed here
@@ -866,12 +863,12 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
         let sub = mkNtfSubRec subId newSub
         resp <-
           withNtfStore (`addNtfSubscription` sub) $ \case
-            True -> do
+            (srvId, True) -> do
               st <- asks store
-              liftIO $ subscribeNtfs ns st srv (subId, (nId, nKey))
+              liftIO $ subscribeNtfs ns st srv srvId (subId, (nId, nKey))
               incNtfStat subCreated
               pure $ NRSubId subId
-            False -> pure $ NRErr AUTH
+            (_, False) -> pure $ NRErr AUTH
         pure (corrId, NoEntity, resp)
       NtfReqCmd SSubscription (NtfSub NtfSubRec {ntfSubId, smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         (corrId,subId,) <$> case cmd of

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

@@ -141,6 +141,7 @@ newNtfSubscriber smpAgentCfg random = do
 
 data SMPSubscriber = SMPSubscriber
   { smpServer :: SMPServer,
+    smpServerId :: Int64,
     subscriberSubQ :: TQueue ServerNtfSub,
     subThreadId :: Weak ThreadId
   }

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

@@ -46,8 +46,9 @@ import Simplex.Messaging.Server.Main (strParse)
 import Simplex.Messaging.Server.Main.Init (iniDbOpts)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Server.StoreLog (closeStoreLog)
-import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion)
+import Simplex.Messaging.Transport (ASrvTransport)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
@@ -136,7 +137,7 @@ ntfServerCLI cfgPath logPath =
             (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
         Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
     iniFile = combine cfgPath "ntf-server.ini"
-    serverVersion = "SMP notifications server v" <> simplexMQVersion
+    serverVersion = "SMP notifications server v" <> simplexmqVersionCommit
     defaultServerPort = "443"
     executableName = "ntf-server"
     storeLogFilePath = combine logPath "ntf-server-store.log"
@@ -167,6 +168,9 @@ ntfServerCLI cfgPath logPath =
             <> "Time to retain deleted entities in the database, days.\n"
             <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
             <> "log_stats: off\n\n\
+               \# Log interval for real-time Prometheus metrics\n\
+               \# prometheus_interval: 60\n\
+               \\n\
                \[AUTH]\n\
                \# control_port_admin_password:\n\
                \# control_port_user_password:\n\
@@ -280,7 +284,7 @@ ntfServerCLI cfgPath logPath =
               transportConfig =
                 mkTransportServerConfig
                   (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just alpnSupportedNTFHandshakes)
+                  (Just $ alpnSupportedNTFHandshakes <> httpALPN)
                   False,
               startOptions
             }

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

@@ -54,15 +54,16 @@ import Network.Socket (ServiceName)
 import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
-import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer)
 import Simplex.Messaging.Notifications.Server.Store.Migrations
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.StoreLog
-import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId, pattern SMPServer)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
 import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_)
@@ -75,7 +76,8 @@ import System.IO (IOMode (..), hFlush, stdout, withFile)
 import Text.Hex (decodeHex)
 
 #if !defined(dbPostgres)
-import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util (eitherToMaybe)
 #endif
 
@@ -98,7 +100,7 @@ data NtfEntityRec (e :: NtfEntity) where
 
 newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
 newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
+  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations (MigrationConfig confirmMigrations Nothing)
   dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
   pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
   where
@@ -401,13 +403,13 @@ updateTokenCronSentAt st tknId now =
   withDB' "updateTokenCronSentAt" st $ \db ->
     void $ DB.execute db "UPDATE tokens t SET cron_sent_at = ? WHERE token_id = ?" (now, tknId)
 
-addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool)
+addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType (Int64, Bool))
 addNtfSubscription st sub =
   withFastDB "addNtfSubscription" st $ \db -> runExceptT $ do
     srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub
     n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub
     withLog "addNtfSubscription" st (`logCreateSubscription` sub)
-    pure $ n > 0
+    pure (srvId, n > 0)
   where
     -- It is possible to combine these two statements into one with CTEs,
     -- to reduce roundtrips in case of `insert`, but it would be making 2 queries in all cases.
@@ -454,8 +456,8 @@ deleteNtfSubscription st subId =
       DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId)
     withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId)
 
-updateSubStatus :: NtfPostgresStore -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
-updateSubStatus st nId status =
+updateSubStatus :: NtfPostgresStore -> Int64 -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
+updateSubStatus st srvId nId status =
   withFastDB' "updateSubStatus" st $ \db -> do
     sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
       maybeFirstRow id $
@@ -463,10 +465,10 @@ updateSubStatus st nId status =
           db
           [sql|
             UPDATE subscriptions SET status = ?
-            WHERE smp_notifier_id = ? AND status != ?
+            WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ?
             RETURNING subscription_id, ntf_service_assoc
           |]
-          (status, nId, status)
+          (status, srvId, nId, status)
     forM_ sub_ $ \(subId, serviceAssoc) ->
       withLog "updateSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
 

src/Simplex/Messaging/Protocol.hs

@@ -64,6 +64,8 @@ module Simplex.Messaging.Protocol
     EncFixedDataBytes,
     EncUserDataBytes,
     EncDataBytes (..),
+    NewNtfCreds (..),
+    ServerNtfCreds (..),
     Party (..),
     Cmd (..),
     QueueParty,
@@ -79,6 +81,7 @@ module Simplex.Messaging.Protocol
     CommandError (..),
     ProxyError (..),
     BrokerErrorType (..),
+    NetworkError (..),
     BlockingInfo (..),
     BlockingReason (..),
     RawTransmission,
@@ -114,6 +117,7 @@ module Simplex.Messaging.Protocol
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
+    pattern NoCorrId,
     EntityId (..),
     pattern NoEntity,
     QueueId,
@@ -165,6 +169,7 @@ module Simplex.Messaging.Protocol
     noMsgFlags,
     messageId,
     messageTs,
+    toNetworkError,
 
     -- * Parse and serialize
     ProtocolMsgTag (..),
@@ -209,7 +214,7 @@ module Simplex.Messaging.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
-import Control.Exception (Exception)
+import Control.Exception (Exception, SomeException, displayException, fromException)
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
@@ -238,6 +243,7 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import qualified GHC.TypeLits as TE
 import qualified GHC.TypeLits as Type
 import Network.Socket (ServiceName)
+import qualified Network.TLS as TLS
 import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -582,9 +588,8 @@ data NewQueueReq = NewQueueReq
     rcvDhKey :: RcvPublicDhKey,
     auth_ :: Maybe BasicAuth,
     subMode :: SubscriptionMode,
-    queueReqData :: Maybe QueueReqData
-    -- TODO [notifications]
-    -- ntfCreds :: Maybe NewNtfCreds
+    queueReqData :: Maybe QueueReqData,
+    ntfCreds :: Maybe NewNtfCreds
   }
   deriving (Show)
 
@@ -628,8 +633,7 @@ instance ToField EncDataBytes where
   toField (EncDataBytes s) = toField (Binary s)
   {-# INLINE toField #-}
 
--- TODO [notifications]
--- data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
+data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
 
 instance StrEncoding SubscriptionMode where
   strEncode = \case
@@ -660,10 +664,9 @@ instance Encoding QueueReqData where
       'C' -> QRContact <$> smpP
       _ -> fail "bad QueueReqData"
 
--- TODO [notifications]
--- instance Encoding NewNtfCreds where
---   smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
---   smpP = NewNtfCreds <$> smpP <*> smpP
+instance Encoding NewNtfCreds where
+  smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
+  smpP = NewNtfCreds <$> smpP <*> smpP
 
 newtype EncTransmission = EncTransmission ByteString
   deriving (Show)
@@ -1370,6 +1373,9 @@ newtype CorrId = CorrId {bs :: ByteString}
   deriving (Eq, Ord, Show)
   deriving newtype (Encoding)
 
+pattern NoCorrId :: CorrId
+pattern NoCorrId = CorrId ""
+
 instance IsString CorrId where
   fromString = CorrId . fromString
   {-# INLINE fromString #-}
@@ -1393,19 +1399,17 @@ data QueueIdsKeys = QIK
     rcvPublicDhKey :: RcvPublicDhKey,
     queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
     linkId :: Maybe LinkId,
-    serviceId :: Maybe ServiceId
-    -- TODO [notifications]
-    -- serverNtfCreds :: Maybe ServerNtfCreds
+    serviceId :: Maybe ServiceId,
+    serverNtfCreds :: Maybe ServerNtfCreds
   }
   deriving (Eq, Show)
 
--- TODO [notifications]
--- data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
---   deriving (Eq, Show)
+data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
+  deriving (Eq, Show)
 
--- instance Encoding ServerNtfCreds where
---   smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
---   smpP = ServerNtfCreds <$> smpP <*> smpP
+instance Encoding ServerNtfCreds where
+  smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
+  smpP = ServerNtfCreds <$> smpP <*> smpP
 
 -- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
 --
@@ -1554,7 +1558,7 @@ data BrokerErrorType
   | -- | unexpected response
     UNEXPECTED {respErr :: String}
   | -- | network error
-    NETWORK
+    NETWORK {networkError :: NetworkError}
   | -- | no compatible server host (e.g. onion when public is required, or vice versa)
     HOST
   | -- | service unavailable client-side - used in agent errors
@@ -1565,6 +1569,24 @@ data BrokerErrorType
     TIMEOUT
   deriving (Eq, Read, Show, Exception)
 
+data NetworkError
+  = NEConnectError {connectError :: String}
+  | NETLSError {tlsError :: String}
+  | NEUnknownCAError
+  | NEFailedError
+  | NETimeoutError
+  | NESubscribeError {subscribeError :: String}
+  deriving (Eq, Read, Show)
+
+toNetworkError :: SomeException -> NetworkError
+toNetworkError e = maybe (NEConnectError err) fromTLSError (fromException e)
+  where
+    err = displayException e
+    fromTLSError :: TLS.TLSException -> NetworkError
+    fromTLSError = \case
+      TLS.HandshakeFailed (TLS.Error_Protocol _ TLS.UnknownCa) -> NEUnknownCAError
+      _ -> NETLSError err
+
 data BlockingInfo = BlockingInfo
   { reason :: BlockingReason
   }
@@ -1650,7 +1672,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -
 instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol v = \case
-    NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData}
+    NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
+      | v >= newNtfCredsSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
       | v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData)
       | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
       | otherwise -> new <> auth <> e subMode
@@ -1735,19 +1758,20 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
     CT SCreator NEW_ -> Cmd SCreator <$> newCmd
       where
         newCmd
-          | v >= shortLinksSMPVersion = new smpP smpP
-          | v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP)
-          | otherwise = new auth (pure Nothing)
+          | v >= newNtfCredsSMPVersion = new smpP smpP smpP
+          | v >= shortLinksSMPVersion = new smpP smpP nothing
+          | v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP) nothing
+          | otherwise = new auth nothing nothing
           where
-            new p1 p2 = NEW <$> do
+            nothing = pure Nothing
+            new p1 p2 p3 = NEW <$> do
               rcvAuthKey <- _smpP
               rcvDhKey <- smpP
               auth_ <- p1
               subMode <- smpP
               queueReqData <- p2
-              -- TODO [notifications]
-              -- ntfCreds <- p3
-              pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData} -- ntfCreds
+              ntfCreds <- p3
+              pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
             auth = optional (A.char 'A' *> smpP)
             qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
     CT SRecipient tag ->
@@ -1792,7 +1816,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
 instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol v = \case
-    IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId}
+    IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
+      | v >= newNtfCredsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId <> e serverNtfCreds
       | v >= serviceCertsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId
       | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId
       | v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
@@ -1833,23 +1858,23 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       where
         bodyP = EncRcvMsgBody . unTail <$> smpP
     IDS_
-      | v >= serviceCertsSMPVersion -> ids smpP smpP smpP
-      | v >= shortLinksSMPVersion -> ids smpP smpP nothing
-      | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
-      | otherwise -> ids nothing nothing nothing
+      | v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
+      | v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
+      | v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
+      | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing nothing
+      | otherwise -> ids nothing nothing nothing nothing
       where
         qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
         nothing = pure Nothing
-        ids p1 p2 p3 = do
+        ids p1 p2 p3 p4 = do
           rcvId <- _smpP
           sndId <- smpP
           rcvPublicDhKey <- smpP
           queueMode <- p1
           linkId <- p2
           serviceId <- p3
-          -- TODO [notifications]
-          -- serverNtfCreds <- p3
-          pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId}
+          serverNtfCreds <- p4
+          pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
     LNK_ -> LNK <$> _smpP <*> smpP
     SOK_ -> SOK <$> _smpP
     SOKS_ -> SOKS <$> _smpP
@@ -1997,7 +2022,7 @@ instance Encoding BrokerErrorType where
     RESPONSE e -> "RESPONSE " <> smpEncode e
     UNEXPECTED e -> "UNEXPECTED " <> smpEncode e
     TRANSPORT e -> "TRANSPORT " <> smpEncode e
-    NETWORK -> "NETWORK"
+    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> smpEncode e
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
     NO_SERVICE -> "NO_SERVICE"
@@ -2006,7 +2031,7 @@ instance Encoding BrokerErrorType where
       "RESPONSE" -> RESPONSE <$> _smpP
       "UNEXPECTED" -> UNEXPECTED <$> _smpP
       "TRANSPORT" -> TRANSPORT <$> _smpP
-      "NETWORK" -> pure NETWORK
+      "NETWORK" -> NETWORK <$> (_smpP <|> pure NEFailedError)
       "TIMEOUT" -> pure TIMEOUT
       "HOST" -> pure HOST
       "NO_SERVICE" -> pure NO_SERVICE
@@ -2017,7 +2042,7 @@ instance StrEncoding BrokerErrorType where
     RESPONSE e -> "RESPONSE " <> encodeUtf8 (T.pack e)
     UNEXPECTED e -> "UNEXPECTED " <> encodeUtf8 (T.pack e)
     TRANSPORT e -> "TRANSPORT " <> smpEncode e
-    NETWORK -> "NETWORK"
+    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> strEncode e
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
     NO_SERVICE -> "NO_SERVICE"
@@ -2026,13 +2051,50 @@ instance StrEncoding BrokerErrorType where
       "RESPONSE" -> RESPONSE <$> _textP
       "UNEXPECTED" -> UNEXPECTED <$> _textP
       "TRANSPORT" -> TRANSPORT <$> _smpP
-      "NETWORK" -> pure NETWORK
+      "NETWORK" -> NETWORK <$> (_strP <|> pure NEFailedError)
       "TIMEOUT" -> pure TIMEOUT
       "HOST" -> pure HOST
       "NO_SERVICE" -> pure NO_SERVICE
       _ -> fail "bad BrokerErrorType"
-    where
-      _textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString)
+
+instance Encoding NetworkError where
+  smpEncode = \case
+    NEConnectError e -> "CONNECT " <> smpEncode e
+    NETLSError e -> "TLS " <> smpEncode e
+    NEUnknownCAError -> "UNKNOWNCA"
+    NEFailedError -> "FAILED"
+    NETimeoutError -> "TIMEOUT"
+    NESubscribeError e -> "SUBSCRIBE " <> smpEncode e
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "CONNECT" -> NEConnectError <$> _smpP
+      "TLS" -> NETLSError <$> _smpP
+      "UNKNOWNCA" -> pure NEUnknownCAError
+      "FAILED" -> pure NEFailedError
+      "TIMEOUT" -> pure NETimeoutError
+      "SUBSCRIBE" -> NESubscribeError <$> _smpP
+      _ -> fail "bad NetworkError"
+
+instance StrEncoding NetworkError where
+  strEncode = \case
+    NEConnectError e -> "CONNECT " <> encodeUtf8 (T.pack e)
+    NETLSError e -> "TLS " <> encodeUtf8 (T.pack e)
+    NEUnknownCAError -> "UNKNOWNCA"
+    NEFailedError -> "FAILED"
+    NETimeoutError -> "TIMEOUT"
+    NESubscribeError e -> "SUBSCRIBE " <> encodeUtf8 (T.pack e)
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "CONNECT" -> NEConnectError <$> _textP
+      "TLS" -> NETLSError <$> _textP
+      "UNKNOWNCA" -> pure NEUnknownCAError
+      "FAILED" -> pure NEFailedError
+      "TIMEOUT" -> pure NETimeoutError
+      "SUBSCRIBE" -> NESubscribeError <$> _textP
+      _ -> fail "bad NetworkError"
+
+_textP :: Parser String
+_textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString)
 
 -- | Send signed SMP transmission to TCP transport.
 tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
@@ -2196,6 +2258,12 @@ $(J.deriveJSON defaultJSON ''MsgFlags)
 
 $(J.deriveJSON (sumTypeJSON id) ''CommandError)
 
+$(J.deriveToJSON (sumTypeJSON $ dropPrefix "NE") ''NetworkError)
+
+instance FromJSON NetworkError where
+  parseJSON = $(J.mkParseJSON (sumTypeJSON $ dropPrefix "NE") ''NetworkError)
+  omittedField = Just NEFailedError
+
 $(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
 
 $(J.deriveJSON defaultJSON ''BlockingInfo)

src/Simplex/Messaging/Server.hs

@@ -31,6 +31,7 @@
 module Simplex.Messaging.Server
   ( runSMPServer,
     runSMPServerBlocking,
+    controlPortAuth,
     importMessages,
     exportMessages,
     printMessageStats,
@@ -61,17 +62,18 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Constraint (Dict (..))
 import Data.Dynamic (toDyn)
 import Data.Either (fromRight, partitionEithers)
+import Data.Foldable (foldrM)
 import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
-import Data.List (foldl', intercalate, mapAccumR)
+import Data.List (foldl', intercalate)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
+import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Semigroup (Sum (..))
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -103,7 +105,7 @@ import Simplex.Messaging.Server.Control
 import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
@@ -130,12 +132,17 @@ import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
+
 #if MIN_VERSION_base(4,18,0)
 import Data.List (sort)
 import GHC.Conc (listThreads, threadStatus)
 import GHC.Conc.Sync (threadLabel)
 #endif
 
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats)
+#endif
+
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
@@ -201,15 +208,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       env <- ask
       liftIO $ case (httpCreds_, attachHTTP_) of
         (Just httpCreds, Just attachHTTP) | addHTTP ->
-          runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg {serverALPN = Just combinedALPNs} $ \s (sniUsed, h) ->
+          runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
             case cast h of
               Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext
               _ -> runClient srvCert srvSignKey t h `runReaderT` env
           where
             combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
-            combinedALPNs = alpnSupportedSMPHandshakes <> httpALPN
-            httpALPN :: [ALPN]
-            httpALPN = ["h2", "http/1.1"]
         _ ->
           runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
 
@@ -271,6 +275,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 as'' <- if prevServiceId == serviceId_ then pure [] else endServiceSub prevServiceId qId END
                 case serviceId_ of
                   Just serviceId -> do
+                    modifyTVar' totalServiceSubs (+ 1) -- server count for all services
                     as <- endQueueSub qId END
                     as' <- cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers
                     pure $ as ++ as' ++ as''
@@ -282,8 +287,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 as <- endQueueSub qId DELD
                 as' <- endServiceSub serviceId qId DELD
                 pure $ as ++ as'
-              CSService serviceId -> do
+              CSService serviceId count -> do
                 modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients
+                modifyTVar' totalServiceSubs (+ count) -- server count for all services
                 cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers
             updateSubDisconnected = case clntSub of
                 -- do not insert client if it is already disconnected, but send END/DELD to any other client subscribed to this queue or service
@@ -296,7 +302,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                   as <- endQueueSub qId DELD
                   as' <- endServiceSub serviceId qId DELD
                   pure $ as ++ as'
-                CSService serviceId -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers
+                CSService serviceId _ -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers
             endQueueSub :: QueueId -> BrokerMsg -> STM [PrevClientSub s]
             endQueueSub qId msg = prevSub qId msg (CSAEndSub qId) =<< lookupDeleteSubscribedClient qId queueSubscribers
             endServiceSub :: Maybe ServiceId -> QueueId -> BrokerMsg -> STM [PrevClientSub s]
@@ -382,7 +388,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept"
                 unlessM (currentClient readTVar c) $ cancelNtfs "not current client"
                 whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full"
-                writeTBQueue sndQ ts
+                writeTBQueue sndQ (ts, [])
               pure $ length ts_
             currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool
             currentClient rd Client {clientId, connected} = (&&) <$> rd connected <*> (IS.member clientId <$> rd subClients)
@@ -393,7 +399,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 ntfs -> do
                   writeTVar v []
                   pure $ foldl' (\acc' ntf -> nmsg nId ntf : acc') acc ntfs -- reverses, to order by time
-            nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (CorrId "", nId, NMSG ntfNonce ntfEncMeta)
+            nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (NoCorrId, nId, NMSG ntfNonce ntfEncMeta)
             updateNtfStats :: Client s' -> Either SomeException Int -> IO ()
             updateNtfStats Client {clientId} = \case
               Right 0 -> pure ()
@@ -419,14 +425,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           where
             enqueueEvts evts c@Client {connected, sndQ} =
               whenM (readTVarIO connected) $ do
-                sent <- atomically $ tryWriteTBQueue sndQ ts
+                sent <- atomically $ tryWriteTBQueue sndQ (ts, [])
                 if sent
                   then updateEndStats
                   else -- if queue is full it can block
-                    forkClient c ("sendPendingEvtsThread.queueEvts") $
-                      atomically (writeTBQueue sndQ ts) >> updateEndStats
+                    forkClient c "sendPendingEvtsThread.queueEvts" $
+                      atomically (writeTBQueue sndQ (ts, [])) >> updateEndStats
               where
-                ts = L.map (\(entId, evt) -> (CorrId "", entId, evt)) evts
+                ts = L.map (\(entId, evt) -> (NoCorrId, entId, evt)) evts
                 -- this accounts for both END and DELD events
                 updateEndStats = do
                   let len = L.length evts
@@ -476,7 +482,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               atomicWriteIORef (msgCount stats) stored
               atomicModifyIORef'_ (msgExpired stats) (+ expired)
               printMessageStats "STORE: messages" msgStats
-            Left e -> logError $ "STORE: withAllMsgQueues, error expiring messages, " <> tshow e
+            Left e -> logError $ "STORE: expireOldMessages, error expiring messages, " <> tshow e
 
     expireNtfsThread :: ServerConfig s -> M s ()
     expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do
@@ -555,6 +561,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0
           msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0
           msgNtfExpired' <- atomicSwapIORef (msgNtfExpired ss) 0
+          _qBlocked <- atomicSwapIORef (qBlocked ss) 0 -- not logged, only reset
           pRelays' <- getResetProxyStatsData pRelays
           pRelaysOwn' <- getResetProxyStatsData pRelaysOwn
           pMsgFwds' <- getResetProxyStatsData pMsgFwds
@@ -703,7 +710,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times')
                 else acc
             countSubs acc@(!cnt, times) Sub {delivered} = do
-              delivered_ <- atomically $ tryReadTMVar delivered
+              delivered_ <- readTVarIO delivered
               pure $ case delivered_ of
                 Nothing -> acc
                 Just (_, ts) -> (cnt + 1, updateTimeBuckets ts ts' times)
@@ -767,12 +774,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+              CPAuth auth -> controlPortAuth h user admin role auth
                 where
-                  newRole ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
-                    | Just auth == admin = CPRAdmin
-                    | Just auth == user = CPRUser
-                    | otherwise = CPRNone
+                  ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
               CPSuspend -> withAdminRole $ hPutStrLn h "suspend not implemented"
               CPResume -> withAdminRole $ hPutStrLn h "resume not implemented"
               CPClients -> withAdminRole $ do
@@ -961,41 +965,53 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                               SubPending -> (c1, c2 + 1, c3, c4)
                               SubThread _ -> (c1, c2, c3 + 1, c4)
                           ProhibitSub -> pure (c1, c2, c3, c4 + 1)
-              CPDelete sId -> withUserRole $ unliftIO u $ do
+              CPDelete qId -> withAdminRole $ unliftIO u $ do
                 st <- asks msgStore
                 r <- liftIO $ runExceptT $ do
-                  q <- ExceptT $ getQueue st SSender sId
+                  (q, _) <- ExceptT $ getSenderQueue st qId
                   ExceptT $ deleteQueueSize st q
                 case r of
                   Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
                   Right (qr, numDeleted) -> do
                     updateDeletedStats qr
                     liftIO $ hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted"
-              CPStatus sId -> withUserRole $ unliftIO u $ do
+              CPStatus qId -> withUserRole $ unliftIO u $ do
                 st <- asks msgStore
-                q <- liftIO $ getQueueRec st SSender sId
+                q <- liftIO $ getSenderQueue st qId
                 liftIO $ hPutStrLn h $ case q of
                   Left e -> "error: " <> show e
                   Right (_, QueueRec {queueMode, status, updatedAt}) ->
                     "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", queueMode: " <> show queueMode
-              CPBlock sId info -> withUserRole $ unliftIO u $ do
+              CPBlock qId info -> withUserRole $ unliftIO u $ do
+                st <- asks msgStore
+                stats <- asks serverStats
+                blocked <- liftIO $ readIORef $ qBlocked stats
+                let quota = dailyBlockQueueQuota cfg
+                if blocked >= quota && quota /= 0
+                  then liftIO $ hPutStrLn h $ "error: reached limit of " <> show quota <> " queues blocked daily"
+                  else do
+                    r <- liftIO $ runExceptT $ do
+                      (q, QueueRec {status}) <- ExceptT $ getSenderQueue st qId
+                      when (status == EntityActive) $ ExceptT $ blockQueue (queueStore st) q info
+                      pure status
+                    case r of
+                      Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
+                      Right EntityActive -> do
+                        incStat $ qBlocked stats
+                        liftIO $ hPutStrLn h "ok, queue blocked"
+                      Right status -> liftIO $ hPutStrLn h $ "ok, already inactive: " <> show status
+              CPUnblock qId -> withUserRole $ unliftIO u $ do
                 st <- asks msgStore
                 r <- liftIO $ runExceptT $ do
-                  q <- ExceptT $ getQueue st SSender sId
-                  ExceptT $ blockQueue (queueStore st) q info
-                case r of
-                  Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
-                  Right () -> do
-                    incStat . qBlocked =<< asks serverStats
-                    liftIO $ hPutStrLn h "ok"
-              CPUnblock sId -> withUserRole $ unliftIO u $ do
-                st <- asks msgStore
-                r <- liftIO $ runExceptT $ do
-                  q <- ExceptT $ getQueue st SSender sId
-                  ExceptT $ unblockQueue (queueStore st) q
+                  (q, QueueRec {status}) <- ExceptT $ getSenderQueue st qId
+                  case status of
+                    EntityBlocked info -> Right info <$ ExceptT (unblockQueue (queueStore st) q)
+                    EntityActive -> pure $ Left True
+                    EntityOff -> pure $ Left False
                 liftIO $ hPutStrLn h $ case r of
                   Left e -> "error: " <> show e
-                  Right () -> "ok"
+                  Right (Right info) -> "ok, queue unblocked, reason to block was: " <> show info
+                  Right (Left unblocked) -> if unblocked then "ok, queue was active" else "error, queue is inactive"
               CPSave -> withAdminRole $ withLock' (savingLock srv) "control" $ do
                 hPutStrLn h "saving server state..."
                 unliftIO u $ saveServer False
@@ -1004,6 +1020,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               CPQuit -> pure ()
               CPSkip -> pure ()
               where
+                getSenderQueue st qId =
+                  getQueueRec st SSender qId >>= \case
+                    Right r -> pure $ Right r
+                    Left AUTH -> getQueueRec st SSenderLink qId
+                    Left e ->  pure $ Left e
                 withUserRole action = readTVarIO role >>= \case
                   CPRAdmin -> action
                   CPRUser -> action
@@ -1042,6 +1063,20 @@ runClientTransport h@THandle {params = thParams@THandleParams {sessionId}} = do
       where
         hasSubs ServerSubscribers {subClients} = IS.member clientId <$> readTVarIO subClients
 
+controlPortAuth :: Handle -> Maybe BasicAuth -> Maybe BasicAuth -> TVar CPClientRole -> BasicAuth -> IO ()
+controlPortAuth h user admin role auth = do
+  readTVarIO role >>= \case
+    CPRNone -> do
+      atomically $ writeTVar role $! newRole
+      hPutStrLn h $ currentRole newRole
+    r -> hPutStrLn h $ currentRole r <> if r == newRole then "" else ", start new session to change."
+  where
+    currentRole r = "Current role is " <> show r
+    newRole
+      | Just auth == admin = CPRAdmin
+      | Just auth == user = CPRUser
+      | otherwise = CPRNone
+
 clientDisconnected :: forall s. Client s -> M s ()
 clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceSubsCount, ntfServiceSubsCount, connected, clientTHParams = THandleParams {sessionId, thAuth}, endThreads} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
@@ -1095,7 +1130,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
     atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
     let (es, ts') = partitionEithers $ L.toList ts
         errs = map (second ERR) es
-    case ts' of
+    errs' <- case ts' of
       (_, _, (_, _, Cmd p cmd)) : rest -> do
         let service = peerClientService =<< thAuth
         (errs', cmds) <- partitionEithers <$> case batchParty p of
@@ -1105,9 +1140,10 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
             qs <- getQueueRecs ms p $ map queueId ts'
             zipWithM (\t -> verified stats t . verifyLoadedQueue service thAuth t) ts' qs
           _ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts'
-        write rcvQ cmds
-        write sndQ $ errs ++ errs'
-      [] -> write sndQ errs
+        mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds
+        pure $ errs ++ errs'
+      [] -> pure errs
+    mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs'
   where
     sameParty :: SParty p -> SignedTransmission Cmd -> Bool
     sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p'
@@ -1129,32 +1165,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
             NSUB -> incStat $ ntfSubAuth stats
             GET -> incStat $ msgGetAuth stats
             _ -> pure ()
-    write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
 send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
 send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
   forever $ atomically (readTBQueue sndQ) >>= sendTransmissions
   where
-    sendTransmissions :: NonEmpty (Transmission BrokerMsg) -> IO ()
-    sendTransmissions ts
-      | L.length ts <= 2 = tSend th c ts
+    -- If the request had batched subscriptions
+    -- this will reply SOKs to all SUBs in the first batched transmission,
+    -- to reduce client timeouts.
+    -- After that all messages will be sent in separate transmissions,
+    -- without any client response timeouts, and allowing them to interleave
+    -- with other requests responses.
+    sendTransmissions :: (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
+    sendTransmissions (ts, []) = tSend th c ts
+    sendTransmissions (ts, msg : msgs)
+      | length ts <= 4 = do -- up to 4 SOKs can be in one block with MSG (see testBatchSubResponses test)
+          tSend th c $ ts <> [msg]
+          mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs
       | otherwise = do
-          let (msgs_, ts') = mapAccumR splitMessages [] ts
-          -- If the request had batched subscriptions and L.length ts > 2
-          -- this will reply OK to all SUBs in the first batched transmission,
-          -- to reduce client timeouts.
-          tSend th c ts'
-          -- After that all messages will be sent in separate transmissions,
-          -- without any client response timeouts, and allowing them to interleave
-          -- with other requests responses.
-          mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs_
-      where
-        splitMessages :: [Transmission BrokerMsg] -> Transmission BrokerMsg -> ([Transmission BrokerMsg], Transmission BrokerMsg)
-        splitMessages msgs t@(corrId, entId, cmd) = case cmd of
-          -- replace MSG response with OK, accumulating MSG in a separate list.
-          MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
-          _ -> (msgs, t)
+          tSend th c ts
+          atomically $ writeTBQueue msgQ (msg :| msgs)
 
 sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
 sendMsg th c@Client {msgQ, clientTHParams = THandleParams {sessionId}} = do
@@ -1200,7 +1231,7 @@ verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case
   Left e -> VRFailed e
 
 verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s
-verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(Cmd p cmd))) q_
+verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_
   | not checkRole = VRFailed $ CMD PROHIBITED
   | not verifyServiceSig = VRFailed SERVICE
   | otherwise = vc p cmd
@@ -1226,8 +1257,8 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(
     verify = verifyCmdAuthorization thAuth tAuth authorized' corrId
     verifyServiceCmd :: VerificationResult s
     verifyServiceCmd = case (service, tAuth) of
-      (Just THClientService {serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing))
-        | C.verify' k s authorized -> VRVerified Nothing
+      (Just THClientService {serviceId, serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing))
+        | entId == serviceId && C.verify' k s authorized -> VRVerified Nothing
       _ -> VRFailed SERVICE
     -- this function verify service signature for commands that use it in service sessions
     verifyServiceSig
@@ -1321,19 +1352,20 @@ client
   -- TODO [certs rcv] rcv subscriptions
   Server {subscribers, ntfSubscribers}
   ms
-  clnt@Client {clientId, subscriptions, ntfSubscriptions, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
+  clnt@Client {clientId, ntfSubscriptions, ntfServiceSubscribed, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
     labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
     let THandleParams {thVersion} = thParams'
-        service = peerClientService =<< thAuth thParams'
+        clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
+        process t acc@(rs, msgs) =
+          (maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_)))
+            <$> processCommand clntServiceId thVersion t
     forever $
       atomically (readTBQueue rcvQ)
-        >>= mapM (processCommand service thVersion)
-        >>= mapM_ reply . L.nonEmpty . catMaybes . L.toList
+        >>= foldrM process ([], [])
+        >>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_)
   where
-    reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m ()
-    reply = atomically . writeTBQueue sndQ
-    processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe (Transmission BrokerMsg))
-    processProxiedCmd (corrId, EntityId sessId, command) = (corrId,EntityId sessId,) <$$> case command of
+    processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe ResponseAndMessage)
+    processProxiedCmd (corrId, EntityId sessId, command) = (\t -> ((corrId, EntityId sessId, t), Nothing)) <$$> case command of
       PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH)
         where
           allowProxy = do
@@ -1396,7 +1428,7 @@ client
         forkProxiedCmd cmdAction = do
           bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do
             -- commands MUST be processed under a reasonable timeout or the client would halt
-            cmdAction >>= \t -> reply [(corrId, EntityId sessId, t)]
+            cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, EntityId sessId, t)], [])
           pure Nothing
           where
             wait = do
@@ -1412,32 +1444,32 @@ client
     mkIncProxyStats ps psOwn own sel = do
       incStat $ sel ps
       when own $ incStat $ sel psOwn
-    processCommand :: Maybe THPeerClientService -> VersionSMP -> VerifiedTransmission s -> M s (Maybe (Transmission BrokerMsg))
-    processCommand service clntVersion (q_, (corrId, entId, cmd)) = case cmd of
+    processCommand :: Maybe ServiceId -> VersionSMP -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage)
+    processCommand clntServiceId clntVersion (q_, (corrId, entId, cmd)) = case cmd of
       Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
-      Cmd SSender command -> Just <$> case command of
+      Cmd SSender command -> case command of
         SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k
-        SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody
-      Cmd SIdleClient PING -> pure $ Just (corrId, NoEntity, PONG)
-      Cmd SProxyService (RFWD encBlock) -> Just . (corrId,NoEntity,) <$> processForwardedCommand encBlock
-      Cmd SSenderLink command -> Just <$> case command of
+        SEND flags msgBody -> response <$> withQueue_ False err (sendMessage flags msgBody)
+      Cmd SIdleClient PING -> pure $ response (corrId, NoEntity, PONG)
+      Cmd SProxyService (RFWD encBlock) -> response . (corrId,NoEntity,) <$> processForwardedCommand encBlock
+      Cmd SSenderLink command -> case command of
         LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
         LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
-      Cmd SNotifier NSUB -> Just . (corrId,entId,) <$> case q_ of
+      Cmd SNotifier NSUB -> response . (corrId,entId,) <$> case q_ of
         Just (q, QueueRec {notifier = Just ntfCreds}) -> subscribeNotifications q ntfCreds
         _ -> pure $ ERR INTERNAL
-      Cmd SNotifierService NSUBS -> Just . (corrId,entId,) <$> case service of
-        Just s -> subscribeServiceNotifications s
+      Cmd SNotifierService NSUBS -> response . (corrId,entId,) <$> case clntServiceId of
+        Just serviceId -> subscribeServiceNotifications serviceId
         Nothing -> pure $ ERR INTERNAL
       Cmd SCreator (NEW nqr@NewQueueReq {auth_}) ->
-        Just <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
+        response <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
           where
             allowNew = do
               ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
               pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth
       Cmd SRecipient command ->
-        Just <$> case command of
-          SUB -> withQueue subscribeQueue
+        case command of
+          SUB -> withQueue' subscribeQueueAndDeliver
           GET -> withQueue getMessage
           ACK msgId -> withQueue $ acknowledgeMsg msgId
           KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey
@@ -1453,25 +1485,24 @@ client
               Nothing -> pure ok
           NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey
           NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q
-          OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_
-          DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_
+          OFF -> response <$> maybe (pure $ err INTERNAL) suspendQueue_ q_
+          DEL -> response <$> maybe (pure $ err INTERNAL) delQueueAndMsgs q_
           QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr
-      Cmd SRecipientService SUBS -> pure $ Just $ err (CMD PROHIBITED) -- "TODO [certs rcv]"
+      Cmd SRecipientService SUBS -> pure $ response $ err (CMD PROHIBITED) -- "TODO [certs rcv]"
       where
         createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
-        createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData}
-          | isJust service && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED)
-          | otherwise = time "NEW" $ do
+        createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds}
+          | isJust clntServiceId && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED)
+          | otherwise = do
               g <- asks random
               idSize <- asks $ queueIdBytes . config
               updatedAt <- Just <$> liftIO getSystemDate
               (rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g
-              -- TODO [notifications]
-              -- ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
-              --   (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
-              --   pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
+              ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
+                (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
+                pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
               let randId = EntityId <$> atomically (C.randomBytes idSize g)
-                  -- TODO [notifications] the remaining 24 bytes are reserver for notifier ID
+                  -- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
                   sndId' = B.take 24 $ C.sha3_384 (bs corrId)
                   tryCreate 0 = pure $ ERR INTERNAL
                   tryCreate n = do
@@ -1486,12 +1517,11 @@ client
                       then pure $ ERR $ CMD PROHIBITED
                       else do
                         rcvId <- randId
-                        -- TODO [notifications]
-                        -- ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
-                        --   notifierId <- randId
-                        --   pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey)
+                        ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
+                          notifierId <- randId
+                          let ntfCreds' = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId = Nothing}
+                          pure (ntfCreds', ServerNtfCreds notifierId rcvPubDhKey)
                         let queueMode = queueReqMode <$> queueReqData
-                            rcvServiceId = (\THClientService {serviceId} -> serviceId) <$> service
                             qr =
                               QueueRec
                                 { senderId = sndId,
@@ -1500,11 +1530,10 @@ client
                                   senderKey = Nothing,
                                   queueMode,
                                   queueData,
-                                  -- TODO [notifications]
-                                  notifier = Nothing, -- fst <$> ntf,
+                                  notifier = fst <$> ntf,
                                   status = EntityActive,
                                   updatedAt,
-                                  rcvServiceId
+                                  rcvServiceId = clntServiceId
                                 }
                         liftIO (addQueue ms rcvId qr) >>= \case
                           Left DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied?
@@ -1515,12 +1544,11 @@ client
                             stats <- asks serverStats
                             incStat $ qCreated stats
                             incStat $ qCount stats
-                            -- TODO [notifications]
-                            -- when (isJust ntf) $ incStat $ ntfCreated stats
+                            when (isJust ntf) $ incStat $ ntfNewCreated stats
                             case subMode of
                               SMOnlyCreate -> pure ()
-                              SMSubscribe -> void $ subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue
-                            pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = rcvServiceId} -- , serverNtfCreds = snd <$> ntf
+                              SMSubscribe -> subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue
+                            pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = clntServiceId, serverNtfCreds = snd <$> ntf}
               (corrId,entId,) <$> tryCreate (3 :: Int)
 
         -- this check allows to support contact queues created prior to SKEY,
@@ -1544,7 +1572,7 @@ client
         getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId
 
         addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M s (Transmission BrokerMsg)
-        addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do
+        addQueueNotifier_ q notifierKey dhKey = do
           (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
           let rcvNtfDhSecret = C.dh' dhKey privDhKey
           (corrId,entId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
@@ -1581,47 +1609,60 @@ client
         suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue (queueStore ms) q
 
         -- TODO [certs rcv] if serviceId is passed, associate with the service and respond with SOK
-        subscribeQueue :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
-        subscribeQueue q qr =
-          liftIO (TM.lookupIO rId subscriptions) >>= \case
-            Nothing -> subscribeNewQueue rId qr >>= deliver True
+        subscribeQueueAndDeliver :: StoreQueue s -> QueueRec -> M s ResponseAndMessage
+        subscribeQueueAndDeliver q qr =
+          liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case
+            Nothing -> subscribeRcvQueue qr >>= deliver False
             Just s@Sub {subThread} -> do
               stats <- asks serverStats
               case subThread of
                 ProhibitSub -> do
                   -- cannot use SUB in the same connection where GET was used
                   incStat $ qSubProhibited stats
-                  pure (corrId, rId, ERR $ CMD PROHIBITED)
+                  pure (err (CMD PROHIBITED), Nothing)
                 _ -> do
                   incStat $ qSubDuplicate stats
-                  atomically (tryTakeTMVar $ delivered s) >> deliver False s
+                  atomically (writeTVar (delivered s) Nothing) >> deliver True s
           where
-            rId = recipientId q
-            deliver :: Bool -> Sub -> M s (Transmission BrokerMsg)
-            deliver inc sub = do
+            deliver :: Bool -> Sub -> M s ResponseAndMessage
+            deliver hasSub sub = do
               stats <- asks serverStats
-              fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do
+              fmap (either ((,Nothing) . err) id) $ liftIO $ runExceptT $ do
                 msg_ <- tryPeekMsg ms q
-                liftIO $ when (inc && isJust msg_) $ incStat (qSub stats)
-                liftIO $ deliverMessage "SUB" qr rId sub msg_
+                msg' <- forM msg_ $ \msg -> liftIO $ do
+                  ts <- getSystemSeconds
+                  atomically $ setDelivered sub msg ts
+                  unless hasSub $ incStat $ qSub stats
+                  pure (NoCorrId, entId, MSG (encryptMsg qr msg))
+                pure ((corrId, entId, SOK clntServiceId), msg')
 
-        subscribeNewQueue :: RecipientId -> QueueRec -> M s Sub
-        subscribeNewQueue rId QueueRec {rcvServiceId} = time "SUB newSub" . atomically $ do
-          writeTQueue (subQ subscribers) (CSClient rId rcvServiceId Nothing, clientId)
+        -- TODO [certs rcv] combine with subscribing ntf queues
+        subscribeRcvQueue :: QueueRec -> M s Sub
+        subscribeRcvQueue QueueRec {rcvServiceId} = atomically $ do
+          writeTQueue (subQ subscribers) (CSClient entId rcvServiceId Nothing, clientId)
           sub <- newSubscription NoSub
-          TM.insert rId sub subscriptions
+          TM.insert entId sub $ subscriptions clnt
           pure sub
 
+        subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
+        subscribeNewQueue rId QueueRec {rcvServiceId} = do
+          case rcvServiceId of
+            Just _ -> atomically $ modifyTVar' (serviceSubsCount clnt) (+ 1)
+            Nothing -> do
+              sub <- atomically $ newSubscription NoSub
+              atomically $ TM.insert rId sub $ subscriptions clnt
+          atomically $ writeTQueue (subQ subscribers) (CSClient rId rcvServiceId rcvServiceId, clientId)
+
         -- clients that use GET are not added to server subscribers
         getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
-        getMessage q qr = time "GET" $ do
-          atomically (TM.lookup entId subscriptions) >>= \case
+        getMessage q qr = do
+          atomically (TM.lookup entId $ subscriptions clnt) >>= \case
             Nothing ->
               atomically newSub >>= (`getMessage_` Nothing)
             Just s@Sub {subThread} ->
               case subThread of
                 ProhibitSub ->
-                  atomically (tryTakeTMVar $ delivered s)
+                  atomically (swapTVar (delivered s) Nothing)
                     >>= getMessage_ s
                 -- cannot use GET in the same connection where there is an active subscription
                 _ -> do
@@ -1632,7 +1673,7 @@ client
             newSub :: STM Sub
             newSub = do
               s <- newProhibitedSub
-              TM.insert entId s subscriptions
+              TM.insert entId s $ subscriptions clnt
               -- Here we don't account for this client as subscribed in the server
               -- and don't notify other subscribed clients.
               -- This is tracked as "subscription" in the client to prevent these
@@ -1650,27 +1691,32 @@ client
                     atomically $ setDelivered s msg ts $> (corrId, entId, MSG encMsg)
                   Nothing -> incStat (msgGetNoMsg stats) $> ok
 
-        withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg)
-        withQueue = withQueue_ True
+        withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Maybe ResponseAndMessage)
+        withQueue = fmap response . withQueue_ True err
+        {-# INLINE withQueue #-}
+
+        withQueue' :: (StoreQueue s -> QueueRec -> M s ResponseAndMessage) -> M s (Maybe ResponseAndMessage)
+        withQueue' = fmap Just . withQueue_ True ((,Nothing) . err)
+        {-# INLINE withQueue' #-}
 
         -- SEND passes queueNotBlocked False here to update time, but it fails anyway on blocked queues (see code for SEND).
-        withQueue_ :: Bool -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg)
-        withQueue_ queueNotBlocked action = case q_ of
-          Nothing -> pure $ err INTERNAL
+        withQueue_ :: Bool -> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
+        withQueue_ queueNotBlocked err' action = case q_ of
+          Nothing -> pure $ err' INTERNAL
           Just (q, qr@QueueRec {status, updatedAt}) -> case status of
-            EntityBlocked info | queueNotBlocked -> pure $ err $ BLOCKED info
+            EntityBlocked info | queueNotBlocked -> pure $ err' $ BLOCKED info
             _ -> do
               t <- liftIO getSystemDate
               if updatedAt == Just t
                 then action q qr
-                else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err) (action q)
+                else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err') (action q)
 
         subscribeNotifications :: StoreQueue s -> NtfCreds -> M s BrokerMsg
         subscribeNotifications q NtfCreds {ntfServiceId} = do
           stats <- asks serverStats
           let incNtfSrvStat sel = incStat $ sel $ ntfServices stats
-          case service of
-            Just THClientService {serviceId}
+          case clntServiceId of
+            Just serviceId
               | ntfServiceId == Just serviceId -> do
                   -- duplicate queue-service association - can only happen in case of response error/timeout
                   hasSub <- atomically $ ifM hasServiceSub (pure True) (False <$ newServiceQueueSub)
@@ -1719,24 +1765,25 @@ client
                   incStat $ if hasSub then ntfSubDuplicate stats else ntfSub stats
                   pure $ SOK Nothing
 
-        subscribeServiceNotifications :: THPeerClientService -> M s BrokerMsg
-        subscribeServiceNotifications THClientService {serviceId} = do
-          srvSubs <- readTVarIO ntfServiceSubsCount
-          if srvSubs == 0
-            then
-              liftIO (getNtfServiceQueueCount @(StoreQueue s) (queueStore ms) serviceId) >>= \case
+        subscribeServiceNotifications :: ServiceId -> M s BrokerMsg
+        subscribeServiceNotifications serviceId = do
+          subscribed <- readTVarIO ntfServiceSubscribed
+          if subscribed
+            then SOKS <$> readTVarIO ntfServiceSubsCount
+            else
+              liftIO (getServiceQueueCount @(StoreQueue s) (queueStore ms) SNotifierService serviceId) >>= \case
                 Left e -> pure $ ERR e
-                Right count -> do
-                  atomically $ do
-                    modifyTVar' ntfServiceSubsCount (+ count) -- service count
-                    modifyTVar' (totalServiceSubs ntfSubscribers) (+ count) -- server count for all services
-                  atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId, clientId)
-                  pure $ SOKS count
-            else pure $ SOKS srvSubs
+                Right !count' -> do
+                  incCount <- atomically $ do
+                    writeTVar ntfServiceSubscribed True
+                    count <- swapTVar ntfServiceSubsCount count'
+                    pure $ count' - count
+                  atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId incCount, clientId)
+                  pure $ SOKS count'
 
         acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
-        acknowledgeMsg msgId q qr = time "ACK" $ do
-          liftIO (TM.lookupIO entId subscriptions) >>= \case
+        acknowledgeMsg msgId q qr =
+          liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case
             Nothing -> pure $ err NO_MSG
             Just sub ->
               atomically (getDelivered sub) >>= \case
@@ -1750,16 +1797,20 @@ client
                         pure ok
                       _ -> do
                         (deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId
-                        liftIO $ mapM_ (updateStats stats False ts) deletedMsg_
-                        liftIO $ deliverMessage "ACK" qr entId sub msg_
+                        liftIO $ do
+                          mapM_ (updateStats stats False ts) deletedMsg_
+                          forM_ msg_ $ \msg -> do
+                            ts' <- getSystemSeconds
+                            atomically $ setDelivered sub msg ts'
+                          pure (corrId, entId, maybe OK (MSG . encryptMsg qr) msg_)
                 _ -> pure $ err NO_MSG
           where
             getDelivered :: Sub -> STM (Maybe (ServerSub, RoundedSystemTime))
             getDelivered Sub {delivered, subThread} = do
-              tryTakeTMVar delivered $>>= \v@(msgId', ts) ->
+              readTVar delivered $>>= \(msgId', ts) ->
                 if msgId == msgId' || B.null msgId
-                  then pure $ Just (subThread, ts)
-                  else putTMVar delivered v $> Nothing
+                  then writeTVar delivered Nothing $> Just (subThread, ts)
+                  else pure Nothing
             updateStats :: ServerStats -> Bool -> RoundedSystemTime -> Message -> IO ()
             updateStats stats isGet deliveryTime = \case
               MessageQuota {} -> pure ()
@@ -1802,10 +1853,10 @@ client
                     Right body -> do
                       when (isJust (queueData qr) && isSecuredMsgQueue qr) $ void $ liftIO $
                         deleteQueueLinkData (queueStore ms) q
-                      ServerConfig {messageExpiration, msgIdBytes} <- asks config
+                      ServerConfig {messageExpiration, expireMessagesOnSend, msgIdBytes} <- asks config
                       msgId <- randomId' msgIdBytes
-                      msg_ <- liftIO $ time "SEND" $ runExceptT $ do
-                        expireMessages messageExpiration stats
+                      msg_ <- liftIO $ runExceptT $ do
+                        when expireMessagesOnSend $ mapM_ (expireMessages stats) messageExpiration
                         msg <- liftIO $ mkMessage msgId body
                         writeMsg ms q True msg
                       case msg_ of
@@ -1813,7 +1864,7 @@ client
                         Right Nothing -> do
                           incStat $ msgSentQuota stats
                           pure $ err QUOTA
-                        Right (Just (msg, wasEmpty)) -> time "SEND ok" $ do
+                        Right (Just (msg, wasEmpty)) -> do
                           when wasEmpty $ liftIO $ tryDeliverMessage msg
                           when (notification msgFlags) $ do
                             mapM_ (`enqueueNotification` msg) (notifier qr)
@@ -1829,9 +1880,9 @@ client
               msgTs <- getSystemTime
               pure $! Message msgId msgTs msgFlags body
 
-            expireMessages :: Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO ()
-            expireMessages msgExp stats = do
-              deleted <- maybe (pure 0) (deleteExpiredMsgs ms q <=< liftIO . expireBeforeEpoch) msgExp
+            expireMessages :: ServerStats -> ExpirationConfig -> ExceptT ErrorType IO ()
+            expireMessages stats msgExp = do
+              deleted <- deleteExpiredMsgs ms q =<< liftIO (expireBeforeEpoch msgExp)
               liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted)
 
             -- The condition for delivery of the message is:
@@ -1854,17 +1905,17 @@ client
                 deliverToSub rcv = do
                   ts <- getSystemSeconds
                   atomically $
-                  -- reading client TVar in the same transaction,
-                  -- so that if subscription ends, it re-evalutates
-                  -- and delivery is cancelled -
-                  -- the new client will receive message in response to SUB.
+                    -- reading client TVar in the same transaction,
+                    -- so that if subscription ends, it re-evalutates
+                    -- and delivery is cancelled -
+                    -- the new client will receive message in response to SUB.
                     readTVar rcv
                       $>>= \rc@Client {subscriptions = subs, sndQ = sndQ'} -> TM.lookup rId subs
                       $>>= \s@Sub {subThread, delivered} -> case subThread of
                         ProhibitSub -> pure Nothing
                         ServerSub st -> readTVar st >>= \case
                           NoSub ->
-                            tryTakeTMVar delivered >>= \case
+                            readTVar delivered >>= \case
                               Just _ -> pure Nothing -- if a message was already delivered, should not deliver more
                               Nothing ->
                                 ifM
@@ -1874,8 +1925,8 @@ client
                           _ -> pure Nothing
                 deliver sndQ' s ts = do
                   let encMsg = encryptMsg qr msg
-                  writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)]
-                  void $ setDelivered s msg ts
+                  writeTBQueue sndQ' ([(NoCorrId, rId, MSG encMsg)], [])
+                  setDelivered s msg ts
                 forkDeliver (rc@Client {sndQ = sndQ'}, s@Sub {delivered}, st) = do
                   t <- mkWeakThreadId =<< forkIO deliverThread
                   atomically $ modifyTVar' st $ \case
@@ -1888,10 +1939,10 @@ client
                       -- lookup can be outside of STM transaction,
                       -- as long as the check that it is the same client is inside.
                       getSubscribedClient rId (queueSubscribers subscribers) >>= mapM_ deliverIfSame
-                    deliverIfSame rcv = time "deliver" $ do
+                    deliverIfSame rcv = do
                       ts <- getSystemSeconds
                       atomically $ whenM (sameClient rc rcv) $
-                        tryTakeTMVar delivered >>= \case
+                        readTVar delivered >>= \case
                           Just _ -> pure () -- if a message was already delivered, should not deliver more
                           Nothing -> do
                             -- a separate thread is needed because it blocks when client sndQ is full.
@@ -1935,7 +1986,8 @@ client
               Left r -> pure r
               -- rejectOrVerify filters allowed commands, no need to repeat it here.
               -- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types).
-              Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand Nothing fwdVersion t'')
+              -- `fst` removes empty message that is only returned for `SUB` command
+              Right t''@(_, (corrId', entId', _)) -> maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing fwdVersion t'')
           -- encode response
           r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of
             [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
@@ -1968,22 +2020,6 @@ client
                     VRVerified q -> Right (q, t'')
                     VRFailed e -> Left (corrId', entId', ERR e)
 
-        deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg)
-        deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") $
-          case subThread of
-            ProhibitSub -> pure resp
-            _ -> case msg_ of
-              Just msg -> do
-                ts <- getSystemSeconds
-                let encMsg = encryptMsg qr msg
-                atomically (setDelivered s msg ts) $> (corrId, rId, MSG encMsg)
-              _ -> pure resp
-          where
-            resp = (corrId, rId, OK)
-
-        time :: MonadIO m => T.Text -> m a -> m a
-        time name = timed name entId
-
         encryptMsg :: QueueRec -> Message -> RcvMessage
         encryptMsg qr msg = encrypt . encodeRcvMsgBody $ case msg of
           Message {msgFlags, msgBody} -> RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
@@ -1994,21 +2030,21 @@ client
             msgId' = messageId msg
             msgTs' = messageTs msg
 
-        setDelivered :: Sub -> Message -> RoundedSystemTime -> STM Bool
+        setDelivered :: Sub -> Message -> RoundedSystemTime -> STM ()
         setDelivered Sub {delivered} msg !ts = do
           let !msgId = messageId msg
-          tryPutTMVar delivered (msgId, ts)
+          writeTVar delivered $ Just (msgId, ts)
 
         delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
         delQueueAndMsgs (q, QueueRec {rcvServiceId}) = do
           liftIO (deleteQueue ms q) >>= \case
             Right qr -> do
               -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
-              atomically $ do
-                writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId)
-                -- queue is usually deleted by the same client that is currently subscribed,
-                -- we delete subscription here, so the client with no subscriptions can be disconnected.
-                TM.delete entId subscriptions
+              -- queue is usually deleted by the same client that is currently subscribed,
+              -- we delete subscription here, so the client with no subscriptions can be disconnected.
+              sub <- atomically $ TM.lookupDelete entId $ subscriptions clnt
+              liftIO $ mapM_ cancelSub sub
+              atomically $ writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId)
               forM_ (notifier qr) $ \NtfCreds {notifierId = nId, ntfServiceId} -> do
                 -- queue is deleted by a different client from the one subscribed to notifications,
                 -- so we don't need to remove subscription from the current client.
@@ -2023,7 +2059,7 @@ client
         getQueueInfo :: StoreQueue s -> QueueRec -> M s BrokerMsg
         getQueueInfo q QueueRec {senderKey, notifier} = do
           fmap (either ERR INFO) $ liftIO $ runExceptT $ do
-            qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub
+            qiSub <- liftIO $ TM.lookupIO entId (subscriptions clnt) >>= mapM mkQSub
             qiSize <- getQueueSize ms q
             qiMsg <- toMsgInfo <$$> tryPeekMsg ms q
             let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
@@ -2038,14 +2074,20 @@ client
                     SubPending -> QSubPending
                     SubThread _ -> QSubThread
                 ProhibitSub -> pure QProhibitSub
-              qDelivered <- atomically $ decodeLatin1 . encode . fst <$$> tryReadTMVar delivered
+              qDelivered <- decodeLatin1 . encode . fst <$$> readTVarIO delivered
               pure QSub {qSubThread, qDelivered}
 
         ok :: Transmission BrokerMsg
         ok = (corrId, entId, OK)
+        {-# INLINE ok #-}
 
         err :: ErrorType -> Transmission BrokerMsg
         err e = (corrId, entId, ERR e)
+        {-# INLINE err #-}
+
+        response :: Transmission BrokerMsg -> Maybe ResponseAndMessage
+        response = Just . (,Nothing)
+        {-# INLINE response #-}
 
 updateDeletedStats :: QueueRec -> M s ()
 updateDeletedStats q = do
@@ -2059,18 +2101,6 @@ incStat :: MonadIO m => IORef Int -> m ()
 incStat r = liftIO $ atomicModifyIORef'_ r (+ 1)
 {-# INLINE incStat #-}
 
-timed :: MonadIO m => T.Text -> RecipientId -> m a -> m a
-timed name (EntityId qId) a = do
-  t <- liftIO getSystemTime
-  r <- a
-  t' <- liftIO getSystemTime
-  let int = diff t t'
-  when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int]
-  pure r
-  where
-    diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
-    sec = 1000_000000
-
 randomId' :: Int -> M s ByteString
 randomId' n = atomically . C.randomBytes n =<< asks random
 
@@ -2079,27 +2109,42 @@ randomId = fmap EntityId . randomId'
 {-# INLINE randomId #-}
 
 saveServerMessages :: Bool -> MsgStore s -> IO ()
-saveServerMessages drainMsgs = \case
-  StoreMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
+saveServerMessages drainMsgs ms = case ms of
+  StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
     Just f -> exportMessages False ms f drainMsgs
     Nothing -> logNote "undelivered messages are not saved"
   StoreJournal _ -> logNote "closed journal message storage"
+#if defined(dbServerPostgres)
+  StoreDatabase _ -> logNote "closed postgres message storage"
+#endif
 
-exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
-exportMessages tty ms f drainMsgs = do
+exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO ()
+exportMessages tty st f drainMsgs = do
   logNote $ "saving messages to file " <> T.pack f
-  liftIO $ withFile f WriteMode $ \h ->
-    tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case
-      Right (Sum total) -> logNote $ "messages saved: " <> tshow total
+  run $ case st of
+    StoreMemory ms -> exportMessages_ ms $ getMsgs ms
+    StoreJournal ms -> exportMessages_ ms $ getJournalMsgs ms
+#if defined(dbServerPostgres)
+    StoreDatabase ms -> exportDbMessages tty ms
+#endif
+  where
+    exportMessages_ ms get = fmap (\(Sum n) -> n) . unsafeWithAllMsgQueues tty ms . saveQueueMsgs get
+    run :: (Handle -> IO Int) -> IO ()
+    run a = liftIO $ withFile f WriteMode $ tryAny . a >=> \case
+      Right n -> logNote $ "messages saved: " <> tshow n
       Left e -> do
         logError $ "error exporting messages: " <> tshow e
         exitFailure
-  where
-    saveQueueMsgs h q = do
-      msgs <-
-        unsafeRunStore q "saveQueueMsgs" $
-          getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
-      BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
+    getJournalMsgs ms q =
+      readTVarIO (msgQueue' q) >>= \case
+        Just _ -> getMsgs ms q
+        Nothing -> getJournalQueueMessages ms q
+    getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
+    getMsgs ms q = unsafeRunStore q "saveQueueMsgs" $ getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
+    saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int)
+    saveQueueMsgs get h q = do
+      msgs <- get q
+      unless (null msgs) $ BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
       pure $ Sum $ length msgs
     encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n')
 
@@ -2115,6 +2160,9 @@ processServerMessages StartOptions {skipWarnings} = do
           Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing)
           Nothing -> pure Nothing
         StoreJournal ms -> processJournalMessages old_ expire ms
+#if defined(dbServerPostgres)
+        StoreDatabase ms -> processDbMessages old_ expire ms
+#endif
       processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
       processJournalMessages old_ expire ms
         | expire = Just <$> case old_ of
@@ -2126,7 +2174,7 @@ processServerMessages StartOptions {skipWarnings} = do
               run processValidateQueue
         | otherwise = logWarn "skipping message expiration" $> Nothing
         where
-          run a = unsafeWithAllMsgQueues False False ms a `catchAny` \_ -> exitFailure
+          run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
           processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
           processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
             mq <- getMsgQueue ms q False
@@ -2137,6 +2185,17 @@ processServerMessages StartOptions {skipWarnings} = do
           processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do
             storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False
             pure newMessageStats {storedMsgsCount, storedQueues = 1}
+#if defined(dbServerPostgres)
+      processDbMessages old_ expire ms
+        | expire = Just <$> case old_ of
+            Just old -> do
+              -- TODO [messages] expire messages from all queues, not only recent
+              logNote "expiring database store messages..."
+              now <- systemSeconds <$> getSystemTime
+              expireOldMessages False ms now (now - old)
+            Nothing -> getDbMessageStats ms
+        | otherwise = logWarn "skipping message expiration" $> Nothing
+#endif
 
 importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
 importMessages tty ms f old_ skipWarnings  = do

src/Simplex/Messaging/Server/CLI.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -32,9 +33,10 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
-import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), dbStoreCfg, storeLogFile')
+import Simplex.Messaging.Server.Main.GitCommit
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
-import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..))
+import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -97,6 +99,12 @@ getCliCommand' cmdP version =
   where
     versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
 
+simplexmqVersionCommit :: String
+simplexmqVersionCommit = simplexMQVersion <> " / " <> take 7 simplexmqCommit
+
+simplexmqCommit :: String
+simplexmqCommit = $(gitCommit)
+
 createServerX509 :: FilePath -> X509Config -> IO ByteString
 createServerX509 = createServerX509_ True
 
@@ -406,12 +414,13 @@ printServerTransports protocol ts = do
       \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
 
 printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
-printSMPServerConfig transports = \case
-  SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
-  SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile
-  SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
-    B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
-    printServerTransports "SMP" transports
+printSMPServerConfig transports st = case dbStoreCfg st of
+  Just cfg -> printDBConfig cfg
+  Nothing -> printServerConfig "SMP" transports $ storeLogFile' st
+  where
+    printDBConfig PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}} = do
+      B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
+      printServerTransports "SMP" transports
 
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

src/Simplex/Messaging/Server/Control.hs

@@ -8,7 +8,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
 
 data CPClientRole = CPRNone | CPRUser | CPRAdmin
-  deriving (Eq)
+  deriving (Eq, Show)
 
 data ControlProtocol
   = CPAuth BasicAuth

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

@@ -40,6 +40,7 @@ module Simplex.Messaging.Server.Env.STM
     MsgStore (..),
     AStoreType (..),
     VerifiedTransmission,
+    ResponseAndMessage,
     newEnv,
     mkJournalStoreConfig,
     msgStore,
@@ -71,7 +72,10 @@ module Simplex.Messaging.Server.Env.STM
     defaultIdleQueueInterval,
     journalMsgStoreDepth,
     readWriteQueueStore,
+    noPostgresExitStr,
     noPostgresExit,
+    dbStoreCfg,
+    storeLogFile',
   )
 where
 
@@ -130,6 +134,10 @@ import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.MsgStore.Postgres
+#endif
+
 data ServerConfig s = ServerConfig
   { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
@@ -148,9 +156,11 @@ data ServerConfig s = ServerConfig
     -- | control port passwords,
     controlPortUserAuth :: Maybe BasicAuth,
     controlPortAdminAuth :: Maybe BasicAuth,
+    dailyBlockQueueQuota :: Int,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     expireMessagesOnStart :: Bool,
+    expireMessagesOnSend :: Bool,
     -- | interval of inactivity after which journal queue is closed
     idleQueueInterval :: Int64,
     -- | notification expiration interval (seconds)
@@ -272,14 +282,25 @@ fromMsgStore :: MsgStore s -> s
 fromMsgStore = \case
   StoreMemory s -> s
   StoreJournal s -> s
+#if defined(dbServerPostgres)
+  StoreDatabase s -> s
+#endif
 {-# INLINE fromMsgStore #-}
 
 type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
   SupportedStore 'QSMemory 'MSMemory = ()
   SupportedStore 'QSMemory 'MSJournal = ()
-  SupportedStore 'QSPostgres 'MSJournal = ()
+  SupportedStore 'QSMemory 'MSPostgres =
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in Postgres DB with queues in memory is not supported"))
   SupportedStore 'QSPostgres 'MSMemory =
-    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported"))
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with queues in Postgres DB is not supported"))
+  SupportedStore 'QSPostgres 'MSJournal = ()
+#if defined(dbServerPostgres)
+  SupportedStore 'QSPostgres 'MSPostgres = ()
+#else
+  SupportedStore 'QSPostgres 'MSPostgres =
+    (Int ~ Bool, TypeError ('TE.Text "Server compiled without server_postgres flag"))
+#endif
 
 data AStoreType =
   forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
@@ -289,16 +310,43 @@ data ServerStoreCfg s where
   SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore
   SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory)
   SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres)
+#if defined(dbServerPostgres)
+  SSCDatabase :: PostgresStoreCfg -> ServerStoreCfg PostgresMsgStore
+#endif
+
+dbStoreCfg :: ServerStoreCfg s -> Maybe PostgresStoreCfg
+dbStoreCfg = \case
+  SSCMemory _ -> Nothing
+  SSCMemoryJournal {} -> Nothing
+  SSCDatabaseJournal {storeCfg} -> Just storeCfg
+#if defined(dbServerPostgres)
+  SSCDatabase cfg -> Just cfg
+#endif
+
+storeLogFile' :: ServerStoreCfg s -> Maybe FilePath
+storeLogFile' = \case
+  SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> Just storeLogFile
+  SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbStoreLogPath}} -> dbStoreLogPath
+#if defined(dbServerPostgres)
+  SSCDatabase (PostgresStoreCfg {dbStoreLogPath}) -> dbStoreLogPath
+#endif
 
 data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath}
 
 type family MsgStoreType (qs :: QSType) (ms :: MSType) where
   MsgStoreType 'QSMemory 'MSMemory = STMMsgStore
   MsgStoreType qs 'MSJournal = JournalMsgStore qs
+#if defined(dbServerPostgres)
+  MsgStoreType 'QSPostgres 'MSPostgres = PostgresMsgStore
+#endif
 
 data MsgStore s where
   StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
   StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
+#if defined(dbServerPostgres)
+  StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore
+#endif
 
 data Server s = Server
   { clients :: ServerClients s,
@@ -377,7 +425,7 @@ sameClient c cv = maybe False (sameClientId c) <$> readTVar cv
 data ClientSub
   = CSClient QueueId (Maybe ServiceId) (Maybe ServiceId) -- includes previous and new associated service IDs
   | CSDeleted QueueId (Maybe ServiceId) -- includes previously associated service IDs
-  | CSService ServiceId -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB
+  | CSService ServiceId Int64 -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB
 
 newtype ProxyAgent = ProxyAgent
   { smpAgent :: SMPClientAgent 'Sender
@@ -389,10 +437,12 @@ data Client s = Client
   { clientId :: ClientId,
     subscriptions :: TMap RecipientId Sub,
     ntfSubscriptions :: TMap NotifierId (),
+    serviceSubscribed :: TVar Bool, -- set independently of serviceSubsCount, to track whether service subscription command was received
+    ntfServiceSubscribed :: TVar Bool,
     serviceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count
     ntfServiceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count
     rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s)),
-    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
+    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
     endThreads :: TVar (IntMap (Weak ThreadId)),
@@ -406,13 +456,15 @@ data Client s = Client
 
 type VerifiedTransmission s = (Maybe (StoreQueue s, QueueRec), Transmission Cmd)
 
+type ResponseAndMessage = (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
+
 data ServerSub = ServerSub (TVar SubscriptionThread) | ProhibitSub
 
 data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId)
 
 data Sub = Sub
   { subThread :: ServerSub, -- Nothing value indicates that sub
-    delivered :: TMVar (MsgId, RoundedSystemTime)
+    delivered :: TVar (Maybe (MsgId, RoundedSystemTime))
   }
 
 newServer :: IO (Server s)
@@ -458,6 +510,8 @@ newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemT
 newClient clientId qSize clientTHParams createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
+  serviceSubscribed <- newTVarIO False
+  ntfServiceSubscribed <- newTVarIO False
   serviceSubsCount <- newTVarIO 0
   ntfServiceSubsCount <- newTVarIO 0
   rcvQ <- newTBQueueIO qSize
@@ -474,6 +528,8 @@ newClient clientId qSize clientTHParams createdAt = do
       { clientId,
         subscriptions,
         ntfSubscriptions,
+        serviceSubscribed,
+        ntfServiceSubscribed,
         serviceSubsCount,
         ntfServiceSubsCount,
         rcvQ,
@@ -491,13 +547,13 @@ newClient clientId qSize clientTHParams createdAt = do
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
-  delivered <- newEmptyTMVar
+  delivered <- newTVar Nothing
   subThread <- ServerSub <$> newTVar st
   return Sub {subThread, delivered}
 
 newProhibitedSub :: STM Sub
 newProhibitedSub = do
-  delivered <- newEmptyTMVar
+  delivered <- newTVar Nothing
   return Sub {subThread = ProhibitSub, delivered}
 
 newEnv :: ServerConfig s -> IO (Env s)
@@ -522,8 +578,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
           qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
           cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
       when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
-      ms <- newMsgStore cfg
-      pure $ StoreJournal ms
+      StoreJournal <$> newMsgStore cfg
+    SSCDatabase storeCfg -> do
+      let StartOptions {compactLog, confirmMigrations} = startOptions config
+          cfg = PostgresMsgStoreCfg storeCfg {confirmMigrations} msgQueueQuota
+      when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
+      StoreDatabase <$> newMsgStore cfg
 #else
     SSCDatabaseJournal {} -> noPostgresExit
 #endif
@@ -617,10 +677,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
           _ -> SPMMessages
 
 noPostgresExit :: IO a
-noPostgresExit = do
-  putStrLn "Error: server binary is compiled without support for PostgreSQL database."
-  putStrLn "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
-  exitFailure
+noPostgresExit = putStrLn noPostgresExitStr >> exitFailure
+
+noPostgresExitStr :: String
+noPostgresExitStr =
+  "Error: server binary is compiled without support for PostgreSQL database.\n"
+    <> "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
 
 mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
 mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =

src/Simplex/Messaging/Server/Information.hs

@@ -14,7 +14,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Int (Int64)
 import Data.Maybe (isJust)
 import Data.Text (Text)
-import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri)
+import Simplex.Messaging.Agent.Protocol (ConnectionLink, ConnectionMode (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
 
@@ -100,7 +100,7 @@ data Entity = Entity {name :: Text, country :: Maybe Text}
   deriving (Show)
 
 data ServerContactAddress = ServerContactAddress
-  { simplex :: Maybe (ConnectionRequestUri 'CMContact),
+  { simplex :: Maybe (ConnectionLink 'CMContact),
     email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present
     pgp :: Maybe PGPKey
   }

src/Simplex/Messaging/Server/Main.hs

@@ -18,9 +18,10 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
-import Control.Exception (finally)
+import Control.Exception (SomeException, finally, try)
 import Control.Logger.Simple
 import Control.Monad
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, toUpper)
@@ -37,7 +38,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import qualified Data.Text.IO as T
 import Options.Applicative
-import Simplex.Messaging.Agent.Protocol (connReqUriP')
+import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
@@ -56,14 +57,15 @@ import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCf
 import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config
 import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
-import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
-import Simplex.Messaging.Util (eitherToMaybe, ifM)
+import Simplex.Messaging.Util (eitherToMaybe, ifM, unlessM)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import System.IO (BufferMode (..), IOMode (..), hSetBuffering, stderr, stdout, withFile)
 import Text.Read (readMaybe)
 
 #if defined(dbServerPostgres)
@@ -72,6 +74,7 @@ import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
 import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
 import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
 import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
+import Simplex.Messaging.Server.MsgStore.Postgres
 import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
 import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
 import Simplex.Messaging.Server.QueueStore.Types
@@ -128,6 +131,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               printMessageStats "Messages" msgStats
               putStrLn $ case readStoreType ini of
                 Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
+                Right (ASType SQSPostgres SMSPostgres) -> "store_messages set to `database`, update it to `journal` in INI file"
                 Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
                 Left e -> e <> ", configure storage correctly"
         SCExport
@@ -139,19 +143,31 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               confirmOrExit
                 ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
                 "Journal not exported"
-              ms <- newJournalMsgStore logPath MQStoreCfg
-              -- TODO [postgres] in case postgres configured, queues must be read from database
-              readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
-              exportMessages True ms storeMsgsFilePath False
-              putStrLn "Export completed"
               case readStoreType ini of
-                Right (ASType SQSMemory SMSMemory) -> putStrLn "store_messages set to `memory`, start the server."
-                Right (ASType SQSMemory SMSJournal) -> putStrLn "store_messages set to `journal`, update it to `memory` in INI file"
-                Right (ASType SQSPostgres SMSJournal) ->
+                Right (ASType SQSMemory msType) -> do
+                  ms <- newJournalMsgStore logPath MQStoreCfg
+                  readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
+                  exportMessages True (StoreJournal ms) storeMsgsFilePath False
+                  putStrLn "Export completed"
+                  putStrLn $ case msType of
+                    SMSMemory -> "store_messages set to `memory`, start the server."
+                    SMSJournal -> "store_messages set to `journal`, update it to `memory` in INI file"
 #if defined(dbServerPostgres)
+                Right (ASType SQSPostgres SMSJournal) -> do
+                  let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+                      dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
+                  unlessM (checkSchemaExists connstr schema) $ do
+                    putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+                    exitFailure
+                  ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+                  exportMessages True (StoreJournal ms) storeMsgsFilePath False
+                  putStrLn "Export completed"
                   putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
+                Right (ASType SQSPostgres SMSPostgres) -> do
+                  putStrLn $ "Messages can be exported with `dabatase export --table messages`."
+                  exitFailure
 #else
-                  noPostgresExit
+                Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
 #endif
                 Left e -> putStrLn $ e <> ", configure storage correctly"
         SCDelete
@@ -165,11 +181,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               deleteDirIfExists storeMsgsJournalDir
               putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
 #if defined(dbServerPostgres)
-    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+    Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
       schemaExists <- checkSchemaExists connstr schema
       storeLogExists <- doesFileExist storeLogFilePath
-      case cmd of
-        SCImport
+      msgsFileExists <- doesFileExist storeMsgsFilePath
+      case (cmd, tables) of
+        (SCImport, DTQueues)
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
@@ -187,12 +204,29 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               putStrLn $ case readStoreType ini of
                 Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
                 Right (ASType SQSMemory SMSJournal) -> setToDbStr
-                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server."
+                Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
                 Left e -> e <> ", configure storage correctly"
           where
             setToDbStr :: String
             setToDbStr = "store_queues set to `memory`, update it to `database` in INI file"
-        SCExport
+        (SCImport, DTMessages)
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | not msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Message records not imported"
+              mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
+              putStrLn $ "Import completed: " <> show mCnt <> " messages"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
+                Right _ -> "set store_queues and store_messages set to `database` in INI file"
+                Left e -> e <> ", configure storage correctly"
+        (SCExport, DTQueues)
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
@@ -202,15 +236,33 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               exitFailure
           | otherwise -> do
               confirmOrExit
-                ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
                 "Queue records not exported"
               (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
               putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
               putStrLn $ case readStoreType ini of
-                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
+                Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
                 Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
                 Left e -> e <> ", configure storage correctly"
-        SCDelete
+        (SCExport, DTMessages)
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: Messages from PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to message log file " <> storeMsgsFilePath)
+                "Message records not exported"
+              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
+              ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
+              withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
+                Right mCnt -> do
+                  putStrLn $ "Export completed: " <> show mCnt <> " messages"
+                  putStrLn "Export queues with `smp-server database export queues`"
+                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
+        (SCDelete, _)
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
               exitFailure
@@ -234,7 +286,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
         Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
     iniFile = combine cfgPath "smp-server.ini"
-    serverVersion = "SMP server v" <> simplexMQVersion
+    serverVersion = "SMP server v" <> simplexmqVersionCommit
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
     storeMsgsFilePath = combine logPath "smp-server-messages.log"
@@ -244,8 +296,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
     readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
       ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
       ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
+      ("memory", "database") -> Left "Database and memory storage are not compatible."
+      ("database", "memory") -> Left "Database and memory storage are not compatible."
       ("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
-      ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
+#if defined(dbServerPostgres)
+      ("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
+#else
+      ("database", "database") -> Left noPostgresExitStr
+#endif
       (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
       where
         iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
@@ -395,6 +453,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
               storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
            in SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}
+#if defined(dbServerPostgres)
+        iniStoreCfg SQSPostgres SMSPostgres =
+          let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+              storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+           in SSCDatabase storeCfg
+#endif
         serverConfig :: ServerStoreCfg s -> ServerConfig s
         serverConfig serverStoreCfg =
           ServerConfig
@@ -420,12 +484,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
               controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini,
               controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini,
+              dailyBlockQueueQuota = readIniDefault 20 "AUTH" "daily_block_queue_quota" ini,
               messageExpiration =
                 Just
                   defaultMessageExpiration
                     { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                     },
               expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
+              expireMessagesOnSend = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_send" ini,
               idleQueueInterval = defaultIdleQueueInterval,
               notificationExpiration =
                 defaultNtfExpiration
@@ -449,7 +515,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               transportConfig =
                 mkTransportServerConfig
                   (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just alpnSupportedSMPHandshakes)
+                  (Just $ alpnSupportedSMPHandshakes <> httpALPN)
                   (fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
               controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
               smpAgentCfg =
@@ -502,6 +568,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       msgsFileExists <- doesFileExist storeMsgsFilePath
       storeLogExists <- doesFileExist storeLogFilePath
       case mode of
+#if defined(dbServerPostgres)
+        ASType SQSPostgres SMSPostgres
+          | msgsFileExists || msgsDirExists -> do
+              putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
+              putStrLn "Configure memory storage."
+              exitFailure
+          | otherwise -> checkDbStorage ini storeLogExists
+#endif
         ASType qs SMSJournal
           | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
           | msgsFileExists -> do
@@ -514,28 +588,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               SQSMemory ->
                 unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
 #if defined(dbServerPostgres)
-              SQSPostgres -> do
-                let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
-                schemaExists <- checkSchemaExists connstr schema
-                case enableDbStoreLog' ini of
-                  Just ()
-                    | not schemaExists -> noDatabaseSchema connstr schema
-                    | not storeLogExists -> do
-                        putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
-                        exitFailure
-                    | otherwise -> pure ()
-                  Nothing
-                    | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
-                    | storeLogExists -> do
-                        putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
-                        putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
-                        exitFailure
-                    | not schemaExists -> noDatabaseSchema connstr schema
-                    | otherwise -> pure ()
-                where
-                  noDatabaseSchema connstr schema = do
-                    putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
-                    exitFailure
+              SQSPostgres -> checkDbStorage ini storeLogExists
 #else
               SQSPostgres -> noPostgresExit
 #endif
@@ -553,6 +606,29 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       exitFailure
 
 #if defined(dbServerPostgres)
+    checkDbStorage ini storeLogExists = do
+      let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
+      schemaExists <- checkSchemaExists connstr schema
+      case enableDbStoreLog' ini of
+        Just ()
+          | not schemaExists -> noDatabaseSchema connstr schema
+          | not storeLogExists -> do
+              putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
+              exitFailure
+          | otherwise -> pure ()
+        Nothing
+          | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
+          | storeLogExists -> do
+              putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
+              putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
+              exitFailure
+          | not schemaExists -> noDatabaseSchema connstr schema
+          | otherwise -> pure ()
+      where
+        noDatabaseSchema connstr schema = do
+          putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
+          exitFailure
+
     exitConfigureQueueStore connstr schema = do
       putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
       putStrLn "Configure queue storage."
@@ -573,13 +649,28 @@ importStoreLogToDatabase logPath storeLogFile dbOpts = do
   renameFile storeLogFile $ storeLogFile <> ".bak"
   pure (sCnt, qCnt)
 
+importMessagesToDatabase :: FilePath -> DBOpts -> IO Int64
+importMessagesToDatabase msgsLogFile dbOpts = do
+  let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
+  ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
+  mCnt <- getDbMessageCount ms
+  when (mCnt > 0) $ do
+    confirmOrExit ("WARNING: the database contains messages, they will be deleted.") "Message records not imported"
+    deleteAllMessages ms
+  inserted <- batchInsertMessages True msgsLogFile $ queueStore ms
+  mCnt' <- getDbMessageCount ms
+  unless (inserted == mCnt') $ putStrLn $ "WARNING: inserted " <> show inserted <> " rows, table has " <> show mCnt' <> " messages."
+  updateQueueCounts ms
+  renameFile msgsLogFile $ msgsLogFile <> ".bak"
+  pure mCnt'
+
 exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
 exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
   let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
   ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
   sl <- openWriteStoreLog False storeLogFilePath
   Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
-  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
+  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
   closeStoreLog sl
   pure (sCnt, qCnt)
 #endif
@@ -637,7 +728,8 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
         <$!> infoValue nameField
     countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
     iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
-      let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+      let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+          linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
           email = infoValue emailField
           pkURI_ = infoValue pgpKeyUriField
           pkFingerprint_ = infoValue pgpKeyFingerprintField
@@ -664,10 +756,22 @@ data CliCommand
   | Start StartOptions
   | Delete
   | Journal StoreCmd
-  | Database StoreCmd DBOpts
+  | Database StoreCmd DatabaseTable DBOpts
 
 data StoreCmd = SCImport | SCExport | SCDelete
 
+data DatabaseTable = DTQueues | DTMessages
+
+instance StrEncoding DatabaseTable where
+  strEncode = \case
+    DTQueues -> "queues"
+    DTMessages -> "messages"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "queues" -> pure DTQueues
+      "messages" -> pure DTMessages
+      _ -> fail "DatabaseTable"
+
 cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
@@ -676,7 +780,7 @@ cliCommandP cfgPath logPath iniFile =
         <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
         <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
-        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -806,7 +910,7 @@ cliCommandP cfgPath logPath iniFile =
             sourceCode = T.pack <$> sourceCode,
             serverInfo =
               ServerPublicInfo
-                { sourceCode = T.pack simplexmqSource,
+                { sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode,
                   usageConditions = Nothing,
                   operator = fst operator_,
                   website,
@@ -830,6 +934,13 @@ cliCommandP cfgPath logPath iniFile =
             <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
             <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
         )
+    dbTableP =
+      option
+        strParse
+        ( long "table"
+            <> help "Database tables: queues/messages"
+            <> metavar "TABLE"
+        )
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Messaging.Server.Main.GitCommit where
+
+import Language.Haskell.TH
+import System.Process
+import Control.Exception
+import System.Exit
+
+gitCommit :: Q Exp
+gitCommit = stringE . commit =<< runIO (try $ readProcessWithExitCode "git" ["rev-parse", "HEAD"] "")
+  where
+    commit :: Either SomeException (ExitCode, String, String) -> String
+    commit = \case
+      Right (ExitSuccess, out, _) -> take 40 out
+      _ -> ""

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

@@ -87,12 +87,13 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
     <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
     <> "# Messages and notifications expiration periods.\n"
     <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
-    <> "expire_messages_on_start: on\n"
+    <> "expire_messages_on_start: on\n\
+        \expire_messages_on_send: off\n"
     <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
     <> "# Log daily server statistics to CSV file\n"
     <> ("log_stats: " <> onOff logStats <> "\n\n")
     <> "# Log interval for real-time Prometheus metrics\n\
-        \# prometheus_interval: 300\n\n\
+        \# prometheus_interval: 60\n\n\
         \[AUTH]\n\
         \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
         \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
@@ -107,8 +108,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
         )
     <> "\n\n"
     <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
-    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
-    <> "\n\
+    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n\n")
+    <> "# The limit for queues that can be blocked via control port per day, resets at 0:00 UTC.\n\
+        \# Set to 0 to disable limit, to -1 to prohibit blocking. Default is 20.\n\
+        \# daily_block_queue_quota: 20\n\
+        \\n\
         \[TRANSPORT]\n\
         \# Host is only used to print server address on start.\n\
         \# You can specify multiple server ports.\n"

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

@@ -24,7 +24,7 @@ module Simplex.Messaging.Server.MsgStore.Journal
   ( JournalMsgStore (random, expireBackupsBefore),
     QStore (..),
     QStoreCfg (..),
-    JournalQueue,
+    JournalQueue (msgQueue'), -- msgQueue' is used in tests
     JournalMsgQueue (queue, state),
     JMQueue (queueDirectory, statePath),
     JournalStoreConfig (..),
@@ -38,6 +38,7 @@ module Simplex.Messaging.Server.MsgStore.Journal
     msgQueueStatePath,
     readQueueState,
     newMsgQueueState,
+    getJournalQueueMessages,
     newJournalId,
     appendState,
     queueLogFileName,
@@ -58,7 +59,7 @@ import Control.Monad.Trans.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
+import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (sort)
@@ -290,13 +291,10 @@ newtype StoreIO (s :: QSType) a = StoreIO {unStoreIO :: IO a}
   deriving newtype (Functor, Applicative, Monad)
 
 instance StoreQueueClass (JournalQueue s) where
-  type MsgQueue (JournalQueue s) = JournalMsgQueue s
   recipientId = recipientId'
   {-# INLINE recipientId #-}
   queueRec = queueRec'
   {-# INLINE queueRec #-}
-  msgQueue = msgQueue'
-  {-# INLINE msgQueue #-}
   withQueueLock :: JournalQueue s -> Text -> IO a -> IO a
   withQueueLock JournalQueue {recipientId', queueLock, sharedLock} =
     withLockWaitShared recipientId' queueLock sharedLock
@@ -309,7 +307,7 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
   newQueueStore = \case
     MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) ()
 #if defined(dbServerPostgres)
-    PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg
+    PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) (cfg, True)
 #endif
 
   closeQueueStore = withQS (closeQueueStore @(JournalQueue s))
@@ -356,8 +354,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
   {-# INLINE setQueueService #-}
   getQueueNtfServices = withQS (getQueueNtfServices @(JournalQueue s))
   {-# INLINE getQueueNtfServices #-}
-  getNtfServiceQueueCount = withQS (getNtfServiceQueueCount @(JournalQueue s))
-  {-# INLINE getNtfServiceQueueCount #-}
+  getServiceQueueCount = withQS (getServiceQueueCount @(JournalQueue s))
+  {-# INLINE getServiceQueueCount #-}
 
 makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s)
 makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do
@@ -378,6 +376,7 @@ makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do
 
 instance MsgStoreClass (JournalMsgStore s) where
   type StoreMonad (JournalMsgStore s) = StoreIO s
+  type MsgQueue (JournalMsgStore s) = JournalMsgQueue s
   type QueueStore (JournalMsgStore s) = QStore s
   type StoreQueue (JournalMsgStore s) = JournalQueue s
   type MsgStoreConfig (JournalMsgStore s) = JournalStoreConfig s
@@ -405,11 +404,11 @@ instance MsgStoreClass (JournalMsgStore s) where
 
   -- This function can only be used in server CLI commands or before server is started.
   -- It does not cache queues and is NOT concurrency safe.
-  unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
-  unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
+  unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of
     MQStore st -> withLoadedQueues st run
 #if defined(dbServerPostgres)
-    PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkQueue ms False) >=> run
+    PQStore st -> foldQueueRecs False tty st $ uncurry (mkQueue ms False) >=> run
 #endif
     where
       run q = do
@@ -421,7 +420,7 @@ instance MsgStoreClass (JournalMsgStore s) where
   expireOldMessages :: Bool -> JournalMsgStore s -> Int64 -> Int64 -> IO MessageStats
   expireOldMessages tty ms now ttl = case queueStore_ ms of
     MQStore st ->
-      withLoadedQueues st $ \q -> run $ isolateQueue q "deleteExpiredMsgs" $ do
+      withLoadedQueues st $ \q -> run $ isolateQueue ms q "deleteExpiredMsgs" $ do
         StoreIO (readTVarIO $ queueRec q) >>= \case
           Just QueueRec {updatedAt = Just (RoundedSystemTime t)} | t > veryOld ->
             expireQueueMsgs ms now old q
@@ -429,7 +428,7 @@ instance MsgStoreClass (JournalMsgStore s) where
 #if defined(dbServerPostgres)
     PQStore st -> do
       let JournalMsgStore {queueLocks, sharedLock} = ms
-      foldQueueRecs tty False st (Just veryOld) $ \(rId, qr) -> do
+      foldRecentQueueRecs veryOld tty st $ \(rId, qr) -> do
         q <- mkQueue ms False rId qr
         withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $
           getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old
@@ -485,7 +484,7 @@ instance MsgStoreClass (JournalMsgStore s) where
     where
       newQ = do
         let dir = msgQueueDirectory ms rId
-            statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
+            statePath = msgQueueStatePath dir rId
             queue = JMQueue {queueDirectory = dir, statePath}
         q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue)
         atomically $ writeTVar msgQueue' $ Just q
@@ -563,8 +562,9 @@ instance MsgStoreClass (JournalMsgStore s) where
     where
       getSize = maybe (pure (-1)) (fmap size . readTVarIO . state)
 
+   -- drainMsgs is never True with Journal storage
   getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message]
-  getQueueMessages_ drainMsgs q' q = StoreIO (run [])
+  getQueueMessages_ drainMsgs q' q = StoreIO $ if drainMsgs then run [] else readTVarIO (state q) >>= runFast
     where
       run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
       getMsg msgs hs = chooseReadJournal q' q drainMsgs hs >>= maybe (pure msgs) readMsg
@@ -573,9 +573,19 @@ instance MsgStoreClass (JournalMsgStore s) where
             (msg, len) <- hGetMsgAt h $ bytePos rs
             updateReadPos q' q drainMsgs len hs
             (msg :) <$> run msgs
+      runFast MsgQueueState {writeState = ws, readState = rs, size}
+        | size > 0 =
+            readTVarIO (handles q) >>= \case
+              Just (MsgQueueHandles _ rh wh_) -> do
+                msgs <- getJournalRange rh (bytePos rs) (byteCount rs)
+                case wh_ of
+                  Just wh -> (msgs ++) <$> getJournalRange wh 0 (bytePos ws)
+                  Nothing -> pure msgs
+              Nothing -> pure []
+        | otherwise = pure []
 
   writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
-  writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do
+  writeMsg ms q' logState msg = isolateQueue ms q' "writeMsg" $ do
     q <- getMsgQueue ms q' True
     StoreIO $ (`E.finally` updateActiveAt q') $ do
       st@MsgQueueState {canWrite, size} <- readTVarIO (state q)
@@ -649,8 +659,8 @@ instance MsgStoreClass (JournalMsgStore s) where
         $>>= \len -> readTVarIO handles
         $>>= \hs -> updateReadPos q mq logState len hs $> Just ()
 
-  isolateQueue :: JournalQueue s -> Text -> StoreIO s a -> ExceptT ErrorType IO a
-  isolateQueue sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO
+  isolateQueue :: JournalMsgStore s -> JournalQueue s -> Text -> StoreIO s a -> ExceptT ErrorType IO a
+  isolateQueue _ sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO
 
   unsafeRunStore :: JournalQueue s -> Text -> StoreIO s a -> IO a
   unsafeRunStore sq op a =
@@ -795,8 +805,8 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP
       let (seg, s') = B.splitAt 2 s
        in seg : splitSegments (n - 1) s'
 
-msgQueueStatePath :: FilePath -> String -> FilePath
-msgQueueStatePath dir queueId = dir </> (queueLogFileName <> "." <> queueId <> logFileExt)
+msgQueueStatePath :: FilePath -> RecipientId -> FilePath
+msgQueueStatePath dir rId = dir </> (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt)
 
 createNewJournal :: FilePath -> ByteString -> IO Handle
 createNewJournal dir journalId = do
@@ -965,10 +975,11 @@ deleteQueue_ ms q =
     pure r
   where
     rId = recipientId q
-    remove r@(_, mq_) = do
+    remove qr = do
+      mq_ <- atomically $ swapTVar (msgQueue' q) Nothing
       mapM_ (closeMsgQueueHandles ms) mq_
       removeQueueDirectory ms rId
-      pure r
+      pure (qr, mq_)
 
 closeMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO ()
 closeMsgQueue ms JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ (closeMsgQueueHandles ms)
@@ -1019,3 +1030,33 @@ hClose h =
 
 closeOnException :: Handle -> IO a -> IO a
 closeOnException h a = a `E.onException` hClose h
+
+getJournalQueueMessages :: JournalMsgStore s -> JournalQueue s -> IO [Message]
+getJournalQueueMessages ms q =
+  readQueueState ms (msgQueueStatePath dir rId) >>= \case
+    (Just MsgQueueState {readState = rs, writeState = ws, size}, _) | size > 0 -> do
+      msgs <- getMsgs (journalId rs) (bytePos rs) (byteCount rs)
+      if journalId rs == journalId ws
+        then pure msgs
+        else (msgs ++) <$> getMsgs (journalId ws) 0 (bytePos ws)
+    _ -> pure []
+  where
+    rId = recipientId' q
+    dir = msgQueueDirectory ms rId
+    getMsgs jId from to =
+      IO.withFile (journalFilePath dir jId) ReadWriteMode $ \h' ->
+        getJournalRange h' from to
+
+getJournalRange :: Handle -> Int64 -> Int64 -> IO [Message]
+getJournalRange h from to
+  | to > from = do
+      IO.hSeek h AbsoluteSeek $ fromIntegral from
+      parseMsgs =<< B.hGet h (fromIntegral $ to - from)
+  | otherwise = pure []
+  where
+    parseMsgs s = do
+      let (errs, msgs) = partitionEithers $ map strDecode $ B.lines s
+      unless (null errs) $ do
+        f <- IO.hShow h
+        putStrLn $ "Error reading " <> show (length errs) <> " messages from " <> f
+      pure msgs

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

@@ -0,0 +1,386 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Simplex.Messaging.Server.MsgStore.Postgres
+  ( PostgresMsgStore,
+    PostgresMsgStoreCfg (..),
+    PostgresQueue,
+    exportDbMessages,
+    getDbMessageStats,
+    getDbMessageCount,
+    deleteAllMessages,
+    batchInsertMessages,
+    updateQueueCounts,
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans.Except
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as LB
+import Data.Functor (($>))
+import Data.IORef
+import Data.Int (Int64)
+import Data.List (intersperse)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import Data.Time.Clock.System (SystemTime (..))
+import Database.PostgreSQL.Simple (Binary (..), Only (..), (:.) (..))
+import qualified Database.PostgreSQL.Simple as DB
+import qualified Database.PostgreSQL.Simple.Copy as DB
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore
+import Simplex.Messaging.Server.MsgStore.Types
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Postgres
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Server.StoreLog (foldLogLines)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow', (<$$>))
+import System.IO (Handle, hFlush, stdout)
+
+data PostgresMsgStore = PostgresMsgStore
+  { config :: PostgresMsgStoreCfg,
+    queueStore_ :: PostgresQueueStore'
+  }
+
+data PostgresMsgStoreCfg = PostgresMsgStoreCfg
+  { queueStoreCfg :: PostgresStoreCfg,
+    quota :: Int
+  }
+
+type PostgresQueueStore' = PostgresQueueStore PostgresQueue
+
+data PostgresQueue = PostgresQueue
+  { recipientId' :: RecipientId,
+    queueRec' :: TVar (Maybe QueueRec)
+  }
+
+instance StoreQueueClass PostgresQueue where
+  recipientId = recipientId'
+  {-# INLINE recipientId #-}
+  queueRec = queueRec'
+  {-# INLINE queueRec #-}
+  withQueueLock PostgresQueue {} _ = id -- TODO [messages] maybe it's just transaction?
+  {-# INLINE withQueueLock #-}
+
+newtype DBTransaction = DBTransaction {dbConn :: DB.Connection}
+
+type DBStoreIO a = ReaderT DBTransaction IO a
+
+instance MsgStoreClass PostgresMsgStore where
+  type StoreMonad PostgresMsgStore = ReaderT DBTransaction IO
+  type MsgQueue PostgresMsgStore = ()
+  type QueueStore PostgresMsgStore = PostgresQueueStore'
+  type StoreQueue PostgresMsgStore = PostgresQueue
+  type MsgStoreConfig PostgresMsgStore = PostgresMsgStoreCfg
+
+  newMsgStore :: PostgresMsgStoreCfg -> IO PostgresMsgStore
+  newMsgStore config = do
+    queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config, False)
+    pure PostgresMsgStore {config, queueStore_}
+
+  closeMsgStore :: PostgresMsgStore -> IO ()
+  closeMsgStore = closeQueueStore @PostgresQueue . queueStore_
+
+  withActiveMsgQueues _ _ = error "withActiveMsgQueues not used"
+
+  unsafeWithAllMsgQueues _ _ _ = error "unsafeWithAllMsgQueues not used"
+
+  expireOldMessages :: Bool -> PostgresMsgStore -> Int64 -> Int64 -> IO MessageStats
+  expireOldMessages _tty ms now ttl =
+    maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db ->
+      DB.query db "CALL expire_old_messages(?,?,?,0,0,0)" (oldQueue, oldMsg, batchSize)
+    where
+      st = dbStore $ queueStore_ ms
+      oldQueue = 0 :: Int64 -- expire all queues
+      oldMsg = now - ttl
+      batchSize = 10000 :: Int
+      toMessageStats (expiredMsgsCount, storedMsgsCount, storedQueues) =
+        MessageStats {expiredMsgsCount, storedMsgsCount, storedQueues}
+
+  logQueueStates _ = error "logQueueStates not used"
+
+  logQueueState _ = error "logQueueState not used"
+
+  queueStore = queueStore_
+  {-# INLINE queueStore #-}
+
+  loadedQueueCounts :: PostgresMsgStore -> IO LoadedQueueCounts
+  loadedQueueCounts ms = do
+    loadedQueueCount <- M.size <$> readTVarIO queues
+    loadedNotifierCount <- M.size <$> readTVarIO notifiers
+    notifierLockCount <- M.size <$> readTVarIO notifierLocks
+    pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount}
+    where
+      PostgresQueueStore {queues, notifiers, notifierLocks} = queueStore_ ms
+
+  mkQueue :: PostgresMsgStore -> Bool -> RecipientId -> QueueRec -> IO PostgresQueue
+  mkQueue _ _keepLock rId qr = PostgresQueue rId <$> newTVarIO (Just qr)
+  {-# INLINE mkQueue #-}
+
+  getMsgQueue _ _ _ = pure ()
+  {-# INLINE getMsgQueue #-}
+
+  getPeekMsgQueue :: PostgresMsgStore -> PostgresQueue -> DBStoreIO (Maybe ((), Message))
+  getPeekMsgQueue _ q = ((),) <$$> tryPeekMsg_ q ()
+
+  withIdleMsgQueue :: Int64 -> PostgresMsgStore -> PostgresQueue -> (() -> DBStoreIO a) -> DBStoreIO (Maybe a, Int)
+  withIdleMsgQueue _ _ _ _ = error "withIdleMsgQueue not used"
+
+  deleteQueue :: PostgresMsgStore -> PostgresQueue -> IO (Either ErrorType QueueRec)
+  deleteQueue ms q = deleteStoreQueue (queueStore_ ms) q
+  {-# INLINE deleteQueue #-}
+
+  deleteQueueSize :: PostgresMsgStore -> PostgresQueue -> IO (Either ErrorType (QueueRec, Int))
+  deleteQueueSize ms q = runExceptT $ do
+    size <- getQueueSize ms q
+    qr <- ExceptT $ deleteStoreQueue (queueStore_ ms) q
+    pure (qr, size)
+
+  getQueueMessages_ _ _ _ = error "getQueueMessages_ not used"
+
+  writeMsg :: PostgresMsgStore -> PostgresQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg ms q _ msg =
+    uninterruptibleMask_ $
+      withDB' "writeMsg" (queueStore_ ms) $ \db -> do
+        let (msgQuota, ntf, body) = case msg of
+              Message {msgFlags = MsgFlags ntf', msgBody = C.MaxLenBS body'} -> (False, ntf', body')
+              MessageQuota {} -> (True, False, B.empty)
+        toResult <$>
+          DB.query
+            db
+            "SELECT quota_written, was_empty FROM write_message(?,?,?,?,?,?,?)"
+            (recipientId' q, Binary (messageId msg), systemSeconds (messageTs msg), msgQuota, ntf, Binary body, quota)
+    where
+      toResult = \case
+        ((msgQuota, wasEmpty) : _) -> if msgQuota then Nothing else Just (msg, wasEmpty)
+        [] -> Nothing
+      PostgresMsgStore {config = PostgresMsgStoreCfg {quota}} = ms
+
+  setOverQuota_ :: PostgresQueue -> IO () -- can ONLY be used while restoring messages, not while server running
+  setOverQuota_ _ = error "TODO setOverQuota_" -- TODO [messages]
+
+  getQueueSize_ :: () -> DBStoreIO Int
+  getQueueSize_ _ = error "getQueueSize_ not used"
+
+  getQueueSize :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO Int
+  getQueueSize ms q =
+    withDB' "getQueueSize" (queueStore_ ms) $ \db ->
+      maybeFirstRow' 0 fromOnly $
+        DB.query db "SELECT msg_queue_size FROM msg_queues WHERE recipient_id = ? AND deleted_at IS NULL" (Only (recipientId' q))
+
+  tryPeekMsg_ :: PostgresQueue -> () -> DBStoreIO (Maybe Message)
+  tryPeekMsg_ q _ = do
+    db <- asks dbConn
+    liftIO $ maybeFirstRow toMessage $
+      DB.query
+        db
+        [sql|
+          SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+          FROM messages
+          WHERE recipient_id = ?
+          ORDER BY message_id ASC LIMIT 1
+        |]
+        (Only (recipientId' q))
+
+  tryDeleteMsg_ :: PostgresQueue -> () -> Bool -> DBStoreIO ()
+  tryDeleteMsg_ _q _ _ = error "tryDeleteMsg_ not used" -- do
+
+  isolateQueue :: PostgresMsgStore -> PostgresQueue -> Text -> DBStoreIO a -> ExceptT ErrorType IO a
+  isolateQueue ms _q op a = uninterruptibleMask_ $ withDB' op (queueStore_ ms) $ runReaderT a . DBTransaction
+
+  unsafeRunStore _ _ _ = error "unsafeRunStore not used"
+
+  tryPeekMsg :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO (Maybe Message)
+  tryPeekMsg ms q = isolateQueue ms q "tryPeekMsg" $ tryPeekMsg_ q ()
+  {-# INLINE tryPeekMsg #-}
+
+  tryDelMsg :: PostgresMsgStore -> PostgresQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message)
+  tryDelMsg ms q msgId =
+    uninterruptibleMask_ $
+      withDB' "tryDelMsg" (queueStore_ ms) $ \db ->
+        maybeFirstRow toMessage $
+          DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_msg(?, ?)" (recipientId' q, Binary msgId)
+
+  tryDelPeekMsg :: PostgresMsgStore -> PostgresQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
+  tryDelPeekMsg ms q msgId =
+    uninterruptibleMask_ $
+      withDB' "tryDelPeekMsg" (queueStore_ ms) $ \db ->
+        toResult . map toMessage
+          <$> DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_peek_msg(?, ?)" (recipientId' q, Binary msgId)
+    where
+      toResult = \case
+        [] -> (Nothing, Nothing)
+        [msg]
+          | messageId msg == msgId -> (Just msg, Nothing)
+          | otherwise -> (Nothing, Just msg)
+        deleted : next : _ -> (Just deleted, Just next)
+
+  deleteExpiredMsgs :: PostgresMsgStore -> PostgresQueue -> Int64 -> ExceptT ErrorType IO Int
+  deleteExpiredMsgs ms q old =
+    uninterruptibleMask_ $
+      maybeFirstRow' 0 (fromIntegral @Int64 . fromOnly) $ withDB' "deleteExpiredMsgs" (queueStore_ ms) $ \db ->
+        DB.query db "SELECT delete_expired_msgs(?, ?)" (recipientId' q, old)
+
+uninterruptibleMask_ :: ExceptT ErrorType IO a -> ExceptT ErrorType IO a
+uninterruptibleMask_ = ExceptT . E.uninterruptibleMask_ . runExceptT
+{-# INLINE uninterruptibleMask_ #-}
+
+toMessage :: (Binary MsgId, Int64, Bool, Bool, Binary MsgBody) -> Message
+toMessage (Binary msgId, ts, msgQuota, ntf, Binary body)
+  | msgQuota = MessageQuota {msgId, msgTs}
+  | otherwise = Message {msgId, msgTs, msgFlags = MsgFlags ntf, msgBody = C.unsafeMaxLenBS body} -- TODO [messages] unsafeMaxLenBS?
+  where
+    msgTs = MkSystemTime ts 0
+
+exportDbMessages :: Bool -> PostgresMsgStore -> Handle -> IO Int
+exportDbMessages tty ms h = do
+  rows <- newIORef []
+  n <- withConnection st $ \db -> DB.foldWithOptions_ opts db query 0 $ \i r -> do
+    let i' = i + 1
+    if i' `mod` 1000 > 0
+      then modifyIORef rows (r :)
+      else do
+        readIORef rows >>= writeMessages . (r :)
+        writeIORef rows []
+        when tty $ putStr (progress i' <> "\r") >> hFlush stdout
+    pure i'
+  readIORef rows >>= \rs -> unless (null rs) $ writeMessages rs
+  when tty $ putStrLn $ progress n
+  pure n
+  where
+    st = dbStore $ queueStore_ ms
+    opts = DB.defaultFoldOptions {DB.fetchQuantity = DB.Fixed 1000}
+    query =
+      [sql|
+        SELECT recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+        FROM messages
+        ORDER BY recipient_id, message_id ASC
+      |]
+    writeMessages = BB.hPutBuilder h . encodeMessages . reverse
+    encodeMessages = mconcat . map (\(Only rId :. msg) -> BB.byteString (strEncode $ MLRv3 rId $ toMessage msg) <> BB.char8 '\n')
+    progress i = "Processed: " <> show i <> " records"
+
+getDbMessageStats :: PostgresMsgStore -> IO MessageStats
+getDbMessageStats ms =
+  maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db ->
+    DB.query_
+      db
+      [sql|
+        SELECT
+          (SELECT COUNT (1) FROM msg_queues WHERE deleted_at IS NULL),
+          (SELECT COUNT (1) FROM messages m JOIN msg_queues q USING recipient_id WHERE deleted_at IS NULL)
+      |]
+  where
+    st = dbStore $ queueStore_ ms
+    toMessageStats (storedQueues, storedMsgsCount) =
+      MessageStats {storedQueues, storedMsgsCount, expiredMsgsCount = 0}
+
+getDbMessageCount :: PostgresMsgStore -> IO Int64
+getDbMessageCount ms =
+  maybeFirstRow' 0 fromOnly $
+    withConnection (dbStore $ queueStore_ ms) (`DB.query_` "SELECT COUNT(*) FROM messages")
+
+deleteAllMessages :: PostgresMsgStore -> IO ()
+deleteAllMessages ms =
+  withConnection (dbStore $ queueStore_ ms) $ \db -> do
+    void $ DB.execute_ db "TRUNCATE messages"
+    void $ DB.execute_
+      db
+      [sql|
+        UPDATE msg_queues
+        SET msg_queue_size = 0, msg_can_write = TRUE, msg_queue_expire = FALSE
+        WHERE msg_queue_size != 0 OR msg_can_write = FALSE OR msg_queue_expire = TRUE
+      |]
+
+updateQueueCounts :: PostgresMsgStore -> IO ()
+updateQueueCounts ms =
+  withConnection (dbStore $ queueStore_ ms) $ \db -> do
+    void $ DB.execute_
+      db
+      [sql|
+        CREATE TEMP TABLE queue_stats AS
+        SELECT recipient_id,
+          COUNT(*) AS size,
+          SUM(CASE WHEN msg_quota THEN 1 ELSE 0 END) AS quota_count
+        FROM messages
+        GROUP BY recipient_id
+      |]
+    void $ DB.execute_
+      db
+      [sql|
+        UPDATE msg_queues
+        SET msg_queue_size = 0, msg_can_write = TRUE, msg_queue_expire = FALSE
+        WHERE msg_queue_size != 0 OR msg_can_write = FALSE OR msg_queue_expire = TRUE
+      |]
+    void $ DB.execute_
+      db
+      [sql|
+        UPDATE msg_queues q
+        SET msg_queue_size = s.size,
+            msg_can_write = s.quota_count = 0,
+            msg_queue_expire = s.size > s.quota_count
+        FROM queue_stats s
+        WHERE q.recipient_id = s.recipient_id
+      |]
+    void $ DB.execute_ db "DROP TABLE queue_stats"
+
+batchInsertMessages :: StoreQueueClass q => Bool -> FilePath -> PostgresQueueStore q -> IO Int64
+batchInsertMessages tty f toStore = do
+  putStrLn "Importing messages..."
+  let st = dbStore toStore
+  (_, inserted) <-
+    withTransaction st $ \db -> do
+      DB.copy_
+        db
+        [sql|
+          COPY messages (recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
+          FROM STDIN WITH (FORMAT CSV)
+        |]
+      foldLogLines tty f (putMessage db) (0 :: Int, 0) >>= (DB.putCopyEnd db $>)
+  pure inserted
+  where
+    putMessage db (!i, !cnt) _eof s  = do
+      let i' = i + 1
+      cnt' <- case strDecode s of
+        Right (MLRv3 rId msg) -> (cnt + 1) <$ DB.putCopyData db (messageRecToText rId msg)
+        Left e -> cnt <$ putStrLn ("Error parsing line " <> show i' <> ": " <> e)
+      pure (i', cnt')
+
+messageRecToText :: RecipientId -> Message -> B.ByteString
+messageRecToText rId msg =
+  LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
+  where
+    tabFields = BB.char7 ',' `intersperse` fields
+    fields =
+      [ renderField (toField rId),
+        renderField (toField $ Binary (messageId msg)),
+        renderField (toField $ systemSeconds (messageTs msg)),
+        renderField (toField msgQuota),
+        renderField (toField ntf),
+        renderField (toField $ Binary body)
+      ]
+    (msgQuota, ntf, body) = case msg of
+      Message {msgFlags = MsgFlags ntf', msgBody = C.MaxLenBS body'} -> (False, ntf', body')
+      MessageQuota {} -> (True, False, B.empty)

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

@@ -57,18 +57,16 @@ data STMStoreConfig = STMStoreConfig
   }
 
 instance StoreQueueClass STMQueue where
-  type MsgQueue STMQueue = STMMsgQueue
   recipientId = recipientId'
   {-# INLINE recipientId #-}
   queueRec = queueRec'
   {-# INLINE queueRec #-}
-  msgQueue = msgQueue'
-  {-# INLINE msgQueue #-}
   withQueueLock _ _ = id
   {-# INLINE withQueueLock #-}
 
 instance MsgStoreClass STMMsgStore where
   type StoreMonad STMMsgStore = STM
+  type MsgQueue STMMsgStore = STMMsgQueue
   type QueueStore STMMsgStore = STMQueueStore STMQueue
   type StoreQueue STMMsgStore = STMQueue
   type MsgStoreConfig STMMsgStore = STMStoreConfig
@@ -82,7 +80,7 @@ instance MsgStoreClass STMMsgStore where
   {-# INLINE closeMsgStore #-}
   withActiveMsgQueues = withLoadedQueues . queueStore_
   {-# INLINE withActiveMsgQueues #-}
-  unsafeWithAllMsgQueues _ _ = withLoadedQueues . queueStore_
+  unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
   {-# INLINE unsafeWithAllMsgQueues #-}
 
   expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
@@ -129,10 +127,10 @@ instance MsgStoreClass STMMsgStore where
     Nothing -> pure (Nothing, 0)
 
   deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
-  deleteQueue ms q = fst <$$> deleteStoreQueue (queueStore_ ms) q
+  deleteQueue ms q = fst <$$> deleteQueue_ ms q
 
   deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
-  deleteQueueSize ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM (traverse getSize)
+  deleteQueueSize ms q = deleteQueue_ ms q >>= mapM (traverse getSize)
     -- traverse operates on the second tuple element
     where
       getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
@@ -179,10 +177,15 @@ instance MsgStoreClass STMMsgStore where
       Just _ -> modifyTVar' size (subtract 1)
       _ -> pure ()
 
-  isolateQueue :: STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
-  isolateQueue _ _ = liftIO . atomically
+  isolateQueue :: STMMsgStore -> STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
+  isolateQueue _ _ _ = liftIO . atomically
   {-# INLINE isolateQueue #-}
 
   unsafeRunStore :: STMQueue -> Text -> STM a -> IO a
   unsafeRunStore _ _ = atomically
   {-# INLINE unsafeRunStore #-}
+
+deleteQueue_ :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Maybe STMMsgQueue))
+deleteQueue_ ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM remove
+  where
+    remove qr = (qr,) <$> atomically (swapTVar (msgQueue' q) Nothing)

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

@@ -34,14 +34,15 @@ import Simplex.Messaging.Util ((<$$>), ($>>=))
 class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where
   type StoreMonad s = (m :: Type -> Type) | m -> s
   type MsgStoreConfig s = c | c -> s
+  type MsgQueue s = q | q -> s
   type StoreQueue s = q | q -> s
   type QueueStore s = qs | qs -> s
   newMsgStore :: MsgStoreConfig s -> IO s
   closeMsgStore :: s -> IO ()
   withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
   -- This function can only be used in server CLI commands or before server is started.
-  -- tty, withData, store
-  unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> s -> (StoreQueue s -> IO a) -> IO a
+  -- tty, store
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
   -- tty, store, now, ttl
   expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
   logQueueStates :: s -> IO ()
@@ -51,29 +52,62 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M
 
   -- message store methods
   mkQueue :: s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s)
-  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s))
-  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue s), Message))
+  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
+  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
 
   -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
-  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue (StoreQueue s) -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
+  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
   deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
   deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
-  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s [Message]
+  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message]
   writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
   setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
-  getQueueSize_ :: MsgQueue (StoreQueue s) -> StoreMonad s Int
-  tryPeekMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s (Maybe Message)
-  tryDeleteMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> Bool -> StoreMonad s ()
-  isolateQueue :: StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a
+  getQueueSize_ :: MsgQueue s -> StoreMonad s Int
+  tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
+  tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
+  isolateQueue :: s -> StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a
   unsafeRunStore :: StoreQueue s -> Text -> StoreMonad s a -> IO a
 
-data MSType = MSMemory | MSJournal
+  -- default implementations are overridden for PostgreSQL storage of messages
+  tryPeekMsg :: s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
+  tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
+  {-# INLINE tryPeekMsg #-}
+
+  tryDelMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
+  tryDelMsg st q msgId' =
+    withPeekMsgQueue st q "tryDelMsg" $
+      maybe (pure Nothing) $ \(mq, msg) ->
+        if
+          | messageId msg == msgId' ->
+              tryDeleteMsg_ q mq True $> Just msg
+          | otherwise -> pure Nothing
+
+  -- atomic delete (== read) last and peek next message if available
+  tryDelPeekMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
+  tryDelPeekMsg st q msgId' =
+    withPeekMsgQueue st q "tryDelPeekMsg" $
+      maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
+        if
+          | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
+          | otherwise -> pure (Nothing, Just msg)
+
+  deleteExpiredMsgs :: s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
+  deleteExpiredMsgs st q old =
+    isolateQueue st q "deleteExpiredMsgs" $
+      getMsgQueue st q False >>= deleteExpireMsgs_ old q
+
+  getQueueSize :: s -> StoreQueue s -> ExceptT ErrorType IO Int
+  getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
+  {-# INLINE getQueueSize #-}
+
+data MSType = MSMemory | MSJournal | MSPostgres
 
 data QSType = QSMemory | QSPostgres
 
 data SMSType :: MSType -> Type where
   SMSMemory :: SMSType 'MSMemory
   SMSJournal :: SMSType 'MSJournal
+  SMSPostgres :: SMSType 'MSPostgres
 
 data SQSType :: QSType -> Type where
   SQSMemory :: SQSType 'QSMemory
@@ -84,6 +118,7 @@ data MessageStats = MessageStats
     expiredMsgsCount :: Int,
     storedQueues :: Int
   }
+  deriving (Show)
 
 instance Monoid MessageStats where
   mempty = MessageStats 0 0 0
@@ -126,48 +161,19 @@ readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec))
 readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)
 {-# INLINE readQueueRec #-}
 
-getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int
-getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
-{-# INLINE getQueueSize #-}
-
-tryPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
-tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
-{-# INLINE tryPeekMsg #-}
-
-tryDelMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
-tryDelMsg st q msgId' =
-  withPeekMsgQueue st q "tryDelMsg" $
-    maybe (pure Nothing) $ \(mq, msg) ->
-      if
-        | messageId msg == msgId' ->
-            tryDeleteMsg_ q mq True $> Just msg
-        | otherwise -> pure Nothing
-
--- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
-tryDelPeekMsg st q msgId' =
-  withPeekMsgQueue st q "tryDelPeekMsg" $
-    maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
-      if
-        | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
-        | otherwise -> pure (Nothing, Just msg)
-
 -- The action is called with Nothing when it is known that the queue is empty
-withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
-withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a
+withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
+withPeekMsgQueue st q op a = isolateQueue st q op $ getPeekMsgQueue st q >>= a
 {-# INLINE withPeekMsgQueue #-}
 
-deleteExpiredMsgs :: MsgStoreClass s => s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
-deleteExpiredMsgs st q old =
-  isolateQueue q "deleteExpiredMsgs" $
-    getMsgQueue st q False >>= deleteExpireMsgs_ old q
-
+-- not used with PostgreSQL message store
 expireQueueMsgs :: MsgStoreClass s => s -> Int64 -> Int64 -> StoreQueue s -> StoreMonad s MessageStats
 expireQueueMsgs st now old q = do
   (expired_, stored) <- withIdleMsgQueue now st q $ deleteExpireMsgs_ old q
   pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1}
 
-deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int
+-- not used with PostgreSQL message store
+deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
 deleteExpireMsgs_ old q mq = do
   n <- loop 0
   logQueueState q

src/Simplex/Messaging/Server/Prometheus.hs

@@ -82,6 +82,7 @@ prometheusMetrics sm rtm ts =
         _qSubEnd,
         _qSubEndB,
         _ntfCreated,
+        _ntfNewCreated,
         _ntfDeleted,
         _ntfDeletedB,
         _ntfSub,
@@ -262,15 +263,19 @@ prometheusMetrics sm rtm ts =
       \simplex_smp_messages_notify_get_errors{type=\"duplicate\"} " <> mshow _msgGetDuplicate <> "\n# msgGetDuplicate\n\
       \simplex_smp_messages_notify_get_errors{type=\"prohibited\"} " <> mshow _msgGetProhibited <> "\n# msgGetProhibited\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_created Created queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_created counter\n\
       \simplex_smp_queues_notify_created " <> mshow _ntfCreated <> "\n# ntfCreated\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_new_created Created new queues with notification credentials.\n\
+      \# TYPE simplex_smp_queues_notify_new_created counter\n\
+      \simplex_smp_queues_notify_new_created " <> mshow _ntfNewCreated <> "\n# ntfNewCreated\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_deleted Deleted queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_deleted counter\n\
       \simplex_smp_queues_notify_deleted " <> mshow _ntfDeleted <> "\n# ntfDeleted\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_deleted_batch counter\n\
       \simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\
       \\n\

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

@@ -25,9 +25,13 @@ module Simplex.Messaging.Server.QueueStore.Postgres
     batchInsertQueues,
     foldServiceRecs,
     foldQueueRecs,
+    foldRecentQueueRecs,
     handleDuplicate,
     withLog_,
+    withDB,
     withDB',
+    assertUpdated,
+    renderField,
   )
 where
 
@@ -43,16 +47,16 @@ import qualified Data.ByteString.Builder as BB
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy as LB
 import Data.Bitraversable (bimapM)
-import Data.Either (fromRight, lefts, rights)
+import Data.Either (fromRight, lefts)
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (foldl', intersperse, partition)
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
@@ -64,12 +68,13 @@ import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))
 import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import GHC.IO (catchAny)
-import Simplex.Messaging.Agent.Client (withLockMap, withLocksMap)
+import Simplex.Messaging.Agent.Client (withLockMap)
 import Simplex.Messaging.Agent.Lock (Lock)
 import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
-import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
@@ -83,14 +88,12 @@ import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPServiceRole (..))
-import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>), ($>>=))
+import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, maybeFirstRow', tshow, (<$$>))
 import System.Exit (exitFailure)
 import System.IO (IOMode (..), hFlush, stdout)
 import UnliftIO.STM
 
 #if !defined(dbPostgres)
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
 import Simplex.Messaging.Encoding.String
 #endif
 
@@ -106,15 +109,18 @@ data PostgresQueueStore q = PostgresQueueStore
     notifiers :: TMap NotifierId RecipientId,
     notifierLocks :: TMap NotifierId Lock,
     serviceLocks :: TMap CertFingerprint Lock,
-    deletedTTL :: Int64
+    deletedTTL :: Int64,
+    useCache :: Bool
   }
 
-instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
-  type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
+type UseQueueCache = Bool
 
-  newQueueStore :: PostgresStoreCfg  -> IO (PostgresQueueStore q)
-  newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
+instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
+  type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache)
+
+  newQueueStore :: (PostgresStoreCfg, UseQueueCache)  -> IO (PostgresQueueStore q)
+  newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
     dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
     queues <- TM.emptyIO
     senders <- TM.emptyIO
@@ -122,7 +128,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     notifiers <- TM.emptyIO
     notifierLocks <- TM.emptyIO
     serviceLocks <- TM.emptyIO
-    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL}
+    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache}
     where
       err e = do
         logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -144,7 +150,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
 
   getEntityCounts :: PostgresQueueStore q -> IO EntityCounts
   getEntityCounts st =
-    withConnection (dbStore st) $ \db -> do
+    withTransaction (dbStore st) $ \db -> do
       (queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount) : _ <-
         DB.query
           db
@@ -169,28 +175,35 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       void $ withDB "addQueue_" st $ \db ->
         E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr))
           >>= bimapM handleDuplicate pure
-      atomically $ TM.insert rId sq queues
-      atomically $ TM.insert (senderId qr) rId senders
-      forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
-      forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
+      when useCache $ do
+        atomically $ TM.insert rId sq queues
+        atomically $ TM.insert (senderId qr) rId senders
+        forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
+        forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
       withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
       pure sq
     where
-      PostgresQueueStore {queues, senders, links, notifiers} = st
+      PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
       -- Not doing duplicate checks in maps as the probability of duplicates is very low.
       -- It needs to be reconsidered when IDs are supplied by the users.
       -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
       -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
 
   getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
-  getQueue_ st mkQ party qId = case party of
-    SRecipient -> getRcvQueue qId
-    SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
-    SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
-    -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
-    SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
+  getQueue_ st mkQ party qId
+    | useCache = case party of
+        SRecipient -> getRcvQueue qId
+        SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
+        SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
+        -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
+        SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
+    | otherwise = case party of
+        SRecipient -> loadQueueNoCache " WHERE recipient_id = ?"
+        SSender -> loadQueueNoCache " WHERE sender_id = ?"
+        SSenderLink -> loadQueueNoCache " WHERE link_id = ?"
+        SNotifier -> loadQueueNoCache " WHERE notifier_id = ?"
     where
-      PostgresQueueStore {queues, senders, links, notifiers} = st
+      PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
       getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
       loadRcvQueue = do
         (rId, qRec) <- loadQueue " WHERE recipient_id = ?"
@@ -207,6 +220,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
         liftIO $
           TM.lookupIO rId queues -- checking recipient map first
             >>= maybe (cacheQueue rId qRec cacheSender) (atomically (cacheSender rId) $>)
+      loadQueueNoCache cond = mask $ loadQueue cond >>= liftIO . uncurry (mkQ True)
       mask = E.uninterruptibleMask_ . runExceptT
       cacheSender rId = TM.insert qId rId senders
       loadQueue condition =
@@ -229,20 +243,27 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
               pure sq
 
   getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
-  getQueues_ st mkQ party qIds = case party of
-    SRecipient -> do
-      qs <- readTVarIO queues
-      let qs' = map (\qId -> get qs qId qId) qIds
-      E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
-    SNotifier -> do
-      ns <- readTVarIO notifiers
-      qs <- readTVarIO queues
-      let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
-      E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
-        forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
-          (nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
+  getQueues_ st mkQ party qIds
+    | null qIds = pure []
+    | useCache = case party of
+        SRecipient -> do
+          qs <- readTVarIO queues
+          let qs' = map (\qId -> get qs qId qId) qIds
+          E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
+        SNotifier -> do
+          ns <- readTVarIO notifiers
+          qs <- readTVarIO queues
+          let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
+          E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
+            forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
+              (nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
+    | otherwise = E.uninterruptibleMask_ $ case party of
+        SRecipient -> loadQueuesNoCache " WHERE recipient_id IN ?" $ \(rId, qRec) ->
+          Just . (rId,) <$> mkQ False rId qRec
+        SNotifier -> loadQueuesNoCache " WHERE notifier_id IN ?" $ \(rId, qRec) ->
+          forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ False rId qRec
     where
-      PostgresQueueStore {queues, notifiers} = st
+      PostgresQueueStore {queues, notifiers, useCache} = st
       get :: M.Map QueueId a -> QueueId -> QueueId -> Either QueueId a
       get m qId = maybe (Left qId) Right . (`M.lookup` m)
       loadQueues :: [Either QueueId q] -> Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q]
@@ -251,15 +272,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
         if null qIds'
           then pure $ map (first (const INTERNAL)) qs'
           else do
-            qs_ <-
-              runExceptT $ fmap M.fromList $
-                withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
-                  >>= liftIO . fmap catMaybes . mapM (mkCacheQueue . rowToQueueRec)
+            qs_ <- dbLoadQueues qIds' cond mkCacheQueue
             pure $ map (result qs_) qs'
         where
           result :: Either ErrorType (M.Map QueueId q) -> Either QueueId q -> Either ErrorType q
           result _ (Right q) = Right q
           result qs_ (Left qId) = maybe (Left AUTH) Right . M.lookup qId =<< qs_
+      dbLoadQueues qIds' cond mkQueue' =
+        runExceptT $ fmap M.fromList $
+          withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
+            >>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec)
       cacheRcvQueue (rId, qRec) = do
         sq <- mkQ True rId qRec
         sq' <- withQueueLock sq "getQueue_" $ atomically $
@@ -268,6 +290,12 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
             Just sq' -> pure sq'
             Nothing -> sq <$ TM.insert rId sq queues
         pure $ Just (rId, sq')
+      loadQueuesNoCache cond mkQueue' = do
+        qs_ <- dbLoadQueues qIds cond mkQueue'
+        pure $ map (result qs_) qIds
+        where
+          result :: Either ErrorType (M.Map QueueId q) -> QueueId -> Either ErrorType q
+          result qs_ qId = maybe (Left AUTH) Right . M.lookup qId =<< qs_
 
   getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
   getQueueLinkData st sq lnkId = runExceptT $ do
@@ -333,19 +361,23 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
   addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
     withQueueRec sq "addQueueNotifier" $ \q ->
-      ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
-        ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do
-          assertUpdated $ withDB "addQueueNotifier" st $ \db ->
-            E.try (update db) >>= bimapM handleDuplicate pure
-          nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
-          let !q' = q {notifier = Just ntfCreds}
-          atomically $ writeTVar (queueRec sq) $ Just q'
-          -- cache queue notifier ID – after notifier is added ntf server will likely subscribe
+      checkCachedNotifier $ do
+        assertUpdated $ withDB "addQueueNotifier" st $ \db ->
+          E.try (update db) >>= bimapM handleDuplicate pure
+        nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
+        let !q' = q {notifier = Just ntfCreds}
+        atomically $ writeTVar (queueRec sq) $ Just q'
+        when useCache $ do
           atomically $ TM.insert nId rId notifiers
-          withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
-          pure nc_
+        withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
+        pure nc_
     where
-      PostgresQueueStore {notifiers} = st
+      checkCachedNotifier add
+        | useCache =
+            ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
+              ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT add
+        | otherwise = add
+      PostgresQueueStore {notifiers, useCache} = st
       rId = recipientId sq
       update db =
         DB.execute
@@ -361,13 +393,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   deleteQueueNotifier st sq =
     withQueueRec sq "deleteQueueNotifier" $ \q ->
       ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
-        withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do
+        withNotifierLock nId $ runExceptT $ do
           assertUpdated $ withDB' "deleteQueueNotifier" st update
-          atomically $ TM.delete nId $ notifiers st
+          when (useCache st) $ atomically $ TM.delete nId $ notifiers st
           atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
           withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
           pure nc
     where
+      withNotifierLock nId
+        | useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier"
+        | otherwise = id
       rId = recipientId sq
       update db =
         DB.execute
@@ -410,20 +445,20 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       rId = recipientId sq
 
   -- this method is called from JournalMsgStore deleteQueue that already locks the queue
-  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType QueueRec)
   deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do
     q <- ExceptT $ readQueueRecIO qr
     RoundedSystemTime ts <- liftIO getSystemDate
     assertUpdated $ withDB' "deleteStoreQueue" st $ \db ->
       DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
     atomically $ writeTVar qr Nothing
-    atomically $ TM.delete (senderId q) $ senders st
-    forM_ (notifier q) $ \NtfCreds {notifierId} -> do
-      atomically $ TM.delete notifierId $ notifiers st
-      atomically $ TM.delete notifierId $ notifierLocks st
-    mq_ <- atomically $ swapTVar (msgQueue sq) Nothing
+    when (useCache st) $ do
+      atomically $ TM.delete (senderId q) $ senders st
+      forM_ (notifier q) $ \NtfCreds {notifierId} -> do
+        atomically $ TM.delete notifierId $ notifiers st
+        atomically $ TM.delete notifierId $ notifierLocks st
     withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
-    pure (q, mq_)
+    pure q
     where
       rId = recipientId sq
       qr = queueRec sq
@@ -486,15 +521,19 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
         let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
          in ((serviceId, sNtfs) : ssNtfs, restNtfs)
 
-  getNtfServiceQueueCount :: PostgresQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
-  getNtfServiceQueueCount st serviceId =
-    E.uninterruptibleMask_ $ runExceptT $ withDB' "getNtfServiceQueueCount" st $ \db ->
-      fmap (fromMaybe 0) $ maybeFirstRow fromOnly $
-        DB.query db "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL" (Only serviceId)
+  getServiceQueueCount :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
+  getServiceQueueCount st party serviceId =
+    E.uninterruptibleMask_ $ runExceptT $ withDB' "getServiceQueueCount" st $ \db ->
+      maybeFirstRow' 0 fromOnly $
+        DB.query db query (Only serviceId)
+    where
+      query = case party of
+        SRecipientService -> "SELECT count(1) FROM msg_queues WHERE rcv_service_id = ? AND deleted_at IS NULL"
+        SNotifierService -> "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL"
 
 batchInsertServices :: [STMService] -> PostgresQueueStore q -> IO Int64
 batchInsertServices services' toStore =
-  withConnection (dbStore toStore) $ \db ->
+  withTransaction (dbStore toStore) $ \db ->
     DB.executeMany db insertServiceQuery $ map (serviceRecToRow . serviceRec) services'
 
 batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO Int64
@@ -503,7 +542,7 @@ batchInsertQueues tty queues toStore = do
   putStrLn $ "Importing " <> show (length qs) <> " queues..."
   let st = dbStore toStore
   count <-
-    withConnection st $ \db -> do
+    withTransaction st $ \db -> do
       DB.copy_
         db
         [sql|
@@ -512,7 +551,7 @@ batchInsertQueues tty queues toStore = do
         |]
       mapM_ (putQueue db) (zip [1..] qs)
       DB.putCopyEnd db
-  Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues")
+  Only qCnt : _ <- withTransaction st (`DB.query_` "SELECT count(*) FROM msg_queues")
   putStrLn $ progress count
   pure qCnt
   where
@@ -539,13 +578,33 @@ insertServiceQuery =
 
 foldServiceRecs :: forall a q. Monoid a => PostgresQueueStore q -> (ServiceRec -> IO a) -> IO a
 foldServiceRecs st f =
-  withConnection (dbStore st) $ \db ->
+  withTransaction (dbStore st) $ \db ->
     DB.fold_ db "SELECT service_id, service_role, service_cert, service_cert_hash, created_at FROM services" mempty $
       \ !acc -> fmap (acc <>) . f . rowToServiceRec
 
-foldQueueRecs :: forall a q. Monoid a => Bool -> Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
-foldQueueRecs tty withData st skipOld_ f = do
-  (n, r) <- withConnection (dbStore st) $ \db ->
+foldQueueRecs :: Monoid a => Bool -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
+foldQueueRecs withData = foldQueueRecs_ foldRecs
+  where
+    foldRecs db acc f'
+      | withData = DB.fold_ db (queueRecQueryWithData <> cond) acc $ \acc' -> f' acc' . rowToQueueRecWithData
+      | otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec
+    cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC"
+
+foldRecentQueueRecs :: Monoid a => Int64 -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
+foldRecentQueueRecs old = foldQueueRecs_ foldRecs
+  where
+    foldRecs db acc f' = DB.fold db (queueRecQuery <> cond) (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
+    cond = " WHERE deleted_at IS NULL AND updated_at > ? ORDER BY recipient_id ASC"
+
+foldQueueRecs_ ::
+  Monoid a =>
+  (DB.Connection -> (Int, a) -> ((Int, a) -> (RecipientId, QueueRec) -> IO (Int, a)) -> IO (Int, a)) ->
+  Bool ->
+  PostgresQueueStore q ->
+  ((RecipientId, QueueRec) -> IO a) ->
+  IO a
+foldQueueRecs_ foldRecs tty st f = do
+  (n, r) <- withTransaction (dbStore st) $ \db ->
     foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
       r <- f qr
       let !i' = i + 1
@@ -555,13 +614,6 @@ foldQueueRecs tty withData st skipOld_ f = do
   when tty $ putStrLn $ progress n
   pure r
   where
-    foldRecs db acc f' = case skipOld_ of
-      Nothing
-        | withData -> DB.fold_ db (queueRecQueryWithData <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
-        | otherwise -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
-      Just old
-        | withData -> DB.fold db (queueRecQueryWithData <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
-        | otherwise -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
     progress i = "Processed: " <> show i <> " records"
 
 queueRecQuery :: Query
@@ -625,13 +677,14 @@ queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey,
     (linkId_, queueData_) = queueDataColumns queueData
     nullable :: ToField a => Maybe a -> Builder
     nullable = maybe mempty (renderField . toField)
-    renderField :: Action -> Builder
-    renderField = \case
-      Plain bld -> bld
-      Escape s -> BB.byteString s
-      EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s
-      EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
-      Many as -> mconcat (map renderField as)
+
+renderField :: Action -> Builder
+renderField = \case
+  Plain bld -> bld
+  Escape s -> BB.byteString s
+  EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s
+  EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
+  Many as -> mconcat (map renderField as)
 
 queueDataColumns :: Maybe (LinkId, QueueLinkData) -> (Maybe LinkId, Maybe QueueLinkData)
 queueDataColumns = \case
@@ -684,7 +737,7 @@ withDB' op st action = withDB op st $ fmap Right . action
 
 withDB :: forall a q. Text -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
 withDB op st action =
-  ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure
+  ExceptT $ E.try (withTransaction (dbStore st) action) >>= either logErr pure
   where
     logErr :: E.SomeException -> IO (Either ErrorType a)
     logErr e = logError ("STORE: " <> err) $> Left (STORE err)

src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs

@@ -14,7 +14,8 @@ serverSchemaMigrations =
   [ ("20250207_initial", m20250207_initial, Nothing),
     ("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index),
     ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links),
-    ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs)
+    ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs),
+    ("20250903_store_messages", m20250903_store_messages, Just down_m20250903_store_messages)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -159,3 +160,299 @@ DROP INDEX idx_services_service_role;
 
 DROP TABLE services;
     |]
+
+m20250903_store_messages :: Text
+m20250903_store_messages =
+  T.pack
+    [r|
+CREATE TABLE messages(
+  message_id BIGINT NOT NULL PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  recipient_id BYTEA NOT NULL REFERENCES msg_queues ON DELETE CASCADE ON UPDATE RESTRICT,
+  msg_id BYTEA NOT NULL,
+  msg_ts BIGINT NOT NULL,
+  msg_quota BOOLEAN NOT NULL,
+  msg_ntf_flag BOOLEAN NOT NULL,
+  msg_body BYTEA NOT NULL
+);
+
+ALTER TABLE msg_queues
+  ADD COLUMN msg_can_write BOOLEAN NOT NULL DEFAULT TRUE,
+  ADD COLUMN msg_queue_expire BOOLEAN NOT NULL DEFAULT FALSE,
+  ADD COLUMN msg_queue_size BIGINT NOT NULL DEFAULT 0;
+
+CREATE INDEX idx_messages_recipient_id_message_id ON messages (recipient_id, message_id);
+CREATE INDEX idx_messages_recipient_id_msg_ts on messages(recipient_id, msg_ts);
+CREATE INDEX idx_messages_recipient_id_msg_quota on messages(recipient_id, msg_quota);
+
+DROP INDEX idx_msg_queues_updated_at;
+CREATE INDEX idx_msg_queues_updated_at_recipient_id ON msg_queues (deleted_at, updated_at, msg_queue_expire, recipient_id);
+
+CREATE FUNCTION write_message(
+  p_recipient_id BYTEA,
+  p_msg_id BYTEA,
+  p_msg_ts BIGINT,
+  p_msg_quota BOOLEAN,
+  p_msg_ntf_flag BOOLEAN,
+  p_msg_body BYTEA,
+  p_quota INT
+)
+RETURNS TABLE (quota_written BOOLEAN, was_empty BOOLEAN)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_can_write BOOLEAN;
+  q_size BIGINT;
+BEGIN
+  SELECT msg_can_write, msg_queue_size INTO q_can_write, q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF q_can_write OR q_size = 0 THEN
+    quota_written := p_msg_quota OR q_size >= p_quota;
+    was_empty := q_size = 0;
+
+    INSERT INTO messages(recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
+    VALUES (p_recipient_id, p_msg_id, p_msg_ts, quota_written, p_msg_ntf_flag AND NOT quota_written, CASE WHEN quota_written THEN '' :: BYTEA ELSE p_msg_body END);
+
+    UPDATE msg_queues
+    SET msg_can_write = NOT quota_written,
+        msg_queue_expire = TRUE,
+        msg_queue_size = msg_queue_size + 1
+    WHERE recipient_id = p_recipient_id;
+
+    RETURN QUERY VALUES (quota_written, was_empty);
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION try_del_msg(p_recipient_id BYTEA, p_msg_id BYTEA)
+RETURNS TABLE (r_msg_id BYTEA, r_msg_ts BIGINT, r_msg_quota BOOLEAN, r_msg_ntf_flag BOOLEAN, r_msg_body BYTEA)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+    IF FOUND THEN
+      UPDATE msg_queues
+      SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+          msg_queue_expire = msg_queue_size > 1,
+          msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+      WHERE recipient_id = p_recipient_id;
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION try_del_peek_msg(p_recipient_id BYTEA, p_msg_id BYTEA)
+RETURNS TABLE (r_msg_id BYTEA, r_msg_ts BIGINT, r_msg_quota BOOLEAN, r_msg_ntf_flag BOOLEAN, r_msg_body BYTEA)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+  msg_deleted BOOLEAN;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+
+    msg_deleted := FOUND;
+    IF msg_deleted THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+
+    SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+    INTO msg
+    FROM messages
+    WHERE recipient_id = p_recipient_id
+    ORDER BY message_id ASC LIMIT 1;
+
+    IF FOUND THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+      IF msg_deleted THEN
+        UPDATE msg_queues
+        SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+            msg_queue_expire = msg_queue_size > 1,
+            msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+        WHERE recipient_id = p_recipient_id;
+      END IF;
+    ELSIF msg_deleted OR q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+  ELSE
+    RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION delete_expired_msgs(p_recipient_id BYTEA, p_old_ts BIGINT) RETURNS BIGINT
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  keep_min_id BIGINT;
+  del_count BIGINT;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE SKIP LOCKED;
+
+  IF NOT FOUND OR q_size = 0 THEN
+    RETURN 0;
+  END IF;
+
+  SELECT MIN(message_id) INTO keep_min_id
+  FROM messages WHERE recipient_id = p_recipient_id AND msg_ts >= p_old_ts AND msg_quota = FALSE;
+
+  IF keep_min_id IS NULL THEN
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND msg_quota = FALSE;
+  ELSE
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND message_id < keep_min_id AND msg_quota = FALSE;
+  END IF;
+
+  GET DIAGNOSTICS del_count = ROW_COUNT;
+  IF del_count > 0 THEN
+    UPDATE msg_queues
+    SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
+        msg_queue_expire = msg_queue_size > del_count AND keep_min_id IS NOT NULL,
+        msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
+    WHERE recipient_id = p_recipient_id;
+  END IF;
+  RETURN del_count;
+END;
+$$;
+
+CREATE PROCEDURE expire_old_messages(
+  p_old_queue BIGINT,
+  p_old_ts BIGINT,
+  batch_size INT,
+  OUT r_expired_msgs_count BIGINT,
+  OUT r_stored_msgs_count BIGINT,
+  OUT r_stored_queues BIGINT
+)
+LANGUAGE plpgsql AS $$
+DECLARE
+  rids BYTEA[];
+  rid BYTEA;
+  last_rid BYTEA := '\x';
+  del_count BIGINT;
+  total_deleted BIGINT := 0;
+BEGIN
+  LOOP
+    SELECT array_agg(recipient_id)
+    INTO rids
+    FROM (
+      SELECT recipient_id
+      FROM msg_queues
+      WHERE deleted_at IS NULL
+        AND updated_at > p_old_queue
+        AND msg_queue_expire = TRUE
+        AND recipient_id > last_rid
+      ORDER BY recipient_id ASC
+      LIMIT batch_size
+    ) qs;
+
+    EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
+
+    FOREACH rid IN ARRAY rids
+    LOOP
+      BEGIN
+        del_count := delete_expired_msgs(rid, p_old_ts);
+        total_deleted := total_deleted + del_count;
+      EXCEPTION WHEN OTHERS THEN
+        RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
+        CONTINUE;
+      END;
+      COMMIT;
+    END LOOP;
+    last_rid := rids[cardinality(rids)];
+  END LOOP;
+
+  r_expired_msgs_count := total_deleted;
+  r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
+  r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
+END;
+$$;
+    |]
+
+down_m20250903_store_messages :: Text
+down_m20250903_store_messages =
+  T.pack
+    [r|
+DROP FUNCTION write_message;
+DROP FUNCTION try_del_msg;
+DROP FUNCTION try_del_peek_msg;
+DROP FUNCTION delete_expired_msgs;
+DROP PROCEDURE expire_old_messages;
+
+DROP INDEX idx_msg_queues_updated_at_recipient_id;
+CREATE INDEX idx_msg_queues_updated_at ON msg_queues (deleted_at, updated_at);
+
+DROP INDEX idx_messages_recipient_id_message_id;
+DROP INDEX idx_messages_recipient_id_msg_ts;
+DROP INDEX idx_messages_recipient_id_msg_quota;
+
+ALTER TABLE msg_queues
+  DROP COLUMN msg_can_write,
+  DROP COLUMN msg_queue_expire,
+  DROP COLUMN msg_queue_size;
+
+DROP TABLE messages;
+    |]

src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql

@@ -15,9 +15,273 @@ SET row_security = off;
 CREATE SCHEMA smp_server;
 
 
+
+CREATE FUNCTION smp_server.delete_expired_msgs(p_recipient_id bytea, p_old_ts bigint) RETURNS bigint
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  q_size BIGINT;
+  keep_min_id BIGINT;
+  del_count BIGINT;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE SKIP LOCKED;
+
+  IF NOT FOUND OR q_size = 0 THEN
+    RETURN 0;
+  END IF;
+
+  SELECT MIN(message_id) INTO keep_min_id
+  FROM messages WHERE recipient_id = p_recipient_id AND msg_ts >= p_old_ts AND msg_quota = FALSE;
+
+  IF keep_min_id IS NULL THEN
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND msg_quota = FALSE;
+  ELSE
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND message_id < keep_min_id AND msg_quota = FALSE;
+  END IF;
+
+  GET DIAGNOSTICS del_count = ROW_COUNT;
+  IF del_count > 0 THEN
+    UPDATE msg_queues
+    SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
+        msg_queue_expire = msg_queue_size > del_count AND keep_min_id IS NOT NULL,
+        msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
+    WHERE recipient_id = p_recipient_id;
+  END IF;
+  RETURN del_count;
+END;
+$$;
+
+
+
+CREATE PROCEDURE smp_server.expire_old_messages(IN p_old_queue bigint, IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  rids BYTEA[];
+  rid BYTEA;
+  last_rid BYTEA := '\x';
+  del_count BIGINT;
+  total_deleted BIGINT := 0;
+BEGIN
+  LOOP
+    SELECT array_agg(recipient_id)
+    INTO rids
+    FROM (
+      SELECT recipient_id
+      FROM msg_queues
+      WHERE deleted_at IS NULL
+        AND updated_at > p_old_queue
+        AND msg_queue_expire = TRUE
+        AND recipient_id > last_rid
+      ORDER BY recipient_id ASC
+      LIMIT batch_size
+    ) qs;
+
+    EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
+
+    FOREACH rid IN ARRAY rids
+    LOOP
+      BEGIN
+        del_count := delete_expired_msgs(rid, p_old_ts);
+        total_deleted := total_deleted + del_count;
+      EXCEPTION WHEN OTHERS THEN
+        RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
+        CONTINUE;
+      END;
+      COMMIT;
+    END LOOP;
+    last_rid := rids[cardinality(rids)];
+  END LOOP;
+
+  r_expired_msgs_count := total_deleted;
+  r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
+  r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
+END;
+$$;
+
+
+
+CREATE FUNCTION smp_server.try_del_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+    IF FOUND THEN
+      UPDATE msg_queues
+      SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+          msg_queue_expire = msg_queue_size > 1,
+          msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+      WHERE recipient_id = p_recipient_id;
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+  END IF;
+END;
+$$;
+
+
+
+CREATE FUNCTION smp_server.try_del_peek_msg(p_recipient_id bytea, p_msg_id bytea) RETURNS TABLE(r_msg_id bytea, r_msg_ts bigint, r_msg_quota boolean, r_msg_ntf_flag boolean, r_msg_body bytea)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+  msg_deleted BOOLEAN;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+
+    msg_deleted := FOUND;
+    IF msg_deleted THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+
+    SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+    INTO msg
+    FROM messages
+    WHERE recipient_id = p_recipient_id
+    ORDER BY message_id ASC LIMIT 1;
+
+    IF FOUND THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+      IF msg_deleted THEN
+        UPDATE msg_queues
+        SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+            msg_queue_expire = msg_queue_size > 1,
+            msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+        WHERE recipient_id = p_recipient_id;
+      END IF;
+    ELSIF msg_deleted OR q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+  ELSE
+    RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+  END IF;
+END;
+$$;
+
+
+
+CREATE FUNCTION smp_server.write_message(p_recipient_id bytea, p_msg_id bytea, p_msg_ts bigint, p_msg_quota boolean, p_msg_ntf_flag boolean, p_msg_body bytea, p_quota integer) RETURNS TABLE(quota_written boolean, was_empty boolean)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  q_can_write BOOLEAN;
+  q_size BIGINT;
+BEGIN
+  SELECT msg_can_write, msg_queue_size INTO q_can_write, q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF q_can_write OR q_size = 0 THEN
+    quota_written := p_msg_quota OR q_size >= p_quota;
+    was_empty := q_size = 0;
+
+    INSERT INTO messages(recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
+    VALUES (p_recipient_id, p_msg_id, p_msg_ts, quota_written, p_msg_ntf_flag AND NOT quota_written, CASE WHEN quota_written THEN '' :: BYTEA ELSE p_msg_body END);
+
+    UPDATE msg_queues
+    SET msg_can_write = NOT quota_written,
+        msg_queue_expire = TRUE,
+        msg_queue_size = msg_queue_size + 1
+    WHERE recipient_id = p_recipient_id;
+
+    RETURN QUERY VALUES (quota_written, was_empty);
+  END IF;
+END;
+$$;
+
+
 SET default_table_access_method = heap;
 
 
+CREATE TABLE smp_server.messages (
+    message_id bigint NOT NULL,
+    recipient_id bytea NOT NULL,
+    msg_id bytea NOT NULL,
+    msg_ts bigint NOT NULL,
+    msg_quota boolean NOT NULL,
+    msg_ntf_flag boolean NOT NULL,
+    msg_body bytea NOT NULL
+);
+
+
+
+ALTER TABLE smp_server.messages ALTER COLUMN message_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME smp_server.messages_message_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
 CREATE TABLE smp_server.migrations (
     name text NOT NULL,
     ts timestamp without time zone NOT NULL,
@@ -43,7 +307,10 @@ CREATE TABLE smp_server.msg_queues (
     fixed_data bytea,
     user_data bytea,
     rcv_service_id bytea,
-    ntf_service_id bytea
+    ntf_service_id bytea,
+    msg_can_write boolean DEFAULT true NOT NULL,
+    msg_queue_expire boolean DEFAULT false NOT NULL,
+    msg_queue_size bigint DEFAULT 0 NOT NULL
 );
 
 
@@ -58,6 +325,11 @@ CREATE TABLE smp_server.services (
 
 
 
+ALTER TABLE ONLY smp_server.messages
+    ADD CONSTRAINT messages_pkey PRIMARY KEY (message_id);
+
+
+
 ALTER TABLE ONLY smp_server.migrations
     ADD CONSTRAINT migrations_pkey PRIMARY KEY (name);
 
@@ -78,6 +350,18 @@ ALTER TABLE ONLY smp_server.services
 
 
 
+CREATE INDEX idx_messages_recipient_id_message_id ON smp_server.messages USING btree (recipient_id, message_id);
+
+
+
+CREATE INDEX idx_messages_recipient_id_msg_quota ON smp_server.messages USING btree (recipient_id, msg_quota);
+
+
+
+CREATE INDEX idx_messages_recipient_id_msg_ts ON smp_server.messages USING btree (recipient_id, msg_ts);
+
+
+
 CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id);
 
 
@@ -98,7 +382,7 @@ CREATE UNIQUE INDEX idx_msg_queues_sender_id ON smp_server.msg_queues USING btre
 
 
 
-CREATE INDEX idx_msg_queues_updated_at ON smp_server.msg_queues USING btree (deleted_at, updated_at);
+CREATE INDEX idx_msg_queues_updated_at_recipient_id ON smp_server.msg_queues USING btree (deleted_at, updated_at, msg_queue_expire, recipient_id);
 
 
 
@@ -106,6 +390,11 @@ CREATE INDEX idx_services_service_role ON smp_server.services USING btree (servi
 
 
 
+ALTER TABLE ONLY smp_server.messages
+    ADD CONSTRAINT messages_recipient_id_fkey FOREIGN KEY (recipient_id) REFERENCES smp_server.msg_queues(recipient_id) ON UPDATE RESTRICT ON DELETE CASCADE;
+
+
+
 ALTER TABLE ONLY smp_server.msg_queues
     ADD CONSTRAINT msg_queues_ntf_service_id_fkey FOREIGN KEY (ntf_service_id) REFERENCES smp_server.services(service_id) ON UPDATE RESTRICT ON DELETE SET NULL;
 

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

@@ -114,7 +114,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
       serviceQueuesCount serviceSel = foldM (\n s -> (n +) . S.size <$> readTVarIO (serviceSel s)) 0
 
   addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
-  addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do
+  addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do
     sq <- mkQ rId qr
     add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
     where
@@ -122,8 +122,11 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
       add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do
         TM.insert rId q queues
         TM.insert sId rId senders
-        forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
+        forM_ notifier $ \NtfCreds {notifierId = nId, ntfServiceId} -> do
+          TM.insert nId rId notifiers
+          mapM_ (addServiceQueue st serviceNtfQueues nId) ntfServiceId
         forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links
+        mapM_ (addServiceQueue st serviceRcvQueues rId) rcvServiceId
       hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink]
       hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
       hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
@@ -225,7 +228,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
   deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
   deleteQueueNotifier st sq =
     withQueueRec qr delete
-      $>>= \nc_ -> nc_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq)
+      $>>= (<$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq))
     where
       qr = queueRec sq
       delete q = forM (notifier q) $ \nc -> do
@@ -261,11 +264,10 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
         | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId sq) t)
         | otherwise = pure $ Right q
 
-  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType QueueRec)
   deleteStoreQueue st sq =
     withQueueRec qr delete
-      $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
-      >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing))
+      $>>= (<$$ withLog "deleteStoreQueue" st (`logDeleteQueue` rId))
     where
       rId = recipientId sq
       qr = queueRec sq
@@ -346,10 +348,15 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
         let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
         pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs)
 
-  getNtfServiceQueueCount :: STMQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
-  getNtfServiceQueueCount st serviceId =
+  getServiceQueueCount :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
+  getServiceQueueCount st party serviceId =
     TM.lookupIO serviceId (services st) >>=
-      maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceNtfQueues)
+      maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceSel)
+    where
+      serviceSel :: STMService -> TVar (Set QueueId)
+      serviceSel = case party of
+        SRecipientService -> serviceRcvQueues
+        SNotifierService -> serviceNtfQueues
 
 withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
 withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a

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

@@ -17,10 +17,8 @@ import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.TMap (TMap)
 
 class StoreQueueClass q where
-  type MsgQueue q = mq | mq -> q
   recipientId :: q -> RecipientId
   queueRec :: q -> TVar (Maybe QueueRec)
-  msgQueue :: q -> TVar (Maybe (MsgQueue q))
   withQueueLock :: q -> Text -> IO a -> IO a
 
 class StoreQueueClass q => QueueStoreClass q s where
@@ -44,11 +42,11 @@ class StoreQueueClass q => QueueStoreClass q s where
   blockQueue :: s -> q -> BlockingInfo -> IO (Either ErrorType ())
   unblockQueue :: s -> q -> IO (Either ErrorType ())
   updateQueueTime :: s -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
-  deleteStoreQueue :: s -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue :: s -> q -> IO (Either ErrorType QueueRec)
   getCreateService :: s -> ServiceRec -> IO (Either ErrorType ServiceId)
   setQueueService :: (PartyI p, ServiceParty p) => s -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
   getQueueNtfServices :: s -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
-  getNtfServiceQueueCount :: s -> ServiceId -> IO (Either ErrorType Int64)
+  getServiceQueueCount :: (PartyI p, ServiceParty p) => s -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
 
 data EntityCounts = EntityCounts
   { queueCount :: Int,

src/Simplex/Messaging/Server/Stats.hs

@@ -48,6 +48,7 @@ data ServerStats = ServerStats
     qSubEnd :: IORef Int,
     qSubEndB :: IORef Int,
     ntfCreated :: IORef Int,
+    ntfNewCreated :: IORef Int, -- credentials created at the time of queue creation
     ntfDeleted :: IORef Int,
     ntfDeletedB :: IORef Int,
     ntfSub :: IORef Int,
@@ -107,6 +108,7 @@ data ServerStatsData = ServerStatsData
     _qSubEnd :: Int,
     _qSubEndB :: Int,
     _ntfCreated :: Int,
+    _ntfNewCreated :: Int,
     _ntfDeleted :: Int,
     _ntfDeletedB :: Int,
     _ntfSub :: Int,
@@ -167,6 +169,7 @@ newServerStats ts = do
   qSubEnd <- newIORef 0
   qSubEndB <- newIORef 0
   ntfCreated <- newIORef 0
+  ntfNewCreated <- newIORef 0
   ntfDeleted <- newIORef 0
   ntfDeletedB <- newIORef 0
   ntfSub <- newIORef 0
@@ -224,6 +227,7 @@ newServerStats ts = do
         qSubEnd,
         qSubEndB,
         ntfCreated,
+        ntfNewCreated,
         ntfDeleted,
         ntfDeletedB,
         ntfSub,
@@ -283,6 +287,7 @@ getServerStatsData s = do
   _qSubEnd <- readIORef $ qSubEnd s
   _qSubEndB <- readIORef $ qSubEndB s
   _ntfCreated <- readIORef $ ntfCreated s
+  _ntfNewCreated <- readIORef $ ntfNewCreated s
   _ntfDeleted <- readIORef $ ntfDeleted s
   _ntfDeletedB <- readIORef $ ntfDeletedB s
   _ntfSub <- readIORef $ ntfSub s
@@ -340,6 +345,7 @@ getServerStatsData s = do
         _qSubEnd,
         _qSubEndB,
         _ntfCreated,
+        _ntfNewCreated,
         _ntfDeleted,
         _ntfDeletedB,
         _ntfSub,
@@ -400,6 +406,7 @@ setServerStats s d = do
   writeIORef (qSubEnd s) $! _qSubEnd d
   writeIORef (qSubEndB s) $! _qSubEndB d
   writeIORef (ntfCreated s) $! _ntfCreated d
+  writeIORef (ntfNewCreated s) $! _ntfNewCreated d
   writeIORef (ntfDeleted s) $! _ntfDeleted d
   writeIORef (ntfDeletedB s) $! _ntfDeletedB d
   writeIORef (ntfSub s) $! _ntfSub d
@@ -460,6 +467,7 @@ instance StrEncoding ServerStatsData where
         "qSubEnd=" <> strEncode (_qSubEnd d),
         "qSubEndB=" <> strEncode (_qSubEndB d),
         "ntfCreated=" <> strEncode (_ntfCreated d),
+        "ntfNewCreated=" <> strEncode (_ntfNewCreated d),
         "ntfDeleted=" <> strEncode (_ntfDeleted d),
         "ntfDeletedB=" <> strEncode (_ntfDeletedB d),
         "ntfSub=" <> strEncode (_ntfSub d),
@@ -523,6 +531,7 @@ instance StrEncoding ServerStatsData where
     _qSubEnd <- opt "qSubEnd="
     _qSubEndB <- opt "qSubEndB="
     _ntfCreated <- opt "ntfCreated="
+    _ntfNewCreated <- opt "ntfNewCreated="
     _ntfDeleted <- opt "ntfDeleted="
     _ntfDeletedB <- opt "ntfDeletedB="
     _ntfSub <- opt "ntfSub="
@@ -590,6 +599,7 @@ instance StrEncoding ServerStatsData where
           _qSubEnd,
           _qSubEndB,
           _ntfCreated,
+          _ntfNewCreated,
           _ntfDeleted,
           _ntfDeletedB,
           _ntfSub,

src/Simplex/Messaging/Transport.hs

@@ -54,6 +54,7 @@ module Simplex.Messaging.Transport
     blockedEntitySMPVersion,
     shortLinksSMPVersion,
     serviceCertsSMPVersion,
+    newNtfCredsSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -131,6 +132,7 @@ import GHC.IO.Handle.Internals (ioe_EOF)
 import Network.Socket
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
+import qualified Network.TLS.Internal as TI
 import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -166,6 +168,7 @@ smpBlockSize = 16384
 -- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
 -- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
 -- 16 - service certificates (5/31/2025)
+-- 17 - create notification credentials with NEW (7/12/2025)
 
 data SMPVersion
 
@@ -208,6 +211,9 @@ shortLinksSMPVersion = VersionSMP 15
 serviceCertsSMPVersion :: VersionSMP
 serviceCertsSMPVersion = VersionSMP 16
 
+newNtfCredsSMPVersion :: VersionSMP
+newNtfCredsSMPVersion = VersionSMP 17
+
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 6
 
@@ -215,13 +221,13 @@ minServerSMPRelayVersion :: VersionSMP
 minServerSMPRelayVersion = VersionSMP 6
 
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 16
+currentClientSMPRelayVersion = VersionSMP 17
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 16
+currentServerSMPRelayVersion = VersionSMP 17
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -229,7 +235,7 @@ currentServerSMPRelayVersion = VersionSMP 16
 -- to prevent client version fingerprinting by the
 -- destination relays when clients upgrade at different times.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 15
+proxiedSMPRelayVersion = VersionSMP 16
 
 -- minimal supported protocol version is 6
 -- TODO remove code that supports sending commands without batching
@@ -364,7 +370,7 @@ getTLS cfg tlsCertSent tlsPeerCert cxt = withTlsUnique @TLS @p cxt newTLS
 withTlsUnique :: forall c p. TransportPeerI p => T.Context -> (ByteString -> IO (c p)) -> IO (c p)
 withTlsUnique cxt f =
   cxtFinished cxt
-    >>= maybe (closeTLS cxt >> ioe_EOF) f
+    >>= maybe (closeTLS cxt >> ioe_EOF) (\(TI.VerifyData d) -> f d)
   where
     cxtFinished = case sTransportPeer @p of
       STServer -> T.getPeerFinished

src/Simplex/Messaging/Transport/Client.hs

@@ -30,12 +30,14 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Logger.Simple (logError)
+import Control.Monad
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAsciiLower, isDigit, isHexDigit)
 import Data.Default (def)
+import Data.Functor (($>))
 import Data.IORef
 import Data.IP
 import Data.List.NonEmpty (NonEmpty (..))
@@ -58,7 +60,7 @@ import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.Shared
-import Simplex.Messaging.Util (bshow, catchAll, tshow, (<$?>))
+import Simplex.Messaging.Util (bshow, catchAll, catchAll_, tshow, (<$?>))
 import System.IO.Error
 import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
@@ -156,6 +158,11 @@ clientTransportConfig TransportClientConfig {logTLSErrors} =
 runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
 runTransportClient = runTLSTransportClient defaultSupportedParams Nothing
 
+data ConnectionHandle c
+  = CHSocket Socket
+  | CHContext T.Context
+  | CHTransport (c 'TClient)
+
 runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
 runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, clientALPN, useSNI} socksCreds host port keyHash client = do
   serverCert <- newEmptyTMVarIO
@@ -165,17 +172,22 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
       connectTCP = case socksProxy of
         Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
         _ -> connectTCPClient hostName
-  c <- do
-    sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
+  h <- newIORef Nothing
+  let set hc = (>>= \c -> writeIORef h (Just $ hc c) $> c)
+  E.bracket (set CHSocket $ connectTCP port) (\_ -> closeConn h) $ \sock -> do
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive " <> tshow e)
     let tCfg = clientTransportConfig cfg
     -- No TLS timeout to avoid failing connections via SOCKS
-    tls <- connectTLS (Just hostName) tCfg clientParams sock
-    chain <- takePeerCertChain serverCert `E.onException` closeTLS tls
+    tls <- set CHContext $ connectTLS (Just hostName) tCfg clientParams sock
+    chain <- takePeerCertChain serverCert
     sent <- readIORef clientCredsSent
-    getTransportConnection tCfg sent chain tls
-  client c `E.finally` closeConnection c
+    client =<< set CHTransport (getTransportConnection tCfg sent chain tls)
   where
+    closeConn = readIORef >=> mapM_ (\c -> E.uninterruptibleMask_ $ closeConn_ c `catchAll_` pure ())
+    closeConn_ = \case
+      CHSocket sock -> close sock
+      CHContext tls -> closeTLS tls
+      CHTransport c -> closeConnection c
     hostAddr = \case
       THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
       THIPv6 addr -> SocksAddrIPV6 addr
@@ -199,10 +211,11 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
       E.try (open addr) >>= either (`tryOpen` as) pure
 
     open :: AddrInfo -> IO Socket
-    open addr = do
-      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-      connect sock $ addrAddress addr
-      pure sock
+    open addr =
+      E.bracketOnError
+        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+        close
+        (\sock -> connect sock (addrAddress addr) $> sock)
 
 defaultSMPPort :: PortNumber
 defaultSMPPort = 5223

src/Simplex/Messaging/Transport/Credentials.hs

@@ -25,14 +25,6 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Time.System as Hourglass
 import qualified Time.Types as HT
 
--- | Generate a certificate chain to be used with TLS fingerprint-pinning
---
--- @
--- genTlsCredentials = do
---   ca <- genCredentials Nothing (-25, 365 * 24) "Root" -- long-lived root cert
---   leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert
---   pure $ tlsCredentials (leaf :| [ca])
--- @
 tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
 tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
   where

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Transport.HTTP2 where
 
@@ -15,7 +16,7 @@ import qualified Network.HTTP2.Server as HS
 import Network.Socket (SockAddr (..))
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
+import Simplex.Messaging.Transport (ALPN, TLS, Transport (cGet, cPut))
 import Simplex.Messaging.Transport.Buffer
 import qualified System.TimeManager as TI
 
@@ -81,3 +82,9 @@ getHTTP2Body r n = do
       -- TODO check bodySize once it is set
       bodyPart = if B.length bodyHead == n then Just getPart else Nothing
   pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}
+
+httpALPN :: [ALPN]
+httpALPN = ["h2", "http/1.1"]
+
+httpALPN11 :: ALPN
+httpALPN11 = "http/1.1"

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

@@ -27,6 +27,7 @@ import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (NetworkError (..), toNetworkError)
 import Simplex.Messaging.Transport (ALPN, STransportPeer (..), SessionId, TLS (tlsALPN, tlsPeerCert, tlsUniq), TransportPeer (..), TransportPeerI (..), getServerVerifyKey)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2
@@ -89,7 +90,7 @@ defaultHTTP2ClientConfig =
       suportedTLSParams = http2TLSParams
     }
 
-data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOException
+data HTTP2ClientError = HCResponseTimeout | HCNetworkError NetworkError | HCIOError IOException
   deriving (Show)
 
 getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
@@ -121,12 +122,15 @@ getVerifiedHTTP2ClientWith config host port disconnected setup =
     runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
       cVar <- newEmptyTMVarIO
-      action <- async $ setup (client c cVar) `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
+      action <-
+        async $ setup (client c cVar) `E.catch` \e -> do
+          atomically $ putTMVar cVar $ Left $ HCNetworkError $ toNetworkError e
+          E.throwIO e
       c_ <- connTimeout config `timeout` atomically (takeTMVar cVar)
       case c_ of
         Just (Right c') -> pure $ Right c' {action = Just action}
         Just (Left e) -> pure $ Left e
-        Nothing -> cancel action $> Left HCNetworkError
+        Nothing -> cancel action $> Left (HCNetworkError NETimeoutError)
 
     client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS p -> H.Client HTTP2Response
     client c cVar tls sendReq = do
@@ -176,7 +180,7 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
   reqTimeout `timeout` try (sendReq req process) >>= \case
     Just (Right r) -> pure $ Right r
     Just (Left e) -> disconnected $> Left (HCIOError e)
-    Nothing -> pure $ Left HCNetworkError
+    Nothing -> pure $ Left HCResponseTimeout
   where
     process r = do
       respBody <- getHTTP2Body r $ bodyHeadSize config

src/Simplex/Messaging/Transport/Server.hs

@@ -49,7 +49,7 @@ import Network.Socket
 import qualified Network.TLS as T
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Shared
-import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
+import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow, unlessM)
 import System.Exit (exitFailure)
 import System.IO.Error (tryIOError)
 import System.Mem.Weak (Weak, deRefWeak)
@@ -172,12 +172,13 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve
   E.bracket getSocket (closeServer started clients) $ \sock ->
     forever . E.bracketOnError (safeAccept sock) (close . fst) $ \(conn, _peer) -> do
       cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId' `seq` (cId', cId')
+      closed <- newTVarIO False
       let closeConn _ = do
-            atomically $ modifyTVar' clients $ IM.delete cId
+            atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId)
             gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
             atomically $ modifyTVar' gracefullyClosed (+ 1)
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
-      atomically $ modifyTVar' clients $ IM.insert cId tId
+      atomically $ unlessM (readTVar closed) $ modifyTVar' clients $ IM.insert cId tId
 
 -- | Recover from errors in `accept` whenever it is safe.
 -- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop.

src/Simplex/Messaging/Util.hs

@@ -171,28 +171,30 @@ catchAll_ :: IO a -> IO a -> IO a
 catchAll_ a = catchAll a . const
 {-# INLINE catchAll_ #-}
 
-tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a)
-tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err)
+class Show e => AnyError e where fromSomeException :: E.SomeException -> e
+
+tryAllErrors :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> ExceptT e m (Either e a)
+tryAllErrors action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . fromSomeException)
 {-# INLINE tryAllErrors #-}
 
-tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a)
-tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err)
+tryAllErrors' :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> m (Either e a)
+tryAllErrors' action = runExceptT action `UE.catch` (pure . Left . fromSomeException)
 {-# INLINE tryAllErrors' #-}
 
-catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
-catchAllErrors err action handler = tryAllErrors err action >>= either handler pure
+catchAllErrors :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
+catchAllErrors action handler = tryAllErrors action >>= either handler pure
 {-# INLINE catchAllErrors #-}
 
-catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> m a) -> m a
-catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure
+catchAllErrors' :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> (e -> m a) -> m a
+catchAllErrors' action handler = tryAllErrors' action >>= either handler pure
 {-# INLINE catchAllErrors' #-}
 
-catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a
-catchThrow action err = catchAllErrors err action throwE
+catchThrow :: MonadUnliftIO m => ExceptT e m a -> (SomeException -> e) -> ExceptT e m a
+action `catchThrow` err = ExceptT $ runExceptT action `UE.catch` (pure . Left . err)
 {-# INLINE catchThrow #-}
 
-allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a
-allFinally err action final = tryAllErrors err action >>= \r -> final >> except r
+allFinally :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> ExceptT e m b -> ExceptT e m a
+allFinally action final = tryAllErrors action >>= \r -> final >> except r
 {-# INLINE allFinally #-}
 
 eitherToMaybe :: Either a b -> Maybe b
@@ -209,17 +211,25 @@ firstRow f e a = second f . listToEither e <$> a
 maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b)
 maybeFirstRow f q = fmap f . listToMaybe <$> q
 
+maybeFirstRow' :: Functor f => b -> (a -> b) -> f [a] -> f b
+maybeFirstRow' def f q = maybe def f . listToMaybe <$> q
+
 firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
 firstRow' f e a = (f <=< listToEither e) <$> a
 
 groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
 groupOn = groupBy . eqOn
-  where
-    -- it is equivalent to groupBy ((==) `on` f),
-    -- but it redefines `on` to avoid duplicate computation for most values.
-    -- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-    -- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
-    eqOn f x = let fx = f x in \y -> fx == f y
+
+groupOn' :: Eq k => (a -> k) -> [a] -> [NonEmpty a]
+groupOn' = L.groupBy . eqOn
+
+-- it is equivalent to groupBy ((==) `on` f),
+-- but it redefines `on` to avoid duplicate computation for most values.
+-- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
+-- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
+eqOn :: Eq k => (a -> k) -> a -> a -> Bool
+eqOn f x = let fx = f x in \y -> fx == f y
+{-# INLINE eqOn #-}
 
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f

src/Simplex/RemoteControl/Client.hs

@@ -85,7 +85,7 @@ encInvitationSize = 900
 
 newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
 newRCHostPairing drg = do
-  ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca"
+  ((_, caKey), caCert) <- genCredentials drg Nothing (25, 24 * 999999) "ca"
   (_, idPrivKey) <- atomically $ C.generateKeyPair drg
   pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
 
@@ -193,7 +193,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
 genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> X.SignedCertificate -> IO TLS.Credential
 genTLSCredentials drg caKey caCert = do
   let caCreds = (C.signatureKeyPair caKey, caCert)
-  leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
+  leaf <- genCredentials drg (Just caCreds) (1, 24 * 999999) "localhost" -- session-signing cert
   pure . snd $ tlsCredentials (leaf :| [caCreds])
 
 certFingerprint :: X.SignedCertificate -> C.KeyHash
@@ -259,7 +259,7 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h
   where
     newCtrlPairing :: IO RCCtrlPairing
     newCtrlPairing = do
-      ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca"
+      ((_, caKey), caCert) <- genCredentials drg Nothing (1, 24 * 999999) "ca"
       (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
       pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing}
     updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
@@ -306,14 +306,8 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
             atomically $ takeTMVar endSession
             logDebug "Session ended"
 
-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
-  _ -> RCEException $ show e
-{-# INLINE catchRCError #-}
-
 putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
-a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
+a `putRCError` r = a `catchAllErrors` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
 
 sendRCPacket :: Encoding a => TLS p -> a -> ExceptT RCErrorType IO ()
 sendRCPacket tls pkt = do
@@ -395,7 +389,7 @@ discoverRCCtrl subscribers pairings =
       pure r
   where
     loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
-    loop action = action `catchRCError` \e -> logError (tshow e) >> loop action
+    loop action = action `catchAllErrors` \e -> logError (tshow e) >> loop action
 
 findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do

src/Simplex/RemoteControl/Types.hs

@@ -19,6 +19,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word16)
 import qualified Data.X509 as X
+import qualified Network.TLS as TLS
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
@@ -26,7 +27,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport (TLS, TSbChainKeys, TransportPeer (..))
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (AnyError (..), safeDecodeUtf8)
 import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
 import Simplex.Messaging.Version.Internal
 import UnliftIO
@@ -50,6 +51,12 @@ data RCErrorType
   | RCESyntax {syntaxErr :: String}
   deriving (Eq, Show, Exception)
 
+instance AnyError RCErrorType where
+  fromSomeException e = case fromException e of
+    Just (TLS.Terminated _ _ (TLS.Error_Protocol _ TLS.UnknownCa)) -> RCEIdentity
+    _ -> RCEException $ show e
+  {-# INLINE fromSomeException #-}
+
 instance StrEncoding RCErrorType where
   strEncode = \case
     RCEInternal err -> "INTERNAL" <> text err

tests/AgentTests/FunctionalAPITests.hs

@@ -66,7 +66,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight)
 import Data.Int (Int64)
-import Data.List (find, nub)
+import Data.List (find, isSuffixOf, nub)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as M
 import Data.Maybe (isJust, isNothing)
@@ -81,7 +81,7 @@ import Data.Word (Word16)
 import GHC.Stack (withFrozenCallStack)
 import SMPAgentClient
 import SMPClient
-import Simplex.Messaging.Agent hiding (createConnection, joinConnection, subscribeConnection, sendMessage)
+import Simplex.Messaging.Agent hiding (acceptContact, createConnection, deleteConnection, deleteConnections, getConnShortLink, joinConnection, sendMessage, setConnShortLink, subscribeConnection, suspendConnection)
 import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
@@ -90,15 +90,15 @@ import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
-import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF)
-import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, NetworkError (..), ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
 import Simplex.Messaging.Server.Expiration
@@ -114,6 +114,7 @@ import Test.Hspec hiding (fit, it)
 import UnliftIO
 import Util
 import XFTPClient (testXFTPServer)
+
 #if defined(dbPostgres)
 import Fixtures
 #endif
@@ -122,6 +123,7 @@ import qualified Database.PostgreSQL.Simple as PSQL
 import Simplex.Messaging.Agent.Store (Connection (..), StoredRcvQueue (..), SomeConn (..))
 import Simplex.Messaging.Agent.Store.AgentStore (getConn)
 import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Postgres (PostgresQueue)
 import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
 import Simplex.Messaging.Server.QueueStore.Postgres
 import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..))
@@ -177,7 +179,7 @@ pGet' c skipWarn = do
   case cmd of
     CONNECT {} -> pGet c
     DISCONNECT {} -> pGet c
-    ERR (BROKER _ NETWORK) -> pGet c
+    ERR (BROKER _ (NETWORK _)) -> pGet c
     MWARN {} | skipWarn -> pGet c
     RFWARN {} | skipWarn -> pGet c
     SFWARN {} | skipWarn -> pGet c
@@ -253,6 +255,12 @@ runRight action =
     Right x -> pure x
     Left e -> error $ "Unexpected error: " <> show e
 
+runLeft :: (Show a, HasCallStack) => ExceptT e IO a -> IO e
+runLeft action =
+  runExceptT action >>= \case
+    Right x -> error $ "unexpected result " <> show x
+    Left e -> pure e
+
 getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation
 getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
 
@@ -270,15 +278,18 @@ inAnyOrder g rs = withFrozenCallStack $ do
 
 createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
 createConnection c userId enableNtfs cMode clientData subMode = do
-  (connId, (CCLink cReq _, Nothing)) <- A.createConnection c userId enableNtfs cMode Nothing clientData IKPQOn subMode
+  (connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs cMode Nothing clientData IKPQOn subMode
   pure (connId, cReq)
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
 joinConnection c userId enableNtfs cReq connInfo subMode = do
   connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
-  (sndSecure, Nothing) <- A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
+  (sndSecure, Nothing) <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
   pure (connId, sndSecure)
 
+acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
+acceptContact c = A.acceptContact c NRMInteractive
+
 subscribeConnection :: AgentClient -> ConnId -> AE ()
 subscribeConnection c = void . A.subscribeConnection c
 
@@ -288,6 +299,21 @@ sendMessage c connId msgFlags msgBody = do
   liftIO $ pqEnc `shouldBe` PQEncOn
   pure msgId
 
+deleteConnection :: AgentClient -> ConnId -> AE ()
+deleteConnection c = A.deleteConnection c NRMInteractive
+
+deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ()))
+deleteConnections c = A.deleteConnections c NRMInteractive
+
+getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
+getConnShortLink c = A.getConnShortLink c NRMInteractive
+
+setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
+setConnShortLink c = A.setConnShortLink c NRMInteractive
+
+suspendConnection :: AgentClient -> ConnId -> AE ()
+suspendConnection c = A.suspendConnection c NRMInteractive
+
 functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
 functionalAPITests ps = do
   describe "Establishing duplex connection" $ do
@@ -331,6 +357,13 @@ functionalAPITests ps = do
       testAsyncServerOffline ps
     it "should restore confirmation after client restart" $
       testAllowConnectionClientRestart ps
+  describe "Establishing connections with user retries" $ do
+    describe "Via invitation" $ do
+      it "should connect after errors" $ testInvitationErrors ps False
+      it "should connect after errors with client restarts" $ testInvitationErrors ps True
+    describe "Via contact" $ do
+      it "should connect after errors" $ testContactErrors ps False
+      it "should connect after errors with client restarts" $ testContactErrors ps True
   describe "Short connection links" $ do
     describe "should connect via 1-time short link" $ testProxyMatrix ps testInviationShortLink
     describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync
@@ -485,7 +518,7 @@ functionalAPITests ps = do
     it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
     let srv1 = testSMPServer2 {keyHash = "1234"}
     it "should fail with incorrect fingerprint" $ do
-      testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+      testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
     describe "server with password" $ do
       let auth = Just "abcd"
           srv = ProtoServerWithAuth testSMPServer2
@@ -667,9 +700,9 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
 runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
+    (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
@@ -869,14 +902,14 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
 runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+    (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    (sqSecuredJoin, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    (sqSecuredJoin, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` reqPQSupport
-    bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-    (sqSecured', Nothing) <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+    bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
+    (sqSecured', Nothing) <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
     liftIO $ pqSup'' `shouldBe` bPQ
@@ -913,7 +946,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
 
 runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
-  (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+  (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
   (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
   sentMessages abPQEnc alice bobId bob bAliceId
   (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
@@ -922,12 +955,12 @@ 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
-      (sqSecuredJoin, Nothing) <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
+      (sqSecuredJoin, Nothing) <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe
       liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
       ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
-      bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-      (sqSecuredAccept, Nothing) <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+      bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
+      (sqSecuredAccept, Nothing) <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
       liftIO $ pqSup'' `shouldBe` pq
@@ -966,13 +999,12 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
 testRejectContactRequest :: HasCallStack => IO ()
 testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
-    (addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
-    liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
-    rejectContact alice addrConnId invId
+    rejectContact alice invId
     liftIO $ noMessages bob "nothing delivered to bob"
 
 testUpdateConnectionUserId :: HasCallStack => IO ()
@@ -982,7 +1014,7 @@ testUpdateConnectionUserId =
     newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
     _ <- changeConnectionUser alice 1 connId newUserId
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured' `shouldBe` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -1075,7 +1107,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
   (bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ ->
     runRight $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe
   -- connection fails
-  Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
+  Left (BROKER _ (NETWORK _)) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
   ("", "", DOWN srv conns) <- nGet alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
@@ -1134,11 +1166,166 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
     disposeAgentClient alice2
     disposeAgentClient bob
 
+testInvitationErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
+testInvitationErrors ps restart = do
+  a <- getAgentA
+  b <- getAgentB
+  (bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe
+  ("", "", DOWN _ [_]) <- nGet a
+  aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
+  -- fails to secure the queue on testPort
+  BROKER srv (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
+  (testPort `isSuffixOf` srv) `shouldBe` True
+  withServer1 ps $ do
+    ("", "", UP _ [_]) <- nGet a
+    let loopSecure = do
+          -- secures the queue on testPort, but fails to create reply queue on testPort2
+          BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
+          unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
+    loopSecure
+  ("", "", DOWN _ [_]) <- nGet a
+  b' <- withServer2 ps $ do
+    threadDelay 200000
+    let loopCreate = do
+          -- creates the reply queue on testPort2, but fails to send it to testPort
+          BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
+          unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
+    loopCreate
+    restartAgentB restart b [aId]
+  ("", "", DOWN _ [_]) <- nGet b'
+  n <- withServer1 ps $ do
+    ("", "", UP _ [_]) <- nGet a
+    threadDelay 200000
+    let loopConfirm n =
+          runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
+            Right (True, Nothing) -> pure n
+            Right r -> error $ "unexpected result " <> show r
+            Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
+    n <- loopConfirm 1
+    runRight $ do
+      ("", _, CONF confId _ "bob's connInfo") <- get a
+      allowConnectionAsync a "1" bId confId "alice's connInfo"
+      get a ##> ("1", bId, OK)
+    pure n
+  ("", "", DOWN _ [_]) <- nGet a
+  withServer2 ps $ do
+    get a ##> ("", bId, CON) -- note that server 1 is down, CON event is sent when HELLO is sent to server 2
+    ("", "", UP _ [_]) <- nGet b'
+    get b' ##> ("", aId, INFO "alice's connInfo")
+    get b' ##> ("", aId, CON)
+    withServer1 ps $ do
+      ("", "", UP _ [_]) <- nGet a
+      runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn 2 (2 + n) a bId b' aId
+      disposeAgentClient a
+      disposeAgentClient b'
+
+restartAgentA :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
+restartAgentA = restartAgent_ getAgentA
+
+restartAgentB :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
+restartAgentB = restartAgent_ getAgentB
+
+restartAgent_ :: IO AgentClient -> Bool -> AgentClient -> [ConnId] -> IO AgentClient
+restartAgent_ getAgent restart c cIds
+  | restart = do
+      disposeAgentClient c
+      threadDelay 200000
+      c' <- getAgent
+      rs <- runRight $ subscribeConnections c' cIds
+      all isRight rs `shouldBe` True
+      pure c'
+  | otherwise = pure c
+
+testContactErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
+testContactErrors ps restart = do
+  a <- getAgentA
+  b <- getAgentB
+  (contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe
+  ("", "", DOWN _ [_]) <- nGet a
+  aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
+  -- fails to create queue on testPort2
+  BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
+  (testPort2 `isSuffixOf` srv2) `shouldBe` True
+  b' <- restartAgentB restart b [aId]
+  let loopCreate2 = do
+        -- creates the reply queue on testPort2, but fails to send invitation to testPort
+        BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
+        unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2
+  b'' <- withServer2 ps $ do
+    loopCreate2
+    restartAgentB restart b' [aId]
+  ("", "", DOWN _ [_]) <- nGet b''
+  invId <- withServer1 ps $ do
+    ("", "", UP _ [_]) <- nGet a
+    let loopSend = do
+          -- sends the invitation to testPort
+          runExceptT (A.joinConnection b'' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
+            Right (False, Nothing) -> pure ()
+            Right r -> error $ "unexpected result " <> show r
+            Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend
+    loopSend
+    ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a
+    pure invId
+  ("", "", DOWN _ [_]) <- nGet a
+  bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
+  withServer2 ps $ do
+    ("", "", UP _ [_]) <- nGet b''
+    let loopSecure = do
+          -- secures the queue on testPort2, but fails to create reply queue on testPort
+          BROKER srv (NETWORK _) <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+          unless (testPort `isSuffixOf` srv) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
+    loopSecure
+  ("", "", DOWN _ [_]) <- nGet b''
+  a' <- withServer1 ps $ do
+    ("", "", UP _ [_]) <- nGet a
+    let loopCreate = do
+          -- creates the reply queue on testPort, but fails to send confirmation to testPort2
+          BROKER srv2' (NETWORK _) <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+          unless (testPort2 `isSuffixOf` srv2') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
+    loopCreate
+    restartAgentA restart a [contactId, bId]
+  ("", "", DOWN _ [_, _]) <- nGet a' -- the second connection is from accept
+  (n, confId) <- withServer2 ps $ do
+    ("", "", UP _ [_]) <- nGet b''
+    let loopConfirm n =
+          runExceptT (acceptContact a' 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case
+            Right (True, Nothing) -> pure n
+            Right r -> error $ "unexpected result " <> show r
+            Left _ -> putStrLn "retrying accept confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
+    n <- loopConfirm 1
+    ("", _, A.CONF confId PQSupportOn _ "alice's connInfo") <- get b''
+    pure (n, confId)
+  ("", "", DOWN _ [_]) <- nGet b''
+  runRight_ $ allowConnection b'' aId confId "bob's connInfo"
+  withServer1 ps $ do
+    ("", "", UP _ [_, _]) <- nGet a'
+    get a' ##> ("", bId, A.INFO PQSupportOn "bob's connInfo")
+    get a' ##> ("", bId, A.CON PQEncOn)
+    get b'' ##> ("", aId, A.CON PQEncOn) -- note that server 2 is down, this event is delivered when HELLO is sent to server 1
+    a'' <- restartAgentA restart a' [contactId, bId]
+    withServer2 ps $ do
+      ("", "", UP _ [_]) <- nGet b''
+      runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn (2 + n) 2 a'' bId b'' aId
+      disposeAgentClient a''
+      disposeAgentClient b''
+
+getAgentA :: IO AgentClient
+getAgentA = getSMPAgentClient' 1 agentCfg initAgentServers testDB
+
+getAgentB :: IO AgentClient
+getAgentB = getSMPAgentClient' 2 agentCfg (initAgentServers {smp = userServers [testSMPServer2]}) testDB2
+
+withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a
+withServer1 ps = withSmpServerStoreLogOn ps testPort . const
+
+withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a
+withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const
+
 testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testInviationShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
     let userData = UserLinkData "some user data"
-    (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+    (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
@@ -1160,7 +1347,7 @@ testInviationShortLink viaProxy a b =
 testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
 testJoinConn_ viaProxy sndSecure a bId b connReq = do
   aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
-  (sndSecure', Nothing) <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
+  (sndSecure', Nothing) <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
   liftIO $ sndSecure' `shouldBe` sndSecure
   ("", _, CONF confId _ "bob's connInfo") <- get a
   allowConnection a bId confId "alice's connInfo"
@@ -1173,13 +1360,13 @@ testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> Age
 testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
   let userData = UserLinkData "some user data"
   -- can't create short link with previous version
-  (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
+  (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
   testJoinConn_ viaProxy sndSecure a bId b connReq
 
 testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testInviationShortLinkAsync viaProxy a b = do
   let userData = UserLinkData "some user data"
-  (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+  (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
   (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
   strDecode (strEncode shortLink) `shouldBe` Right shortLink
   connReq' `shouldBe` connReq
@@ -1198,7 +1385,7 @@ testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO
 testContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
     let userData = UserLinkData "some user data"
-    (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
+    (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0)
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
@@ -1216,8 +1403,8 @@ testContactShortLink viaProxy a b =
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
-      bId <- A.prepareConnectionToAccept a True invId PQSupportOn
-      (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+      bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
+      (sndSecure', Nothing) <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
       allowConnection b aId confId "bob's connInfo"
@@ -1236,14 +1423,14 @@ testContactShortLink viaProxy a b =
     shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink2 `shouldBe` shortLink
     -- delete short link
-    runRight_ $ deleteConnShortLink a contactId SCMContact
+    runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact
     Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink
     pure ()
 
 testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testAddContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
-    (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
+    (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0) --
     let userData = UserLinkData "some user data"
     shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
@@ -1263,8 +1450,8 @@ testAddContactShortLink viaProxy a b =
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
-      bId <- A.prepareConnectionToAccept a True invId PQSupportOn
-      (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+      bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
+      (sndSecure', Nothing) <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
       allowConnection b aId confId "bob's connInfo"
@@ -1284,7 +1471,7 @@ testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
 testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
   (bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $
-    runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
+    runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
   withSmpServer ps $ do
     runRight_ $ subscribeConnection a bId
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
@@ -1296,7 +1483,7 @@ testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO
 testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
   (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $
-    runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
+    runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
   let updatedData = UserLinkData "updated user data"
   withSmpServer ps $ do
@@ -1316,7 +1503,7 @@ testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
 testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
   ((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do
-    r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
+    r@(contactId, _) <- A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
     (r,) <$> setConnShortLink a contactId SCMContact userData Nothing
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
   let updatedData = UserLinkData "updated user data"
@@ -1336,23 +1523,32 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
 testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
   (contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $
-    A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
+    A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
   -- make it an "old" queue
   let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
-  () <- case testServerStoreConfig msType of
-    ASSCfg _ _ (SSCMemory (Just StorePaths {storeLogFile})) -> updateStoreLog storeLogFile
-    ASSCfg _ _ (SSCMemoryJournal {storeLogFile}) -> updateStoreLog storeLogFile
-    ASSCfg _ _ (SSCDatabaseJournal {storeCfg}) -> do
 #if defined(dbServerPostgres)
-      let AgentClient {agentEnv = Env {store}} = a
-      Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
-      st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) storeCfg
-      Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
-      closeQueueStore @(JournalQueue 'QSPostgres) st
-#else
-      error "no dbServerPostgres flag"
+      updateDbStore :: PostgresQueueStore s -> IO ()
+      updateDbStore st = do
+        let AgentClient {agentEnv = Env {store}} = a
+        Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
+        Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
+        pure ()
+#endif
+  () <- case testServerStoreConfig msType of
+    ASSCfg _ _ (SSCMemory sp_) -> mapM_ (\StorePaths {storeLogFile} -> updateStoreLog storeLogFile) sp_
+    ASSCfg _ _ SSCMemoryJournal {storeLogFile} -> updateStoreLog storeLogFile
+#if defined(dbServerPostgres)
+    ASSCfg _ _ SSCDatabaseJournal {storeCfg} -> do
+      st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) (storeCfg, True)
+      updateDbStore st
+      closeQueueStore @(JournalQueue 'QSPostgres) st
+    ASSCfg _ _ (SSCDatabase storeCfg) -> do
+      st :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False)
+      updateDbStore st
+      closeQueueStore @PostgresQueue st
+#else
+    ASSCfg _ _ SSCDatabaseJournal {} -> error "no dbServerPostgres flag"
 #endif
-    _ -> pure ()
 
   withSmpServer ps $ do
     let userData = UserLinkData "some user data"
@@ -1558,7 +1754,7 @@ testDuplicateMessage ps = do
   -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing
+  Left (BROKER _ (NETWORK _)) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing
 
   disposeAgentClient alice
   disposeAgentClient bob1
@@ -1642,8 +1838,8 @@ testDeliveryAfterSubscriptionError ps = do
     pure (aId, bId)
 
   withAgentClients2 $ \a b -> do
-    Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId
-    Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId
+    Left (BROKER _ (NETWORK _)) <- runExceptT $ subscribeConnection a bId
+    Left (BROKER _ (NETWORK _)) <- runExceptT $ subscribeConnection b aId
     withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
       withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False
       withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
@@ -1687,7 +1883,7 @@ testExpireMessage ps =
       2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1"
       threadDelay 1500000
       3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire
-      get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False
+      get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && networkOrTimeoutError e; _ -> False
       withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
         withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False
         withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False
@@ -1706,8 +1902,8 @@ testExpireManyMessages ps =
         4 <- sendMessage a bId SMP.noMsgFlags "3"
         liftIO $ threadDelay 2000000
         5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire
-        get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False
-        let expected c e = bId == c && (e == TIMEOUT || e == NETWORK)
+        get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && networkOrTimeoutError e; _ -> False
+        let expected c e = bId == c && networkOrTimeoutError e
         get a >>= \case
           ("", c, MERR 3 (BROKER _ e)) -> do
             liftIO $ expected c e `shouldBe` True
@@ -2067,9 +2263,9 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
 
 makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
-  (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
+  (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
-  (sqSecured', Nothing) <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
+  (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
   liftIO $ sqSecured' `shouldBe` sqSecured
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
@@ -2235,7 +2431,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
       liftIO $ do
         let dc = S.fromList $ take nDel cs
         all isRight (M.withoutKeys r dc) `shouldBe` True
-        all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
+        all (== Left (CONN NOT_FOUND "")) (M.restrictKeys r dc) `shouldBe` True
         M.keys r `shouldMatchList` cs
     delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
     delete c cs = do
@@ -2247,7 +2443,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
     deleteFail c cs = do
       r <- deleteConnections c cs
       liftIO $ do
-        all (== Left (CONN NOT_FOUND)) r `shouldBe` True
+        all (== Left (CONN NOT_FOUND "")) r `shouldBe` True
         M.keys r `shouldMatchList` cs
     runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
@@ -2405,7 +2601,7 @@ testAcceptContactAsync sqSecured alice bob baseId =
     (aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
+    bobId <- acceptContactAsync alice 1 "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
     get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False
     ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
@@ -2448,7 +2644,7 @@ testDeleteConnectionAsync ps =
     runRight_ $ do
       deleteConnectionsAsync a False connIds
       nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False
-      let delOk = \case (c, _, _, Just (BROKER _ e)) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
+      let delOk = \case (c, _, _, Just (BROKER _ e)) -> c `elem` connIds && networkOrTimeoutError e; _ -> False
       get a =##> \case ("", "", DEL_RCVQS rs) -> length rs == 3 && all delOk rs; _ -> False
       get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False
       liftIO $ noMessages a "nothing else should be delivered to alice"
@@ -2506,7 +2702,7 @@ testWaitDelivery ps =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
@@ -2563,7 +2759,7 @@ testWaitDeliveryAUTHErr ps =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
@@ -2603,7 +2799,7 @@ testWaitDeliveryTimeout ps =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
         get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
@@ -2643,7 +2839,7 @@ testWaitDeliveryTimeout2 ps =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
         get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
@@ -2664,6 +2860,12 @@ testWaitDeliveryTimeout2 ps =
     baseId = 1
     msgId = subtract baseId
 
+networkOrTimeoutError :: BrokerErrorType -> Bool
+networkOrTimeoutError = \case
+  TIMEOUT -> True
+  NETWORK _ -> True
+  _ -> False
+
 testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
@@ -2790,7 +2992,7 @@ testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
   nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
   runRight_ $ do
     deleteUser a auId True
-    get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Just (BROKER _ e))]) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Just (BROKER _ e))]) -> c == bId' && networkOrTimeoutError e;; _ -> False
     get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False
     nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
@@ -3216,7 +3418,7 @@ testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
   withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
     -- initially passed server is not running
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
-      testProtocolServer a 1 srv
+      testProtocolServer a NRMInteractive 1 srv
   where
     cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
 
@@ -3428,13 +3630,13 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do
 
 #if defined(dbPostgres)
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError
+createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
 #else
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError
+createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")
@@ -3454,7 +3656,7 @@ testServerMultipleIdentities =
     exchangeGreetings alice bobId bob aliceId
     -- this saves queue with second server identity
     bob' <- liftIO $ do
-      Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe
+      Left (BROKER _ (NETWORK _)) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe
       disposeAgentClient bob
       threadDelay 250000
       getSMPAgentClient' 3 agentCfg initAgentServers testDB2
@@ -3614,7 +3816,7 @@ testServerQueueInfo = do
       liftIO $ isJust r `shouldBe` True
       pure r
     checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do
-      ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId
+      ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c NRMInteractive cId
       liftIO $ do
         qiSnd `shouldBe` qiSnd'
         qiNtf `shouldBe` False
@@ -3651,24 +3853,29 @@ exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> Agen
 exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn
 
 exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetingsMsgId_ = exchangeGreetingsViaProxyMsgId_ False
+exchangeGreetingsMsgId_ pqEnc msgId = exchangeGreetingsViaProxyMsgId_ False pqEnc msgId msgId
 
 exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2
+exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 2
 
-exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc msgId alice bobId bob aliceId = do
+exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
+exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc aMsgId bMsgId alice bobId bob aliceId = do
   msgId1 <- A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
-  liftIO $ msgId1 `shouldBe` (msgId, pqEnc)
-  get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == msgId && viaProxy == isJust srv_; _ -> False
-  get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == msgId && pq == pqEnc; _ -> False
-  ackMessage bob aliceId msgId Nothing
+  liftIO $ msgId1 `shouldBe` (aMsgId, pqEnc)
+  get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == aMsgId && viaProxy == isJust srv_; _ -> False
+  if aMsgId <= bMsgId
+    then get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
+    else get bob =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
+  ackMessage bob aliceId bMsgId Nothing
   msgId2 <- A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
-  let msgId' = msgId + 1
-  liftIO $ msgId2 `shouldBe` (msgId', pqEnc)
-  get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == msgId' && viaProxy == isJust srv_; _ -> False
-  get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == msgId' && pq == pqEnc; _ -> False
-  ackMessage alice bobId msgId' Nothing
+  let aMsgId' = aMsgId + 1
+      bMsgId' = bMsgId + 1
+  liftIO $ msgId2 `shouldBe` (bMsgId', pqEnc)
+  get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == bMsgId' && viaProxy == isJust srv_; _ -> False
+  if aMsgId >= bMsgId
+    then get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
+    else get alice =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
+  ackMessage alice bobId aMsgId' Nothing
 
 exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO ()
 exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do

tests/AgentTests/MigrationTests.hs

@@ -212,7 +212,7 @@ createStore randSuffix migrations confirmMigrations = do
           poolSize = 1,
           createSchema = True
         }
-  createDBStore dbOpts migrations confirmMigrations
+  createDBStore dbOpts migrations (MigrationConfig confirmMigrations Nothing)
 
 cleanup :: Word32 -> IO ()
 cleanup randSuffix = dropSchema testDBConnectInfo (testSchema randSuffix)
@@ -235,7 +235,7 @@ createStore randSuffix migrations confirmMigrations = do
           vacuum = True,
           track = DB.TQOff
         }
-  createDBStore dbOpts migrations confirmMigrations
+  createDBStore dbOpts migrations (MigrationConfig confirmMigrations Nothing)
 
 cleanup :: Word32 -> IO ()
 cleanup randSuffix = removeFile (testDB randSuffix)

tests/AgentTests/NotificationTests.hs

@@ -61,7 +61,8 @@ import qualified Database.PostgreSQL.Simple as PSQL
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
 import SMPClient
-import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
+import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken)
+import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
@@ -69,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken)
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore)
+import Simplex.Messaging.Client (pattern NRMInteractive)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
@@ -77,7 +79,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Store.Postgres (closeNtfDbStore, newNtfDbStore, withDB')
 import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
+import Simplex.Messaging.Protocol (ErrorType (AUTH), NetworkError (..), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
 import Simplex.Messaging.Transport (ASrvTransport)
@@ -135,7 +137,7 @@ notificationTests ps@(t, _) = do
     it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing
     let srv1 = testNtfServer {keyHash = "1234"}
     it "should fail with incorrect fingerprint" $ do
-      testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+      testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
   describe "Managing notification subscriptions" $ do
     describe "should create notification subscription for existing connection" $
       testNtfMatrix ps testNotificationSubscriptionExistingConnection
@@ -194,6 +196,15 @@ testNtfMatrix ps@(_, msType) runTest = do
     cfg' = cfgMS msType
     cfgVPrev' = cfgVPrev msType
 
+registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
+registerNtfToken c = A.registerNtfToken c NRMInteractive
+
+checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
+checkNtfToken c = A.checkNtfToken c NRMInteractive
+
+verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
+verifyNtfToken c = A.verifyNtfToken c NRMInteractive
+
 runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
 runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
   ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
@@ -310,7 +321,7 @@ testNtfTokenServerRestartReverify t apns = do
     runRight_ $ do
       verification <- ntfData .-> "verification"
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
-      Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification
+      Left (BROKER _ (NETWORK _)) <- tryE $ verifyNtfToken a tkn nonce verification
       pure ()
   threadDelay 1500000
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
@@ -467,7 +478,7 @@ testNtfTokenChangeServers t apns =
         tkn2 <- registerTestToken a "xyzw" NMInstant apns
         getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
         deleteNtfToken a tkn2 -- force server switch
-        Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apns -- ok, it's down for now
+        Left BROKER {brokerErr = (NETWORK _)} <- tryError $ registerTestToken a "qwer" NMInstant apns -- ok, it's down for now
         getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
       killThread ntf
       withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 $ runRight_ $ do
@@ -529,7 +540,7 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai
 testRunNTFServerTests t srv =
   withNtfServer t $
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
-      testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
+      testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
 testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do

tests/AgentTests/SQLiteTests.hs

@@ -46,7 +46,7 @@ import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
 import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction')
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (pattern IKPQOn)
@@ -83,7 +83,7 @@ createEncryptedStore key keepKey = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations MCError
+  Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);")
   pure st
 
@@ -421,10 +421,10 @@ testUpgradeRcvConnToDuplex =
               smpClientVersion = VersionSMPC 1
             }
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
-      `shouldReturn` Left (SEBadConnType CSnd)
+      `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CSnd)
     _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
-      `shouldReturn` Left (SEBadConnType CDuplex)
+      `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CDuplex)
 
 testUpgradeSndConnToDuplex :: SpecWith DBStore
 testUpgradeSndConnToDuplex =
@@ -455,10 +455,10 @@ testUpgradeSndConnToDuplex =
               deleteErrors = 0
             }
     upgradeSndConnToDuplex db "conn1" anotherRcvQueue
-      `shouldReturn` Left (SEBadConnType CRcv)
+      `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CRcv)
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     upgradeSndConnToDuplex db "conn1" anotherRcvQueue
-      `shouldReturn` Left (SEBadConnType CDuplex)
+      `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CDuplex)
 
 testSetRcvQueueStatus :: SpecWith DBStore
 testSetRcvQueueStatus =

tests/AgentTests/SchemaDump.hs

@@ -14,7 +14,7 @@ import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import Simplex.Messaging.Agent.Store.SQLite.DB (TrackQueries (..))
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -51,7 +51,7 @@ testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
   savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
   savedSchema `deepseq` pure ()
-  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole
+  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCConsole Nothing)
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
@@ -59,14 +59,14 @@ testVerifyLintFKeyIndexes :: IO ()
 testVerifyLintFKeyIndexes = do
   savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
   savedLint `deepseq` pure ()
-  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole
+  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCConsole Nothing)
   getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint
   removeFile testDB
 
 testSchemaMigrations :: IO ()
 testSchemaMigrations = do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) appMigrations
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations (MigrationConfig MCError Nothing)
   mapM_ (testDownMigration st) $ drop (length noDownMigrations) appMigrations
   closeDBStore st
   removeFile testDB
@@ -89,7 +89,7 @@ testSchemaMigrations = do
 
 testUsersMigrationNew :: IO ()
 testUsersMigrationNew = do
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([] :: [Only Int])
   closeDBStore st
@@ -97,11 +97,11 @@ testUsersMigrationNew = do
 testUsersMigrationOld :: IO ()
 testUsersMigrationOld = do
   let beforeUsers = takeWhile (("m20230110_users" /=) . name) appMigrations
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';")
     `shouldReturn` ([] :: [Only String])
   closeDBStore st
-  Right st' <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCYesUp
+  Right st' <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCYesUp Nothing)
   withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([Only (1 :: Int)])
   closeDBStore st'

tests/AgentTests/ServerChoice.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 

tests/CLITests.hs

@@ -10,7 +10,6 @@ import AgentTests.FunctionalAPITests (runRight_)
 import Control.Logger.Simple
 import Control.Monad
 import qualified Crypto.PubKey.RSA as RSA
-import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as HM
 import Data.Ini (Ini (..), lookupValue, readIniFile, writeIniFile)
@@ -23,8 +22,9 @@ import qualified Network.HTTP.Client as H1
 import qualified Network.HTTP2.Client as H2
 import Simplex.FileTransfer.Server.Main (xftpServerCLI)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Server.CLI (simplexmqVersionCommit)
 import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_)
-import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
+import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, supportedClientSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
@@ -45,6 +45,7 @@ import UnliftIO.Exception (bracket)
 import Util
 
 #if defined(dbServerPostgres)
+import qualified Data.ByteString.Char8 as B
 import qualified Database.PostgreSQL.Simple as PSQL
 import Database.PostgreSQL.Simple.Types (Query (..))
 import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts)
@@ -108,7 +109,7 @@ smpServerTest storeLog basicAuth = do
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
   -- start
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SMP server v" <> simplexMQVersion]
+  r `shouldContain` ["SMP server v" <> simplexmqVersionCommit]
   r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Serving SMP protocol on port 5223 (TLS)...", "Serving SMP protocol on port 443 (TLS)...", "Serving static site on port 443 (TLS)..."]
   r `shouldContain` ["expiring clients inactive for 21600 seconds every 3600 seconds"]
@@ -216,7 +217,7 @@ ntfServerTest storeLog = do
   lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
   doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SMP notifications server v" <> simplexMQVersion]
+  r `shouldContain` ["SMP notifications server v" <> simplexmqVersionCommit]
   r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Serving NTF protocol on port 443 (TLS)..."]
   capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
@@ -234,7 +235,7 @@ xftpServerTest storeLog = do
   lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
   doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SimpleX XFTP server v" <> simplexMQVersion]
+  r `shouldContain` ["SimpleX XFTP server v" <> simplexmqVersionCommit]
   r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Listening on port 443..."]
   capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath)

tests/CoreTests/BatchingTests.hs

@@ -47,6 +47,7 @@ batchingTests = do
       it "should batch with 135 subscriptions per batch" testClientBatchSubscriptions
       it "should batch with 255 ENDs per batch" testClientBatchENDs
       it "should batch with 80 NMSGs per batch" testClientBatchNMSGs
+      it "should batch subscription responses with message" testBatchSubResponses
       it "should break on message that does not fit" testClientBatchWithMessage
       it "should break on large message" testClientBatchWithLargeMessage
 
@@ -207,6 +208,20 @@ testClientBatchNMSGs = do
   (length rs1, length rs2, length rs3) `shouldBe` (40, 80, 80)
   all lenOk [s1, s2, s3] `shouldBe` True
 
+-- 4 responses are used in Simplex.Messaging.Server / `send`
+testBatchSubResponses :: IO ()
+testBatchSubResponses = do
+  client <- testClientStub
+  soks <- replicateM 4 $ randomSOK
+  msg <- randomMSG
+  let msgs = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks <> [msg])
+      batches = batchTransmissions (thParams client) $ L.fromList msgs
+  length batches `shouldBe` 1
+  soks' <- replicateM 5 $ randomSOK
+  let msgs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks' <> [msg])
+      batches' = batchTransmissions (thParams client) $ L.fromList msgs'
+  length batches' `shouldBe` 2
+
 testClientBatchWithMessageV6 :: IO ()
 testClientBatchWithMessageV6 = do
   client <- testClientStubV6
@@ -361,6 +376,22 @@ randomNMSGCmd ts = do
   Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128
   pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta)
 
+randomSOK :: IO (Transmission BrokerMsg)
+randomSOK = do
+  g <- C.newRandom
+  corrId <- atomically $ C.randomBytes 24 g
+  rId <- atomically $ C.randomBytes 24 g
+  pure (CorrId corrId, EntityId rId, SOK Nothing)
+
+randomMSG :: IO (Transmission BrokerMsg)
+randomMSG = do
+  g <- C.newRandom
+  corrId <- atomically $ C.randomBytes 24 g
+  rId <- atomically $ C.randomBytes 24 g
+  msgId <- atomically $ C.randomBytes 24 g
+  msg <- atomically $ C.randomBytes (maxMessageLength currentClientSMPRelayVersion) g
+  pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg})
+
 randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSENDv6 = randomSEND_ C.SEd25519 minServerSMPRelayVersion
 

tests/CoreTests/MsgStoreTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -23,9 +24,9 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
-import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
 import Data.List (isPrefixOf, isSuffixOf)
 import Data.Maybe (fromJust)
 import Data.Time.Clock (addUTCTime)
@@ -33,9 +34,9 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
 import Simplex.Messaging.Crypto (pattern MaxLenBS)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (EntityId (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags)
+import Simplex.Messaging.Protocol (EntityId (..), ErrorType, LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags)
 import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats)
-import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth, readWriteQueueStore)
+import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch)
 import Simplex.Messaging.Server.MsgStore.Journal
 import Simplex.Messaging.Server.MsgStore.STM
@@ -50,28 +51,54 @@ import System.IO (IOMode (..), withFile)
 import Test.Hspec hiding (fit, it)
 import Util
 
+#if defined(dbServerPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+import qualified Database.PostgreSQL.Simple as DB
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Server.MsgStore.Postgres
+import Simplex.Messaging.Server.QueueStore.Postgres
+import SMPClient (postgressBracket, testServerDBConnectInfo, testStoreDBOpts)
+#endif
+
 msgStoreTests :: Spec
 msgStoreTests = do
   around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests
   around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do
     someMsgStoreTests
+    journalMsgStoreTests
     it "should export and import journal store" testExportImportStore
-    describe "queue state" $ do
-      it "should restore queue state from the last line" testQueueState
-      it "should recover when message is written and state is not" testMessageState
-      it "should remove journal files when queue is empty" testRemoveJournals
-    describe "missing files" $ do
-      it "should create read file when missing" testReadFileMissing
-      it "should switch to write file when read file missing" testReadFileMissingSwitch
-      it "should create write file when missing" testWriteFileMissing
-      it "should create read file when read and write files are missing" testReadAndWriteFilesMissing
+#if defined(dbServerPostgres)
+  around_ (postgressBracket testServerDBConnectInfo) $ do
+    around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $
+      describe "Postgres+journal message store" $ do
+        someMsgStoreTests
+        journalMsgStoreTests
+    around (withMsgStore testPostgresStoreConfig) $
+      describe "Postgres-only message store" $ do
+        someMsgStoreTests
+        it "should correctly update message counts and canWrite flag" testUpdateMessageCounts
+        it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts
+#endif
   describe "Journal message store: queue state backup expiration" $ do
     it "should remove old queue state backups" testRemoveQueueStateBackups
     it "should expire messages in idle queues" testExpireIdleQueues
   where
+    journalMsgStoreTests :: SpecWith (JournalMsgStore s)
+    journalMsgStoreTests = do
+      describe "queue state" $ do
+        it "should restore queue state from the last line" testQueueState
+        it "should recover when message is written and state is not" testMessageState
+        it "should remove journal files when queue is empty" testRemoveJournals
+      describe "missing files" $ do
+        it "should create read file when missing" testReadFileMissing
+        it "should switch to write file when read file missing" testReadFileMissingSwitch
+        it "should create write file when missing" testWriteFileMissing
+        it "should create read file when read and write files are missing" testReadAndWriteFilesMissing
     someMsgStoreTests :: MsgStoreClass s => SpecWith s
     someMsgStoreTests = do
       it "should get queue and store/read messages" testGetQueue
+      it "should write/ack messages" testWriteAckMessages
       it "should not fail on EOF when changing read journal" testChangeReadJournal
 
 -- TODO constrain to STM stores?
@@ -96,6 +123,24 @@ testJournalStoreCfg queueStoreCfg =
       keepMinBackups = 1
     }
 
+#if defined(dbServerPostgres)
+testPostgresStoreConfig :: PostgresMsgStoreCfg
+testPostgresStoreConfig =
+  PostgresMsgStoreCfg
+    { queueStoreCfg = testPostgresStoreCfg,
+      quota = 3
+    }
+
+testPostgresStoreCfg :: PostgresStoreCfg
+testPostgresStoreCfg =
+  PostgresStoreCfg
+    { dbOpts = testStoreDBOpts,
+      dbStoreLogPath = Nothing,
+      confirmMigrations = MCYesUp,
+      deletedTTL = 86400
+    }
+#endif
+
 mkMessage :: MonadIO m => ByteString -> m Message
 mkMessage body = liftIO $ do
   g <- C.newRandom
@@ -138,7 +183,6 @@ testNewQueueRecData g qm queueData = do
   where
     rndId = atomically $ EntityId <$> C.randomBytes 24 g
 
--- TODO constrain to STM stores
 testGetQueue :: MsgStoreClass s => s -> IO ()
 testGetQueue ms = do
   g <- C.newRandom
@@ -181,7 +225,28 @@ testGetQueue ms = do
     (Nothing, Nothing) <- tryDelPeekMsg ms q mId8
     void $ ExceptT $ deleteQueue ms q
 
--- TODO constrain to STM stores
+-- TODO [messages] test concurrent writing and reading
+testWriteAckMessages :: MsgStoreClass s => s -> IO ()
+testWriteAckMessages ms = do
+  g <- C.newRandom
+  (rId1, qr1) <- testNewQueueRec g QMMessaging
+  (rId2, qr2) <- testNewQueueRec g QMMessaging
+  runRight_ $ do
+    q1 <- ExceptT $ addQueue ms rId1 qr1
+    q2 <- ExceptT $ addQueue ms rId2 qr2
+    let write q s = writeMsg ms q True =<< mkMessage s
+    0 <- deleteExpiredMsgs ms q1 0 -- won't expire anything, used here to mimic message sending with expiration on SEND
+    Just (Message {msgId = mId1}, True) <- write q1 "message 1"
+    (Msg "message 1", Nothing) <- tryDelPeekMsg ms q1 mId1
+    0 <- deleteExpiredMsgs ms q2 0
+    Just (Message {msgId = mId2}, True) <- write q2 "message 2"
+    (Msg "message 2", Nothing) <- tryDelPeekMsg ms q2 mId2
+    0 <- deleteExpiredMsgs ms q2 0
+    Just (Message {msgId = mId3}, True) <- write q2 "message 3"
+    (Msg "message 3", Nothing) <- tryDelPeekMsg ms q2 mId3
+    void $ ExceptT $ deleteQueue ms q1
+    void $ ExceptT $ deleteQueue ms q2
+
 testChangeReadJournal :: MsgStoreClass s => s -> IO ()
 testChangeReadJournal ms = do
   g <- C.newRandom
@@ -226,9 +291,16 @@ testExportImportStore ms = do
     pure ()
   length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
   length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3
-  exportMessages False ms testStoreMsgsFile False
+  exportMessages False (StoreJournal ms) testStoreMsgsFile False
   closeMsgStore ms
   closeStoreLog sl
+  -- export with closed queues and compare
+  ms2 <- newMsgStore $ testJournalStoreCfg MQStoreCfg
+  readWriteQueueStore True (mkQueue ms2 True) testStoreLogFile (stmQueueStore ms2) >>= closeStoreLog
+  exportMessages False (StoreJournal ms2) (testStoreMsgsFile <> ".copy") False
+  s <- B.readFile testStoreMsgsFile
+  B.readFile (testStoreMsgsFile <> ".copy") `shouldReturn` s
+
   let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2}
   ms' <- newMsgStore cfg
   readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (stmQueueStore ms') >>= closeStoreLog
@@ -237,21 +309,93 @@ testExportImportStore ms = do
   printMessageStats "Messages" stats
   length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
   length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- 2 message files
-  exportMessages False ms' testStoreMsgsFile2 False
+  exportMessages False (StoreJournal ms') testStoreMsgsFile2 False
   (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak")
   stmStore <- newMsgStore testSMTStoreConfig
   readWriteQueueStore True (mkQueue stmStore True) testStoreLogFile (queueStore stmStore) >>= closeStoreLog
   MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
     importMessages False stmStore testStoreMsgsFile2 Nothing False
-  exportMessages False stmStore testStoreMsgsFile False
+  exportMessages False (StoreMemory stmStore) testStoreMsgsFile False
   (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak"))
 
+#if defined(dbServerPostgres)
+testUpdateMessageCounts :: PostgresMsgStore -> IO ()
+testUpdateMessageCounts ms = do
+  g <- C.newRandom
+  (rId, qr) <- testNewQueueRec g QMMessaging
+  runRight_ $ do
+    q <- ExceptT $ addQueue ms rId qr
+    let write s = writeMsg ms q True =<< mkMessage s
+        hasSize = checkQueueSize ms
+    q `hasSize` (0, True, False)
+    Just (Message {msgId = mId1}, True) <- write "message 1"
+    q `hasSize` (1, True, True)
+    Just (Message {msgId = mId2}, False) <- write "message 2"
+    q `hasSize` (2, True, True)
+    Just (Message {msgId = mId3}, False) <- write "message 3"
+    q `hasSize` (3, True, True)
+    Nothing <- write "message 4"
+    q `hasSize` (4, False, True)
+    Msg "message 1" <- tryPeekMsg ms q
+    q `hasSize` (4, False, True)
+    Msg "message 1" <- tryDelMsg ms q mId1
+    q `hasSize` (3, False, True)
+    Msg "message 2" <- tryPeekMsg ms q
+    (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2
+    q `hasSize` (2, False, True)
+    (Msg "message 3", Just MessageQuota {msgId = mId4}) <- tryDelPeekMsg ms q mId3
+    q `hasSize` (1, False, True)
+    (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId4
+    q `hasSize` (0, True, False)
+
+checkQueueSize :: PostgresMsgStore -> PostgresQueue -> (Int64, Bool, Bool) -> ExceptT ErrorType IO ()
+checkQueueSize ms q (size, canWrt, expire) = liftIO $ do
+  [(size', canWrt', expire')] <-
+    withTransaction (dbStore $ queueStore ms) $ \db ->
+      DB.query db "SELECT msg_queue_size, msg_can_write, msg_queue_expire FROM msg_queues WHERE recipient_id = ?" (Only (recipientId q))
+  size' `shouldBe` size
+  canWrt' `shouldBe` canWrt
+  expire' `shouldBe` expire
+
+testResetMessageCounts :: PostgresMsgStore -> IO ()
+testResetMessageCounts ms = do
+  g <- C.newRandom
+  (rId, qr) <- testNewQueueRec g QMMessaging
+  runRight_ $ do
+    q <- ExceptT $ addQueue ms rId qr
+    let write s = writeMsg ms q True =<< mkMessage s
+        hasSize = checkQueueSize ms
+    Just (Message {msgId = mId1}, True) <- write "message 1"
+    Just (Message {msgId = mId2}, False) <- write "message 2"
+    Just (Message {msgId = mId3}, False) <- write "message 3"
+    Nothing <- write "message 4"
+    q `hasSize` (4, False, True)
+    liftIO $ setIncorrectSize q (10, True)
+    Nothing <- write "message 5"
+    q `hasSize` (11, False, True)
+    (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
+    q `hasSize` (10, False, True)
+    (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2
+    q `hasSize` (9, False, True)
+    (Msg "message 3", Just MessageQuota {msgId = mId4}) <- tryDelPeekMsg ms q mId3
+    q `hasSize` (8, False, True)
+    (Just MessageQuota {}, Just MessageQuota {msgId = mId5}) <- tryDelPeekMsg ms q mId4
+    q `hasSize` (7, False, True)
+    (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId5
+    q `hasSize` (0, True, False) -- reset
+  where
+    setIncorrectSize :: PostgresQueue -> (Int64, Bool) -> IO ()
+    setIncorrectSize q (size, canWrt) =
+      void $ withTransaction (dbStore $ queueStore ms) $ \db ->
+        DB.execute db "UPDATE msg_queues SET msg_queue_size = ?, msg_can_write = ? WHERE recipient_id = ?" (size, canWrt, recipientId q)
+#endif
+
 testQueueState :: JournalMsgStore s -> IO ()
 testQueueState ms = do
   g <- C.newRandom
   rId <- EntityId <$> atomically (C.randomBytes 24 g)
   let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
+      statePath = msgQueueStatePath dir rId
   createDirectoryIfMissing True dir
   state <- newMsgQueueState <$> newJournalId (random ms)
   withFile statePath WriteMode (`appendState` state)
@@ -312,7 +456,7 @@ testMessageState ms = do
   g <- C.newRandom
   (rId, qr) <- testNewQueueRec g QMMessaging
   let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
+      statePath = msgQueueStatePath dir rId
       write q s = writeMsg ms q True =<< mkMessage s
 
   mId1 <- runRight $ do
@@ -337,7 +481,7 @@ testRemoveJournals ms = do
   g <- C.newRandom
   (rId, qr) <- testNewQueueRec g QMMessaging
   let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
+      statePath = msgQueueStatePath dir rId
       write q s = writeMsg ms q True =<< mkMessage s
 
   runRight $ do
@@ -361,7 +505,7 @@ testRemoveJournals ms = do
     Nothing <- tryPeekMsg ms q
     -- still not removed, queue is empty and not opened
     liftIO $ journalFilesCount dir `shouldReturn` 1
-    _mq <- isolateQueue q "test" $ getMsgQueue ms q False
+    _mq <- isolateQueue ms q "test" $ getMsgQueue ms q False
     -- journal is removed
     liftIO $ journalFilesCount dir `shouldReturn` 0
     liftIO $ stateBackupCount dir `shouldReturn` 1
@@ -442,7 +586,7 @@ testExpireIdleQueues = do
   ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0}
 
   let dir = msgQueueDirectory ms rId
-      statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
+      statePath = msgQueueStatePath dir rId
       write q s = writeMsg ms q True =<< mkMessage s
 
   q <- runRight $ do
@@ -461,7 +605,7 @@ testExpireIdleQueues = do
   old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages
   now <- systemSeconds <$> getSystemTime
 
-  (expired_, stored) <- runRight $ isolateQueue q "" $ withIdleMsgQueue now ms q $ deleteExpireMsgs_ old q
+  (expired_, stored) <- runRight $ isolateQueue ms q "" $ withIdleMsgQueue now ms q $ deleteExpireMsgs_ old q
   expired_ `shouldBe` Just 0
   stored `shouldBe` 0
   (Nothing, False) <- readQueueState ms statePath
@@ -478,7 +622,7 @@ testReadFileMissing ms = do
     Msg "message 1" <- tryPeekMsg ms q
     pure q
 
-  mq <- fromJust <$> readTVarIO (msgQueue q)
+  mq <- fromJust <$> readTVarIO (msgQueue' q)
   MsgQueueState {readState = rs} <- readTVarIO $ state mq
   closeMsgQueue ms q
   let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
@@ -497,7 +641,7 @@ testReadFileMissingSwitch ms = do
   (rId, qr) <- testNewQueueRec g QMMessaging
   q <- writeMessages ms rId qr
 
-  mq <- fromJust <$> readTVarIO (msgQueue q)
+  mq <- fromJust <$> readTVarIO (msgQueue' q)
   MsgQueueState {readState = rs} <- readTVarIO $ state mq
   closeMsgQueue ms q
   let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
@@ -515,7 +659,7 @@ testWriteFileMissing ms = do
   (rId, qr) <- testNewQueueRec g QMMessaging
   q <- writeMessages ms rId qr
 
-  mq <- fromJust <$> readTVarIO (msgQueue q)
+  mq <- fromJust <$> readTVarIO (msgQueue' q)
   MsgQueueState {writeState = ws} <- readTVarIO $ state mq
   closeMsgQueue ms q
   let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws
@@ -538,7 +682,7 @@ testReadAndWriteFilesMissing ms = do
   (rId, qr) <- testNewQueueRec g QMMessaging
   q <- writeMessages ms rId qr
 
-  mq <- fromJust <$> readTVarIO (msgQueue q)
+  mq <- fromJust <$> readTVarIO (msgQueue' q)
   MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq
   closeMsgQueue ms q
   removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs

tests/CoreTests/SOCKSSettings.hs

@@ -91,7 +91,7 @@ testSocksMode = do
   where
     transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
     transportSocksCfg cfg host =
-      let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing
+      let TransportClientConfig {socksProxy} = transportClientConfig cfg NRMInteractive host False Nothing
        in socksProxy
 
 testSocksProxyEncoding :: Spec

tests/CoreTests/UtilTests.hs

@@ -45,56 +45,32 @@ utilTests = do
         runExceptT (throwTestException `catchError` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
   describe "tryAllErrors" $ do
     it "should return ExceptT error as Left" $
-      runExceptT (tryAllErrors testErr throwTestError) `shouldReturn` Right (Left (TestError "error"))
+      runExceptT (tryAllErrors throwTestError) `shouldReturn` Right (Left (TestError "error"))
     it "should return SomeException as Left" $
-      runExceptT (tryAllErrors testErr throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
+      runExceptT (tryAllErrors throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
     it "should return no errors as Right" $
-      runExceptT (tryAllErrors testErr noErrors) `shouldReturn` Right (Right "no errors")
-  describe "tryAllErrors specialized as tryTestError" $ do
-    let tryTestError = tryAllErrors testErr
-    it "should return ExceptT error as Left" $
-      runExceptT (tryTestError throwTestError) `shouldReturn` Right (Left (TestError "error"))
-    it "should return SomeException as Left" $
-      runExceptT (tryTestError throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
-    it "should return no errors as Right" $
-      runExceptT (tryTestError noErrors) `shouldReturn` Right (Right "no errors")
+      runExceptT (tryAllErrors noErrors) `shouldReturn` Right (Right "no errors")
   describe "catchAllErrors" $ do
     it "should catch ExceptT error" $
-      runExceptT (catchAllErrors testErr throwTestError handleCatch) `shouldReturn` Right "caught TestError \"error\""
+      runExceptT (throwTestError `catchAllErrors` handleCatch) `shouldReturn` Right "caught TestError \"error\""
     it "should catch SomeException" $
-      runExceptT (catchAllErrors testErr throwTestException handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
+      runExceptT (throwTestException `catchAllErrors` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
     it "should not throw if there are no errors" $
-      runExceptT (catchAllErrors testErr noErrors throwError) `shouldReturn` Right "no errors"
-  describe "catchAllErrors specialized as catchTestError" $ do
-    let catchTestError = catchAllErrors testErr
-    it "should catch ExceptT error" $
-      runExceptT (throwTestError `catchTestError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
-    it "should catch SomeException" $
-      runExceptT (throwTestException `catchTestError` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
-    it "should not throw if there are no errors" $
-      runExceptT (noErrors `catchTestError` throwError) `shouldReturn` Right "no errors"
+      runExceptT (noErrors `catchAllErrors` throwError) `shouldReturn` Right "no errors"
   describe "catchThrow" $ do
     it "should re-throw ExceptT error" $
-      runExceptT (throwTestError `catchThrow` testErr) `shouldReturn` Left (TestError "error")
+      runExceptT (throwTestError `catchThrow` fromSomeException) `shouldReturn` Left (TestError "error")
     it "should catch SomeException and throw as ExceptT error" $
-      runExceptT (throwTestException `catchThrow` testErr) `shouldReturn` Left (TestException "user error (error)")
+      runExceptT (throwTestException `catchThrow` fromSomeException) `shouldReturn` Left (TestException "user error (error)")
     it "should not throw if there are no exceptions" $
-      runExceptT (noErrors `catchThrow` testErr) `shouldReturn` Right "no errors"
+      runExceptT (noErrors `catchThrow` fromSomeException) `shouldReturn` Right "no errors"
   describe "allFinally should run final action" $ do
     it "then throw ExceptT error" $ withFinal $ \final ->
-      runExceptT (allFinally testErr throwTestError final) `shouldReturn` Left (TestError "error")
+      runExceptT (throwTestError `allFinally` final) `shouldReturn` Left (TestError "error")
     it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
-      runExceptT (allFinally testErr throwTestException final) `shouldReturn` Left (TestException "user error (error)")
+      runExceptT (throwTestException `allFinally` final) `shouldReturn` Left (TestException "user error (error)")
     it "and should not throw if there are no exceptions" $ withFinal $ \final ->
-      runExceptT (allFinally testErr noErrors final) `shouldReturn` Right "no errors"
-  describe "allFinally specialized as testFinally should run final action" $ do
-    let testFinally = allFinally testErr
-    it "then throw ExceptT error" $ withFinal $ \final ->
-      runExceptT (throwTestError `testFinally` final) `shouldReturn` Left (TestError "error")
-    it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
-      runExceptT (throwTestException `testFinally` final) `shouldReturn` Left (TestException "user error (error)")
-    it "and should not throw if there are no exceptions" $ withFinal $ \final ->
-      runExceptT (noErrors `testFinally` final) `shouldReturn` Right "no errors"
+      runExceptT (noErrors `allFinally` final) `shouldReturn` Right "no errors"
   where
     throwTestError :: ExceptT TestError IO String
     throwTestError = throwError $ TestError "error"
@@ -102,8 +78,6 @@ utilTests = do
     throwTestException = liftIO $ throwIO $ userError "error"
     noErrors :: ExceptT TestError IO String
     noErrors = pure "no errors"
-    testErr :: SomeException -> TestError
-    testErr = TestException . show
     handleCatch :: TestError -> ExceptT TestError IO String
     handleCatch e = pure $ "caught " <> show e
     handleException :: SomeException -> ExceptT TestError IO String
@@ -119,3 +93,6 @@ data TestError = TestError String | TestException String
   deriving (Eq, Show)
 
 instance Exception TestError
+
+instance AnyError TestError where
+  fromSomeException = TestException . show

tests/PostgresSchemaDump.hs

@@ -12,7 +12,7 @@ import Data.Maybe (fromJust, isJust)
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
 import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -30,12 +30,12 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
     testVerifySchemaDump = do
       savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "")
       savedSchema `deepseq` pure ()
-      void $ createDBStore testDBOpts migrations MCConsole
+      void $ createDBStore testDBOpts migrations (MigrationConfig MCConsole Nothing)
       getSchema srcSchemaPath `shouldReturn` savedSchema
 
     testSchemaMigrations = do
       let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations
-      Right st <- createDBStore testDBOpts noDownMigrations MCError
+      Right st <- createDBStore testDBOpts noDownMigrations (MigrationConfig MCError Nothing)
       mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations
       closeDBStore st
       whenM (doesFileExist testSchemaPath) $ removeFile testSchemaPath
@@ -65,6 +65,6 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
       void $ readCreateProcess (shell cmd) ""
       threadDelay 20000
       let sed = (if ci then "sed -i" else "sed -i ''")
-      void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) ""
+      void $ readCreateProcess (shell $ sed <> " '/^--/d; /^\\\\restrict/d; /^\\\\unrestrict/d' " <> schemaPath) ""
       sch <- readFile schemaPath
       sch `deepseq` pure sch

tests/SMPAgentClient.hs

@@ -19,7 +19,7 @@ import SMPClient (proxyVRangeV8, ntfTestPort, testPort)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
+import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
 import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
 import Simplex.Messaging.Transport
@@ -64,7 +64,7 @@ initAgentServers =
     { smp = userServers [testSMPServer],
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
-      netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000},
+      netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
       presetDomains = []
     }
 
@@ -96,7 +96,7 @@ agentCfg =
       certificateFile = "tests/fixtures/server.crt"
     }
   where
-    networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
+    networkConfig = defaultNetworkConfig {tcpConnectTimeout = NetworkTimeout 1_000000 1_000000, tcpTimeout = NetworkTimeout 2_000000 2_000000}
 
 agentProxyCfgV8 :: AgentConfig
 agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}}

tests/SMPClient.hs

@@ -226,8 +226,10 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
       newQueueBasicAuth = Nothing,
       controlPortUserAuth = Nothing,
       controlPortAdminAuth = Nothing,
+      dailyBlockQueueQuota = 20,
       messageExpiration = Just defaultMessageExpiration,
       expireMessagesOnStart = True,
+      expireMessagesOnSend = False,
       idleQueueInterval = defaultIdleQueueInterval,
       notificationExpiration = defaultNtfExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
@@ -272,9 +274,14 @@ serverStoreConfig_ useDbStoreLog = \case
   ASType SQSMemory SMSJournal ->
     ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir}
   ASType SQSPostgres SMSJournal ->
-    let dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
-        storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
-     in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
+    ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
+#if defined(dbServerPostgres)
+  ASType SQSPostgres SMSPostgres ->
+    ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg
+#endif
+  where
+    dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
+    storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
 
 cfgV7 :: AServerConfig
 cfgV7 = updateCfg cfg $ \cfg' -> cfg' {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion}

tests/SMPProxyTests.hs

@@ -167,37 +167,37 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
   g <- C.newRandom
   -- set up proxy
   ts <- getCurrentTime
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
+  pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- set up relay
   msgQ <- newTBQueueIO 1024
-  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
+  rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
   rc <- either (fail . show) pure rc'
   -- prepare receiving queue
   (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
   (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-  SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing)
+  SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing
   let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
   -- get proxy session
-  sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
-  sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
+  sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
+  sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
   sess0 `shouldBe` sess
   -- send via proxy to unsecured queue
   forM_ unsecuredMsgs $ \msg -> do
-    runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
-    runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
+    runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
+    runExceptT' (proxySMPMessage pc NRMInteractive sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
     -- receive 1
     (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ
     dec msgId encBody `shouldBe` Right msg
     runExceptT' $ ackSMPMessage rc rPriv rcvId msgId
   -- secure queue
   (sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
-  runExceptT' $ secureSMPQueue rc rPriv rcvId sPub
+  runExceptT' $ secureSMPQueue rc NRMInteractive rPriv rcvId sPub
   -- send via proxy to secured queue
   waitSendRecv
     ( forM_ securedMsgs $ \msg' ->
-        runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
+        runExceptT' (proxySMPMessage pc NRMInteractive sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
     )
     ( forM_ securedMsgs $ \msg' -> do
         (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ
@@ -210,12 +210,12 @@ proxyConnectDeadRelay n d proxyServ = do
   g <- C.newRandom
   -- set up proxy
   ts <- getCurrentTime
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
+  pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- get proxy session
   replicateM_ n $ do
-    sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct")
+    sess0 <- runExceptT $ connectSMPProxiedRelay pc NRMInteractive (SMPServer testHost "45678" testKeyHash) (Just "correct")
     case sess0 of
       Right !_noWay -> error "got unexpected client"
       Left !_err -> threadDelay d
@@ -224,9 +224,9 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty
 agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
-      (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+      (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
       aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-      (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -280,9 +280,9 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- agent connections have to be set up in advance
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
-      (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+      (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
       aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-      (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       confId <-
         get alice >>= \case
@@ -331,9 +331,9 @@ agentViaProxyVersionError =
   withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
     Left (A.BROKER _ (TRANSPORT TEVersion)) <-
       withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
-        (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+        (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
         aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-        A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+        A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     pure ()
   where
     servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs}
@@ -351,9 +351,9 @@ agentViaProxyRetryOffline = do
       let pqEnc = CR.PQEncOn
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
-          (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+          (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
           aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-          (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+          (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
           liftIO $ sqSecured `shouldBe` True
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
           liftIO $ pqSup' `shouldBe` PQSupportOn

tests/ServerTests.hs

@@ -14,10 +14,12 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module ServerTests where
 
 import Control.Concurrent (ThreadId, killThread, threadDelay)
+import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, throwIO, try)
 import Control.Monad
@@ -29,6 +31,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Hashable (hash)
 import qualified Data.IntSet as IS
+import Data.List.NonEmpty (NonEmpty)
 import Data.String (IsString (..))
 import Data.Type.Equality
 import qualified Data.X509.Validation as XV
@@ -40,10 +43,10 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (exportMessages)
-import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
+import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore)
-import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..), newMsgStore)
+import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SMSType (..), SQSType (..), newMsgStore)
 import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
 import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
 import Simplex.Messaging.Transport
@@ -57,6 +60,11 @@ import Test.HUnit
 import Test.Hspec hiding (fit, it)
 import Util
 
+#if defined(dbServerPostgres)
+import CoreTests.MsgStoreTests (testPostgresStoreConfig)
+import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages)
+#endif
+
 serverTests :: SpecWith (ASrvTransport, AStoreType)
 serverTests = do
   describe "SMP queues" $ do
@@ -75,6 +83,7 @@ serverTests = do
     describe "GET command" testGetCommand
     describe "GET & SUB commands" testGetSubCommands
     describe "Exceeding queue quota" testExceedQueueQuota
+    describe "Concurrent sending and delivery" testConcurrentSendDelivery
   describe "Store log" testWithStoreLog
   describe "Restore messages" testRestoreMessages
   describe "Restore messages (old / v2)" testRestoreExpireMessages
@@ -83,6 +92,7 @@ serverTests = do
   describe "Message notifications" $ do
     testMessageNotifications
     testMessageServiceNotifications
+    testServiceNotificationsTwoRestarts
   describe "Message expiration" $ do
     testMsgExpireOnSend
     testMsgExpireOnInterval
@@ -96,10 +106,10 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> Transmission (Either ErrorType
 pattern Resp corrId queueId command <- (corrId, queueId, Right command)
 
 pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Creator
-pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)))
+pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing)
 
 pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
-pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing)
+pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing Nothing)
 
 pattern Msg :: MsgId -> MsgBody -> BrokerMsg
 pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
@@ -111,16 +121,25 @@ sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do
   tGet1 h
 
 signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
-signSendRecv h pk = signSendRecv_ h pk Nothing
+signSendRecv h pk t = do
+  [r] <- signSendRecv_ h pk Nothing t
+  pure r
+
+signSendRecv2 :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg), Transmission (Either ErrorType BrokerMsg))
+signSendRecv2 h pk t = do
+  [r1, r2] <- signSendRecv_ h pk Nothing t
+  pure (r1, r2)
 
 serviceSignSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
-serviceSignSendRecv h pk = signSendRecv_ h pk . Just
+serviceSignSendRecv h pk serviceKey t = do
+  [r] <- signSendRecv_ h pk (Just serviceKey) t
+  pure r
 
-signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
+signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
 signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (authorize tForAuth, tToSend)
-  tGet1 h
+  liftIO $ tGetClient h
   where
     authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
       C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t'
@@ -282,7 +301,7 @@ testSndSecureProhibited =
       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 (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing))))
+      Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
       (rId1, NoEntity) #== "creates queue"
 
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
@@ -297,7 +316,7 @@ testCreateUpdateKeys =
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing))))
+      Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
       (rPub', rKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       Resp "2" rId1 OK <- signSendRecv h rKey ("2", rId, RKEY [rPub, rPub'])
       rId1 `shouldBe` rId
@@ -365,7 +384,7 @@ testCreateDelete =
       Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)
       (ok4, OK) #== "accepts OFF when suspended"
 
-      Resp "cdab" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
+      (Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 rh rKey ("cdab", rId, SUB)
       (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
 
       Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)
@@ -404,7 +423,7 @@ stressTest =
         Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, New rPub dhPub)
         pure rId
       let subscribeQueues h = forM_ rIds $ \rId -> do
-            Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
+            Resp "" rId' (SOK Nothing) <- signSendRecv h rKey ("", rId, SUB)
             rId' `shouldBe` rId
       closeConnection $ connection h1
       subscribeQueues h2
@@ -497,7 +516,7 @@ testSwitchSub =
       Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
       (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
 
-      Resp "bcda" _ (Msg mId2' msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)
+      (Resp "bcda" _ (SOK Nothing), Resp "" _ (Msg mId2' msg2')) <- signSendRecv2 rh2 rKey ("bcda", rId, SUB)
       (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
       Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
 
@@ -620,6 +639,27 @@ testExceedQueueQuota =
         Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
         pure ()
 
+testConcurrentSendDelivery :: SpecWith (ASrvTransport, AStoreType)
+testConcurrentSendDelivery =
+  it "should continue delivering messages if message is sent before it is acknowledged" $ \(ATransport t, msType) -> do
+    g <- C.newRandom
+    smpTest3 t msType $ \rh sh1 sh2 -> do
+      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+      (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
+      let dec = decryptMsgV3 dhShared
+          sndMsg sh n = do
+            Resp (CorrId n') _ OK <- signSendRecv sh sKey (n, sId, _SEND ("msg " <> n))
+            n' `shouldBe` n
+          isMsg1or2 mId msg = dec mId msg == Right "msg 1" || dec mId msg == Right "msg 2" `shouldBe` True
+      replicateM_ 50 $ do
+        concurrently_ (sndMsg sh1 "1") (sndMsg sh2 "2")
+        Resp "" _ (Msg mId1 msg1) <- tGet1 rh
+        isMsg1or2 mId1 msg1
+        Resp "3" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("3", rId, ACK mId1)
+        isMsg1or2 mId2 msg2
+        Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, ACK mId2)
+        pure ()
+
 testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
 testWithStoreLog =
   it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do
@@ -684,7 +724,7 @@ testWithStoreLog =
       nId <- readTVarIO notifierId
       Resp "dabc" _ (SOK Nothing) <- signSendRecv h1 nKey ("dabc", nId, NSUB)
       Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
-      Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
+      (Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId3 msg3)) <- signSendRecv2 h rKey1 ("cdab", rId1, SUB)
       (decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
       Resp "" _ (NMSG _ _) <- tGet1 h1
       -- this queue is removed - not restored
@@ -762,14 +802,14 @@ testRestoreMessages =
       pure ()
     rId <- readTVarIO recipientId
     logSize testStoreLogFile `shouldReturn` 2
-    logSize testServerStatsBackupFile `shouldReturn` 94
+    logSize testServerStatsBackupFile `shouldReturn` 95
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
     withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
       let dec = decryptMsgV3 dh
-      Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
+      (Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 h rKey ("2", rId, SUB)
       (dec mId2 msg2, Right "hello 2") #== "restored message delivered"
       Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
       (dec mId3 msg3, Right "hello 3") #== "restored message delivered"
@@ -778,7 +818,7 @@ testRestoreMessages =
     logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
     -- the last message is not removed because it was not ACK'd
     -- logSize testStoreMsgsFile `shouldReturn` 3
-    logSize testServerStatsBackupFile `shouldReturn` 94
+    logSize testServerStatsBackupFile `shouldReturn` 95
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
@@ -786,7 +826,7 @@ testRestoreMessages =
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
       let dec = decryptMsgV3 dh
-      Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB)
+      (Resp "4" _ (SOK Nothing), Resp "" _ (Msg mId4 msg4)) <- signSendRecv2 h rKey ("4", rId, SUB)
       (dec mId4 msg4, Right "hello 4") #== "restored message delivered"
       Resp "5" _ (Msg mId5 msg5) <- signSendRecv h rKey ("5", rId, ACK mId4)
       (dec mId5 msg5, Right "hello 5") #== "restored message delivered"
@@ -796,7 +836,7 @@ testRestoreMessages =
       pure ()
     logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
     removeFile testStoreLogFile
-    logSize testServerStatsBackupFile `shouldReturn` 94
+    logSize testServerStatsBackupFile `shouldReturn` 95
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
     removeFileIfExists testStoreMsgsFile
@@ -881,14 +921,27 @@ testRestoreExpireMessages =
     exportStoreMessages :: AStoreType -> IO ()
     exportStoreMessages = \case
       ASType _ SMSJournal -> export
+      ASType _ SMSPostgres -> exportDB
       ASType _ SMSMemory -> pure ()
       where
         export = do
-          ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {quota = 4}
+          ms <- readWriteQueues
+          exportMessages False (StoreJournal ms) testStoreMsgsFile False
+          closeMsgStore ms
+#if defined(dbServerPostgres)
+        exportDB = do
+          readWriteQueues >>= closeMsgStore
+          ms' <- newMsgStore (testPostgresStoreConfig {quota = 4} :: PostgresMsgStoreCfg)
+          _n <- withFile testStoreMsgsFile WriteMode $ exportDbMessages False ms'
+          closeMsgStore ms'
+#else
+        exportDB = error "compiled without server_postgres flag"
+#endif
+        readWriteQueues = do
+          ms <- newMsgStore ((testJournalStoreCfg MQStoreCfg) {quota = 4} :: JournalStoreConfig 'QSMemory)
           readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog
           removeFileIfExists testStoreMsgsFile
-          exportMessages False ms testStoreMsgsFile False
-          closeMsgStore ms
+          pure ms
     runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
@@ -921,7 +974,7 @@ testTiming =
     forM_ timingTests $ \tst ->
       it (testName tst) $ \(ATransport t, msType) ->
         smpTest2Cfg (cfgMS msType) (mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion) t $ \rh sh ->
-          testSameTiming rh sh tst
+          testSameTiming rh sh tst msType
   where
     testName :: (C.AuthAlg, C.AuthAlg, Int) -> String
     testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, _) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg]
@@ -938,11 +991,16 @@ testTiming =
         (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
       ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2
-      | t1 <= t2 = abs (1 - t1 / t2) < 0.3 -- normally the difference between "no queue" and "wrong key" is less than 5%
-      | otherwise = similarTime t2 t1
-    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
+    similarTime t1 t2 msType
+      | t1 <= t2 = abs (1 - t1 / t2) < diff
+      | otherwise = similarTime t2 t1 msType
+      where
+        -- normally the difference between "no queue" and "wrong key" is less than 5%, but it's higher on PostgreSQL and on CI
+        diff = case msType of
+          ASType SQSPostgres _ -> 0.45
+          _ -> 0.3
+    testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> AStoreType -> Expectation
+    testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) msType = do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
@@ -977,7 +1035,7 @@ testTiming =
           timeNoQueue <- timeRepeat n $ do
             Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
             return ()
-          let ok = similarTime timeNoQueue timeWrongKey
+          let ok = similarTime timeNoQueue timeWrongKey msType
           unless ok . putStrLn . unwords $
             [ show goodKeyAlg,
               show badKeyAlg,
@@ -1053,7 +1111,6 @@ testMessageServiceNotifications =
       (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
       Resp "1" _ (NID nId _) <- signSendRecv rh rKey ("1", rId, NKEY nPub rcvNtfPubDhKey)
       serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g
-      -- TODO [certs] we need to get certificate fingerprint and include it into signed over for NSUB commands
       testNtfServiceClient t serviceKeys $ \nh1 -> do
         -- can't subscribe without service signature in service connection
         Resp "2a" _ (ERR SERVICE) <- signSendRecv nh1 nKey ("2a", nId, NSUB)
@@ -1117,12 +1174,57 @@ testMessageServiceNotifications =
         Resp "" _ (NMSG _ _) <- tGet1 nh
         pure ()
 
+testServiceNotificationsTwoRestarts :: SpecWith (ASrvTransport, AStoreType)
+testServiceNotificationsTwoRestarts =
+  it "subscribe notifier as service and deliver notifications after two restarts" $ \ps@(ATransport t, _) -> do
+    g <- C.newRandom
+    (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+    (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+    serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g
+    (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g
+    (rId, rKey, sId, dec, serviceId) <- withSmpServerStoreLogOn ps testPort $ runTest2 t $ \sh rh -> do
+      (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
+      let dec = decryptMsgV3 dhShared
+      Resp "0" _ (NID nId _) <- signSendRecv rh rKey ("0", rId, NKEY nPub rcvNtfPubDhKey)
+      testNtfServiceClient t serviceKeys $ \nh -> do
+        Resp "1" _ (SOK (Just serviceId)) <- serviceSignSendRecv nh nKey servicePK ("1", nId, NSUB)
+        deliverMessage rh rId rKey sh sId sKey nh "hello" dec
+        pure (rId, rKey, sId, dec, serviceId)
+    threadDelay 250000
+    withSmpServerStoreLogOn ps testPort $ runTest2 t $ \sh rh ->
+      testNtfServiceClient t serviceKeys $ \nh -> do
+        Resp "2.1" serviceId' (SOKS n) <- signSendRecv nh (C.APrivateAuthKey C.SEd25519 servicePK) ("2.1", serviceId, NSUBS)
+        n `shouldBe` 1
+        Resp "2.2" _ (SOK Nothing) <- signSendRecv rh rKey ("2.2", rId, SUB)
+        serviceId' `shouldBe` serviceId
+        deliverMessage rh rId rKey sh sId sKey nh "hello 2" dec
+    threadDelay 250000
+    withSmpServerStoreLogOn ps testPort $ runTest2 t $ \sh rh ->
+      testNtfServiceClient t serviceKeys $ \nh -> do
+        Resp "3.1" _ (SOKS n) <- signSendRecv nh (C.APrivateAuthKey C.SEd25519 servicePK) ("3.1", serviceId, NSUBS)
+        n `shouldBe` 1
+        Resp "3.2" _ (SOK Nothing) <- signSendRecv rh rKey ("3.2", rId, SUB)
+        deliverMessage rh rId rKey sh sId sKey nh "hello 3" dec
+    where
+      runTest2 :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
+      runTest2 _ test' server = do
+        a <- testSMPClient $ \h1 -> testSMPClient $ \h2 -> test' h1 h2
+        killThread server
+        pure a
+      deliverMessage rh rId rKey sh sId sKey nh msgText dec = do
+        Resp "msg-1" _ OK <- signSendRecv sh sKey ("msg-1", sId, _SEND' msgText)
+        Resp "" _ (Msg mId msg) <- tGet1 rh
+        Resp "msg-2" _ OK <- signSendRecv rh rKey ("msg-2", rId, ACK mId)
+        (dec mId msg, Right msgText) #== "delivered from queue"
+        Resp "" _ (NMSG _ _) <- tGet1 nh
+        pure ()
+
 testMsgExpireOnSend :: SpecWith (ASrvTransport, AStoreType)
 testMsgExpireOnSend =
   it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
+    let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {expireMessagesOnSend = True, messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
@@ -1131,7 +1233,7 @@ testMsgExpireOnSend =
         threadDelay 2500000
         Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)")
         testSMPClient @c $ \rh -> do
-          Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB)
+          (Resp "3" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("3", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
           1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
@@ -1139,8 +1241,7 @@ testMsgExpireOnSend =
 
 testMsgExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
 testMsgExpireOnInterval =
-  -- fails on ubuntu
-  xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
+  it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
@@ -1151,7 +1252,7 @@ testMsgExpireOnInterval =
         threadDelay 3000000
         testSMPClient @c $ \rh -> do
           signSendRecv rh rKey ("2", rId, SUB) >>= \case
-            Resp "2" _ OK -> pure ()
+            Resp "2" _ (SOK Nothing) -> pure ()
             r -> unexpected r
           1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
@@ -1170,7 +1271,7 @@ testMsgNOTExpireOnInterval =
         Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should NOT expire)")
         threadDelay 2500000
         testSMPClient @c $ \rh -> do
-          Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB)
+          (Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("2", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
           1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
@@ -1215,9 +1316,9 @@ testInvQueueLinkData =
           qrd = QRMessaging $ Just (sId, ld)
       -- sender ID must be derived from corrId
       Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
-        signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
-      Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing)) <-
-        signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
+        signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
+      Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing Nothing)) <-
+        signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
       (sId', sId) #== "should return the same sender ID"
       corrId' `shouldBe` CorrId corrId
       -- can't read link data with LGET
@@ -1272,9 +1373,9 @@ testContactQueueLinkData =
           qrd = QRContact $ Just (lnkId, (sId, ld))
       -- sender ID must be derived from corrId
       Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
-        signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
-      Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing)) <-
-        signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
+        signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
+      Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing Nothing)) <-
+        signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
       (lnkId', lnkId) #== "should return the same link ID"
       (sId', sId) #== "should return the same sender ID"
       corrId' `shouldBe` CorrId corrId
@@ -1346,8 +1447,8 @@ serverSyntaxTests (ATransport t) = do
   describe "NEW" $ do
     it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
     it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
-    it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
-    it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
+    it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
+    it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
   describe "KEY" $ do
     it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)
     it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)

tests/Test.hs

@@ -102,9 +102,11 @@ main = do
               ] -- skipComparisonForDownMigrations
               testStoreDBOpts
               "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
-        aroundAll_ (postgressBracket testServerDBConnectInfo) $
+        around_ (postgressBracket testServerDBConnectInfo) $ do
           describe "SMP server via TLS, postgres+jornal message store" $
             before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
+          describe "SMP server via TLS, postgres-only message store" $
+            before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests
 #endif
         describe "SMP server via TLS, jornal message store" $ do
           describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
@@ -122,16 +124,21 @@ main = do
               [] -- skipComparisonForDownMigrations
               ntfTestStoreDBOpts
               "src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
-        aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ do
+        around_ (postgressBracket ntfTestServerDBConnectInfo) $ do
           describe "Notifications server (SMP server: jornal store)" $
             ntfServerTests (transport @TLS, ASType SQSMemory SMSJournal)
-          aroundAll_ (postgressBracket testServerDBConnectInfo) $
+          around_ (postgressBracket testServerDBConnectInfo) $ do
             describe "Notifications server (SMP server: postgres+jornal store)" $
               ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal)
-        aroundAll_ (postgressBracket testServerDBConnectInfo) $ do
+            describe "Notifications server (SMP server: postgres-only store)" $
+              ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
+        around_ (postgressBracket testServerDBConnectInfo) $ do
           describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
+          describe "SMP client agent, postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres)
           describe "SMP proxy, postgres+jornal message store" $
             before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
+          describe "SMP proxy, postgres-only message store" $
+            before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
 #endif
         describe "SMP client agent, jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
         describe "SMP proxy, jornal message store" $

tests/XFTPAgent.hs

@@ -33,11 +33,12 @@ import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFi
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
 import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
+import Simplex.Messaging.Client (pattern NRMInteractive)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import Simplex.Messaging.Util (tshow)
 import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
@@ -83,7 +84,7 @@ xftpAgentTests =
         it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
         let srv1 = testXFTPServer2 {keyHash = "1234"}
         it "should fail with incorrect fingerprint" $ do
-          testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+          testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
         describe "server with password" $ do
           let auth = Just "abcd"
               srv = ProtoServerWithAuth testXFTPServer2
@@ -674,4 +675,4 @@ testXFTPServerTest newFileBasicAuth srv =
   withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
     -- initially passed server is not running
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
-      testProtocolServer a 1 srv
+      testProtocolServer a NRMInteractive 1 srv

tests/XFTPClient.hs

@@ -99,6 +99,9 @@ testXFTPLogFile = "tests/tmp/xftp-server-store.log"
 testXFTPStatsBackupFile :: FilePath
 testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
 
+xftpTestPrometheusMetricsFile :: FilePath
+xftpTestPrometheusMetricsFile = "tests/tmp/xftp-server-metrics.txt"
+
 testXFTPServerConfig :: XFTPServerConfig
 testXFTPServerConfig =
   XFTPServerConfig
@@ -127,6 +130,8 @@ testXFTPServerConfig =
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
+      prometheusInterval = Nothing,
+      prometheusMetricsFile = xftpTestPrometheusMetricsFile,
       transportConfig = mkTransportServerConfig True (Just alpnSupportedXFTPhandshakes) False,
       responseDelay = 0
     }
@@ -140,6 +145,6 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig
 testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
 testXFTPClientWith cfg client = do
   ts <- getCurrentTime
-  getXFTPClient (1, testXFTPServer, Nothing) cfg ts (\_ -> pure ()) >>= \case
+  getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case
     Right c -> client c
     Left e -> error $ show e

tests/XFTPServerTests.hs

@@ -223,7 +223,7 @@ testInactiveClientExpiration :: Expectation
 testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
   disconnected <- newEmptyTMVarIO
   ts <- liftIO getCurrentTime
-  c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig ts (\_ -> atomically $ putTMVar disconnected ())
+  c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ())
   pingXFTP c
   liftIO $ do
     threadDelay 100000