sync between tests

.github/workflows/build.yml

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

.github/workflows/reproduce-schedule.yml

@@ -25,7 +25,7 @@ jobs:
 
       - name: Execute reproduce script
         run: |
-          ${GITHUB_WORKSPACE}/scripts/simplexmq-reproduce-builds.sh "$TAG" || :
+          ${GITHUB_WORKSPACE}/scripts/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}-simplexmq/_sha256sums" ]; then
+          if [ -f "${GITHUB_WORKSPACE}/$TAG/_sha256sums" ]; then
             exit 0
           else
             curl --proto '=https' --tlsv1.2 -sSf \

CHANGELOG.md

@@ -1,61 +1,3 @@
-# 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:
@@ -76,7 +18,7 @@ Servers:
 - update script (simplex-servers-update) downloads scripts from the specified or the latest stable tag.
 
 SMP server:
-- support for PostgreSQL database for queue records for higher traffic servers.
+- support for PostrgreSQL 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):
@@ -132,7 +74,7 @@ Servers: more reliable restoring of state.
 
 SMP server: reduced memory usage and faster start.
 
-Notifications: compensate for iOS notifications being dropped by Apple while device is offline (#1378):
+Notifications: compensate for iOS notifications being droppted 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/actions/workflows/build.yml/badge.svg)](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml)
+[![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild)
 [![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/Main.hs

@@ -16,6 +16,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
+  setLogLevel LogDebug
   cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
   logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
   withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles cfgPath logPath

apps/smp-server/static/index.html

@@ -223,14 +223,11 @@
             <table id="public-info">
               <tr class="text-grey-black dark:text-white text-base">
                 <td>Server version:</td>
-                <td>${version}<x-commit> / <a href="${commitSourceCode}/commit/${commit}" target="_blank">${shortCommit}</a></x-commit></td>
+                <td>${version}</td>
               </tr>
               <tr class="text-grey-black dark:text-white text-base">
                 <td>Source code:</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>
+                <td><a href="${sourceCode}" target="_blank">${sourceCode}</a></td>
               </tr>
               <x-website>
                 <tr class="text-grey-black dark:text-white text-base">

apps/smp-server/static/link.html

@@ -512,8 +512,6 @@
         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,7 +12,6 @@ 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 (..))
@@ -23,9 +22,8 @@ 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 (..), simplexmqSource)
+import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..))
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util (tshow)
@@ -105,7 +103,6 @@ generateSite si onionHost sitePath = do
   createLinkPage "a"
   createLinkPage "c"
   createLinkPage "g"
-  createLinkPage "r"
   createLinkPage "i"
   logInfo $ "Generated static site contents at " <> tshow sitePath
   where
@@ -119,7 +116,7 @@ generateSite si onionHost sitePath = do
 serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
 serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
   where
-    substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)]
+    substs = substConfig <> maybe [] substInfo information <> [("onionHost", strEncode <$> onionHost)]
     substConfig =
       [ ( "persistence",
           Just $ case persistence config of
@@ -134,7 +131,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
       ]
     yesNo True = "Yes"
     yesNo False = "No"
-    substInfo =
+    substInfo spi =
       concat
         [ basic,
           maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
@@ -146,16 +143,10 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
         ]
       where
         basic =
-          [ ("sourceCode", if T.null sc then Nothing else Just (encodeUtf8 sc)),
-            ("noSourceCode", if T.null sc then Just "none" else Nothing),
+          [ ("sourceCode", Just . encodeUtf8 $ sourceCode spi),
             ("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)
@@ -237,8 +228,8 @@ section_ label content' src =
         (inside, next') ->
           let next = B.drop (B.length endMarker) next'
            in case content' of
-                Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next
-                _ -> before <> next -- collapse section
+                Nothing -> before <> next -- collapse section
+                Just content -> before <> item_ label content inside <> section_ label content' next
   where
     startMarker = "<x-" <> label <> ">"
     endMarker = "</x-" <> label <> ">"

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

@@ -5,19 +5,22 @@
 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 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.
+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.
 
 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 super-peer addresses for the group.
+- 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.
 
 ## Design objectives
 
-We want to achieve these objectives for short links and associated queue data:
+We want to achieve these objectives:
 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.
@@ -25,17 +28,17 @@ We want to achieve these objectives for short links and associated queue data:
 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 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).
+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).
 
-To achieve these objectives the queue data will include fixed (immutable) and user-defined (mutable) parts.
+To achieve these objectives the queue data must have immutable part and mutable part.
 
-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.
+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.
 - public signature key to verify mutable part of link data.
 
-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.
+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.
 
 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`).
 
@@ -46,6 +49,8 @@ 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,
@@ -65,48 +70,43 @@ data NewQueueReq = NewQueueReq
     rcvDhKey :: RcvPublicDhKey,
     auth_ :: Maybe BasicAuth,
     subMode :: SubscriptionMode,
-    queueReqData :: Maybe QueueReqData,
+    queueData :: Maybe QueueReqData,
+    ntfCreds :: Maybe NewNtfCreds
   }
 
+-- 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 (SenderId, QueueLinkData))
-  | QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
+data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, 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.
--- 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 QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes)
 
-type EncFixedLinkData = ByteString
+type EncImmutableDataBytes = ByteString
 
 type EncUserDataBytes = ByteString
 
--- 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
+-- 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
   }
 
-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
+-- 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
+  }
 
 -- | Updated queue IDs and keys, returned in IDS response
 data QueueIdsKeys = QIK
@@ -114,14 +114,17 @@ data QueueIdsKeys = QIK
     sndId :: SenderId, -- server-generated
     rcvPublicDhKey :: RcvPublicDhKey,
     sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied?
-    linkId :: Maybe LinkId -- server-generated
+    linkId :: Maybe LinkId, -- server-generated
+    serverNtfCreds :: Maybe ServerNtfCreds -- currently returned in NID response
   }
+
+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 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, optionally, 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 mutable part of contact address queue.
+-- This command allows to set all data or to update mutlable 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.
@@ -144,43 +147,58 @@ LKEY :: SndPublicAuthKey -> Command Sender
 -- Entity ID is LinkId
 LGET :: Command Sender
 
--- Response to LGET and LSET
+-- Response to LGET, LSKEY and LSGET
 -- 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 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 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 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 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.
 
-Alternative solutions that would allow retries that were considered and rejected:
+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:
 - 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 existence checks (oracle attack).
+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.
 
-This scheme results in 32 byte binary size for contact addresses and 56 bytes for 1-time invitation links.
+**Prepare queue link data**
 
-For fixed link data.
+- 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.
 
-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:
+**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) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
-  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.
+  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.
 
 For mutable user data:
 
 1. Random `nonce2` and the same key are used.
-2. Sign `user_data` with key included in `fixed_data`.
+2. Sign `user_data` with key included in `immutable_data`.
 3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`.
 4. Store: `(nonce2, ct2, tag2)`
 
@@ -190,15 +208,13 @@ 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)`:
-  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.
+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.
 
-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.
+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.
 
 ## Threat model
 
@@ -206,10 +222,10 @@ While using content hash as encryption key is unconventional, it is not complete
 
 can:
 - delete link data.
-- hide link data selectively for some or for all requests.
+- hide link selectively from some requests.
 
 cannot:
-- undetectably replace link data, even if it has the link (objective 3).
+- undetectably replace link data, even if they have 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.
 
@@ -220,10 +236,10 @@ can:
 
 cannot:
 - undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5).
-- undetectably check the existence of messaging queue or 1-time link (objective 8).
+- undetectbly check the existense of messaging queue or 1-time link (objective 8).
 - replace or delete the link data.
 
-**Queue owner who did not compromise the server**:
+**Queue owner who did not comprmise the server**:
 
 cannot:
 - redirect connecting user to another queue, on the same or on another server (objective 1).
@@ -231,42 +247,40 @@ cannot:
 
 ## Correlation of design objectives with design elements
 
-1. The presence of `SenderId` in `LNK` response from the server.
+1. The presense of `SenderId` in `LINK` response from the server.
 2. Encryption of link data with crypto_box.
-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.
+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.
 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 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.
+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.
 
 ## Syntax for short links
 
-The syntax:
+The proposed syntax:
 
 ```abnf
-shortConnectionLink = uriAuthority "/" linkUri [ "?" param *( "&" param ) ]
-uriAuthority = %s"https://" smpServerHost / "simplex:" ; using simplex: scheme requires including host in the parameter hostParam
+shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ]
 smpServerHost = <hostname> ; RFC1123, RFC5891
-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
+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
 ; linkKey - 256 bits/32 bytes
 
-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)>
+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
 ```
 
-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.
+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.
 
-Example one-time link for preset server (104 characters):
+Example one-time link for preset server (103 characters):
 
 ```
-https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij01/23456789abcdefghij0123456789abcdefghij01234
+https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234
 ```
 
 Example contact link for preset server (71 characters):
@@ -275,16 +289,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 - 117 characters):
+Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters):
 
 ```
-https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU
+https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc
 ```
 
-Example contact link for user-defined server (with fingerprint ant onion hostname - 182 characters):
+Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters):
 
 ```
-https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU&h=beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion
+https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
 ```
 
 For the links to work in the browser the servers must provide server pages.

rfcs/2025-05-05-client-certificates.md

@@ -1,142 +0,0 @@
-# Service certificates for high volume servers and services connecting to SMP servers
-
-## Problem
-
-The absense of user and client identification benefits privacy, but it requires separately authorizing subscription for each messaging queue, that doesn't scale when a high volume server or service acts as a client for SMP server even for the current traffic and network size.
-
-These servers/services include:
-- operators' chat relays (aka super-peers),
-- notification servers,
-- high-traffic service chat bots,
-- high-traffic business support clients.
-
-The future chat relays would reduce the number of subscriptions required for the usual clients, by replacing connections with each group member to 1-3 connections with chat relays per group/community, it would shift the burden to the chat relays, that are also clients.
-
-Self-hosted chat relays may want to retain privacy, so they will not use client certificates, but this privacy is not needed (and counter-productive) for the chat relays provided by network operators.
-
-Even today, directory service subscribing to all queues may take 15-20 minutes, which is experienced as downtime by the end users.
-
-Notification servers also acting as clients to messaging servers also take 15-20 minutes to subscribe to all notifications, during which time notifications are not delivered.
-
-Not only these subscription take a lot of time, they also consume a large amount of memory both in the clients and in the servers, as association between clients and queues is currently session-scoped and not persisted anywhere (and it should not be, because end-users' clients do need privacy).
-
-## Solution
-
-High volume "clients" (operators' chat relays, directory service, SimpleX Chat team support client, SimpleX Status bot, etc.) that don't need privacy will identify themselves to the messaging servers at a point of connection by providing client sertificate, both in TLS handshake and in SMP handshake (the same certificate must be provided).
-
-All the new queues and subscriptions made in this session will be creating a permanent association of the messaging queue with the client, and on subsequent reconnections the client can "subscribe" to all their queues with a single client subscription command.
-
-This will save a lot of time subscribing and resubscribing on server and client restarts, servers' bandwidth, servers' traffic spikes, and memory of both clients and servers.
-
-## Protocol
-
-An ephemeral per-session signature key signed by long-term client certificate is used for client authorization – this session signature key will be passed in SMP handshake.
-
-To transition existing queues, the subscription command will have to be double-signed - by the queue key, and then by client key.
-
-When server receives such "hand-over" subscription it would create a permanent association between the client certificate and the queue, and on subsequent re-connections the client can subscribe to all the existing queues still associated with the client with one command.
-
-The server will respond to the client with the number of queues it was subscribed to - it would both inform the client that it has to re-connect in case of interruption, and can be used for client and server statistics.
-
-When client creates a new queue, it would also sign the request with both keys, per-queue and client's. Other queue operations (e.g., deletion, or changing associated queue data for short links) would still require two signatures, both the queue key and the client key.
-
-The open question is whether there is any value in allowing to remove the association between the client and the queue. Probably not, as threat model should assume that the server would retain this information, and the use-case for users controlling their servers is narrow.
-
-## Protocol connection handshake
-
-Currently, the types for handshakes are:
-
-```haskell
-data ServerHandshake = ServerHandshake
-  { smpVersionRange :: VersionRangeSMP,
-    sessionId :: SessionId,
-    -- pub key to agree shared secrets for command authorization and entity ID encryption.
-    -- todo C.PublicKeyX25519
-    authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
-  }
-
-data ClientHandshake = ClientHandshake
-  { -- | agreed SMP server protocol version
-    smpVersion :: VersionSMP,
-    -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash,
-    -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
-    authPubKey :: Maybe C.PublicKeyX25519,
-    -- | Whether connecting client is a proxy server (send from SMP v12).
-    -- This property, if True, disables additional transport encrytion inside TLS.
-    -- (Proxy server connection already has additional encryption, so this layer is not needed there).
-    proxyServer :: Bool
-  }
-```
-
-`ServerHandshake` already contains `authPubKey` with the server certificate chain and the signed key for connection encryption and creating a shared secret for denable authorization (with client entity key) and session encryption layer.
-
-`ClientHandshake` contains only ephemeral `authPubKey` to compute a shared secret for session encryption layer, so we need an additional field for an optional client certificate:
-
-```haskell
-serviceCertKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
-```
-
-Certificate here defines client identity. The actual key to be used to sign commands is session-scoped, and is signed by the certificate key. In case of notification server it MUST be the same certificate that is used for server TLS connections.
-
-For operators' clients we may optionally include operators' certificate in the chain, and that would allow servers to identify operators if either wants to. This would improve end-user security, as not only the server would validate that its certificate matches the address, but it would also validate that it is operated by SimpleX Chat or by Flux, preventing any server impersonation (e.g., via DNS manipulations) - the client could then report that the files are hosted on SimpleX Chat servers, but then can stop and show additional warning in case certificate does not match the domain - same as the browsers do with CA stores in the client.
-
-## Protocol transmissions
-
-Each transport block can contain one or several protocol transmissions.
-
-Each transmission has this structure:
-
-```abnf
-transmission = authenticator authorized
-; authenticator - Ed25519 signature for recipients or X25519 authenticator for senders, to provide repudiation.
-; authenticator authorizes the rest of the transmission.
-authorized = sessId corrId entityId command.
-; sessId is tls-unique channel binding, its presense in the transmission prevents replay attacks.
-```
-
-The proposed change would replace authenticator with exactly one or two authenticators, where the first one will remain resource-level authorization (queue key), and the optional second one will be client authorization with the client key.
-
-```abnf
-authenticator = queue_authenticator ("0" / "1" service_authenticator)
-; "0" and "1" characters (digit characters, not x00 or x01) are conventionally used for Maybe types in the protocol.
-```
-
-In case service_authenticator is present, queue_authenticator should authorize over `fingerprint authorized` (concatenation of service identity certificate fingerprint and the rest of the transmission).
-
-All queues created with client key will have to be double-authorized with both the queue key and the client key - both the client and the server would have to maintain this knowledge, whether the queue is associated with the client or not.
-
-Asymmetric retries have to be supported - the first request creating this association may succeed on the server and timeout on the client.
-
-## Subscription
-
-To subscribe to all associated queues the client has to send a single command authorized with the client key passed in handshake.
-
-The command and response:
-
-```haskell
-SUBS :: Command Recipient -- to enable all client subscriptions, empty entity ID in the transmission, signed by client key - it must be the same as was used in handover subscription signature.
-NSUBS :: Command Recipient -- notification subscription
-SOK :: Maybe ServiceId -- new subscription response
-SOKS :: Int64 -> BrokerMsg -- response from the server, includes the number of subscribed queues
-ENDS :: Int64 -> BrokerMsg -- when another session subscribes with the same certificate
-```
-
-Open questions:
-- What should used as an entity ID for `SUBS` transmission - certificate fingerprint or an empty string?
-- Should there be a command to get the list of all associated queues? It is likely to be useful for debugging?
-- What should happen when `SUB` is sent for a single already associated queue? What if it is signed with the correct session key, but that is different from existing association? The current approach is that once associated, this associaiton would require authorization for single subscriptions, with the same certificate as already associated.
-
-## Ephemeral client-session association
-
-This was considered to reduce costs for the usual clients to re-subscribe. Currently it's a big problem, because of groups, and with transition to chat relays it won't be.
-
-For some very busy end-user clients it may help.
-
-Given that server has access to an ephemeral association between recipient client session and queues anyway (even with clients connecting via Tor, unless per-connection transport isolation is used), introducing `sessionPubKey` to allow resubscription to the previously subscribed queues may reduce the traffic. This won't change threat model as the server would only keep this association in memory, and not persist it. Clients on another hand may safely persist this association for fast resubscription on client restarts.
-
-This is not planned for the forseable future, as migrating to chat relays would solve most of the problem.
-
-Assuming an average active user has 20 contacts and 20 groups, and they would need ~3 subscriptions for each (for redundancy), so about 120 subscription to reconnect. The single 16kb transport block allows to send ~136 subscriptions. Which means that ephemeral sessions would create no value for clients at all, unless they are super active.
-
-Further, improving transport efficiency for super-active non-identified clients may help network abuse, so ephemeral sessions may have negative value.

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

@@ -1,104 +0,0 @@
-# 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.

scripts/simplexmq-reproduce-builds.sh

@@ -47,7 +47,7 @@ for os in 22.04 24.04; do
 	docker exec \
 		-t \
 		builder \
-		sh -c 'git config --global --add safe.directory \*; cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
+		sh -c 'cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
 
 	# Copy smp-server postgresql binary and prepare it
 	docker cp \

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.5.0.3
+version:        6.4.0.4
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -103,13 +103,12 @@ library
       Simplex.Messaging.Agent.Store.AgentStore
       Simplex.Messaging.Agent.Store.Common
       Simplex.Messaging.Agent.Store.DB
-      Simplex.Messaging.Agent.Store.Entity
       Simplex.Messaging.Agent.Store.Interface
       Simplex.Messaging.Agent.Store.Migrations
       Simplex.Messaging.Agent.Store.Migrations.App
       Simplex.Messaging.Agent.Store.Postgres.Options
       Simplex.Messaging.Agent.Store.Shared
-      Simplex.Messaging.Agent.TSessionSubs
+      Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Compression
@@ -131,13 +130,11 @@ library
       Simplex.Messaging.Notifications.Types
       Simplex.Messaging.Parsers
       Simplex.Messaging.Protocol
-      Simplex.Messaging.Protocol.Types
       Simplex.Messaging.Server.Expiration
       Simplex.Messaging.Server.QueueStore.Postgres.Config
       Simplex.Messaging.Server.QueueStore.QueueInfo
       Simplex.Messaging.ServiceScheme
       Simplex.Messaging.Session
-      Simplex.Messaging.SystemTime
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
@@ -149,7 +146,6 @@ library
       Simplex.Messaging.Transport.HTTP2.Server
       Simplex.Messaging.Transport.KeepAlive
       Simplex.Messaging.Transport.Server
-      Simplex.Messaging.Transport.Shared
       Simplex.Messaging.Util
       Simplex.Messaging.Version
       Simplex.Messaging.Version.Internal
@@ -164,9 +160,6 @@ 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
-          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251009_queue_to_subscribe
-          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notices
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -213,16 +206,6 @@ 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
-          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251009_queue_to_subscribe
-          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices
-  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
@@ -230,7 +213,6 @@ 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
@@ -240,7 +222,6 @@ 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
@@ -257,6 +238,14 @@ 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
@@ -264,7 +253,6 @@ library
               Simplex.Messaging.Notifications.Server.Env
               Simplex.Messaging.Notifications.Server.Main
               Simplex.Messaging.Notifications.Server.Prometheus
-              Simplex.Messaging.Notifications.Server.Push
               Simplex.Messaging.Notifications.Server.Push.APNS
               Simplex.Messaging.Notifications.Server.Push.APNS.Internal
               Simplex.Messaging.Notifications.Server.Stats
@@ -273,7 +261,6 @@ 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:
@@ -321,7 +308,6 @@ library
     , network-transport ==0.5.6
     , network-udp ==0.0.*
     , random >=1.1 && <1.3
-    , scientific ==0.3.7.*
     , simple-logger ==0.1.*
     , socks ==0.6.*
     , stm ==2.5.*
@@ -363,12 +349,10 @@ 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
@@ -481,7 +465,7 @@ test-suite simplexmq-test
       CoreTests.RetryIntervalTests
       CoreTests.SOCKSSettings
       CoreTests.StoreLogTests
-      CoreTests.TSessionSubs
+      CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
@@ -572,7 +556,7 @@ test-suite simplexmq-test
     build-depends:
         memory
       , sqlcipher-simple
-  if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres)
+  if !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 (allFinally, catchAll_, catchAllErrors, liftError, tshow, unlessM, whenM)
+import Simplex.Messaging.Util (catchAll_, 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
-              `catchAllErrors` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAllErrors (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> 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 `catchAllErrors` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
+          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
     decryptFile :: RcvFile -> AM ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
       let CryptoFile savePath cfArgs = saveFile
@@ -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) `allFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
+          yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (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 `catchAllErrors` sndWorkerInternalError c sndFileId sndFileEntityId prefixPath
+          prepareFile cfg f `catchAgentError` 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
-                  `catchAllErrors` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
+                  `catchAgentError` \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 catchAllErrors (\_ -> pure ()) $ do
+                  flip catchAgentError (\_ -> 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
-              `catchAllErrors` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAllErrors (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> 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
-              `catchAllErrors` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
-              flip catchAllErrors (\_ -> pure ()) $ do
+              flip catchAgentError (\_ -> 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,22 +31,18 @@ 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
@@ -59,11 +55,9 @@ 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)
+import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.File
@@ -105,16 +99,15 @@ defaultXFTPClientConfig =
   XFTPClientConfig
     { xftpNetworkConfig = defaultNetworkConfig,
       serverVRange = supportedFileServerVRange,
-      clientALPN = Just alpnSupportedXFTPhandshakes
+      clientALPN = Just supportedXFTPhandshakes
     }
 
-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
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
-      useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False useALPN
+  let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -123,11 +116,10 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let HTTP2Client {sessionId, sessionALPN} = http2Client
       v = VersionXFTP 1
       thServerVRange = versionToRange v
-      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
-    Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
-      xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
+    Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
     _ -> pure thParams0
   logDebug $ "Client negotiated protocol: " <> tshow thVersion
   let c = XFTPClient {http2Client, thParams, transportSession, config}
@@ -140,8 +132,7 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
   (vr, sk) <- processServerHandshake shs
   let v = maxVersion vr
   sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
-  let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
-  pure thParams0 {thAuth, thVersion = v, thServerVRange = vr}
+  pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v, thServerVRange = vr}
   where
     getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
     getServerHandshake = do
@@ -156,12 +147,12 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
         Nothing -> throwE $ PCETransportError TEVersion
         Just (Compatible vr) ->
           fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do
-            let CertChainPubKey (X.CertificateChain cert) exact = serverAuth
+            let (X.CertificateChain cert, exact) = serverAuth
             case cert of
               [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
               _ -> throwError "bad certificate"
             pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
-            C.x509ToPublic' pubKey
+            C.x509ToPublic (pubKey, []) >>= C.pubKey
     sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
     sendClientHandshake chs = do
       chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
@@ -186,14 +177,14 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = defaultSupportedParams,
-      connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
+      connTimeout = tcpConnectTimeout,
       transportConfig
     }
 
 xftpClientError :: HTTP2ClientError -> XFTPClientError
 xftpClientError = \case
   HCResponseTimeout -> PCEResponseTimeout
-  HCNetworkError e -> PCENetworkError e
+  HCNetworkError -> PCENetworkError
   HCIOError e -> PCEIOError e
 
 sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
@@ -212,7 +203,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
   HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
   when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK
   -- TODO validate that the file ID is the same as in the request?
-  (_, _fId, respOrErr) <-liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
+  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
   case respOrErr of
     Right r -> case protocolError r of
       Just e -> throwE $ PCEProtocolError e
@@ -263,9 +254,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 $ NEConnectError $ displayException e,
-              Handler $ \(e :: IOException) -> pure $ Left $ PCEIOError e,
-              Handler $ \(e :: SomeException) -> pure $ Left $ PCENetworkError $ toNetworkError e
+            [ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError,
+              Handler $ \(e :: IOException) -> pure $ Left (PCEIOError e),
+              Handler $ \(_e :: SomeException) -> pure $ Left PCENetworkError
             ]
           download cbState =
             runExceptT . withExceptT PCEResponseError $
@@ -276,11 +267,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
 
 xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
 xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
-  maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
+  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
 
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
 chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
-  netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
+  tcpTimeout + 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 (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), 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 $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
+      client_ <- liftIO $ tcpConnectTimeout `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
-      netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
         _ -> pure ()

src/Simplex/FileTransfer/Protocol.hs

@@ -44,9 +44,8 @@ import Simplex.Messaging.Protocol
     EntityId (..),
     RecipientId,
     SenderId,
-    RawTransmission,
     SentRawTransmission,
-    SignedTransmissionOrError,
+    SignedTransmission,
     SndPublicAuthKey,
     Transmission,
     TransmissionForAuth (..),
@@ -54,8 +53,7 @@ import Simplex.Messaging.Protocol
     encodeTransmission,
     encodeTransmissionForAuth,
     messageTagP,
-    tDecodeServer,
-    tDecodeClient,
+    tDecodeParseValidate,
     tEncodeBatch1,
     tParse,
   )
@@ -146,15 +144,10 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
   protocolClientHandshake = xftpClientHandshakeStub
-  {-# INLINE protocolClientHandshake #-}
-  useServiceAuth _ = False
-  {-# INLINE useServiceAuth #-}
   protocolPing = FileCmd SFRecipient PING
-  {-# INLINE protocolPing #-}
   protocolError = \case
     FRErr e -> Just e
     _ -> Nothing
-  {-# INLINE protocolError #-}
 
 data FileCommand (p :: FileParty) where
   FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
@@ -199,7 +192,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
   fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials auth (EntityId fileId) cmd = case cmd of
+  checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
     -- FNEW must not have signature and chunk ID
     FNEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -233,8 +226,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
   fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials tAuth entId (FileCmd p c) = FileCmd p <$> checkCredentials tAuth entId c
-  {-# INLINE checkCredentials #-}
+  checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
 
 instance Encoding FileInfo where
   smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest)
@@ -312,7 +304,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials _ (EntityId entId) cmd = case cmd of
+  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
     FRSndIds {} -> noEntity
     -- ERR response does not always have entity ID
     FRErr _ -> Right cmd
@@ -337,35 +329,25 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
 
-xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
-xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey t@(corrId, _, _) = do
-  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams t
-  xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (C.cbNonce $ bs corrId) tForAuth
+xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
+xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do
+  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
+  xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) (C.cbNonce $ bs corrId) tForAuth
 
-xftpEncodeTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
-xftpEncodeTransmission thParams t = xftpEncodeBatch1 (Nothing, encodeTransmission thParams t)
+xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission thParams (corrId, fId, msg) = do
+  let t = encodeTransmission thParams (corrId, fId, msg)
+  xftpEncodeBatch1 (Nothing, t)
 
 -- this function uses batch syntax but puts only one transmission in the batch
 xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
-xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 False t) xftpBlockSize
+xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
 
-xftpDecodeTServer :: THandleParams XFTPVersion 'TServer -> ByteString -> Either XFTPErrorType (SignedTransmissionOrError XFTPErrorType FileCmd)
-xftpDecodeTServer = xftpDecodeTransmission tDecodeServer
-{-# INLINE xftpDecodeTServer #-}
-
-xftpDecodeTClient :: THandleParams XFTPVersion 'TClient -> ByteString -> Either XFTPErrorType (Transmission (Either XFTPErrorType FileResponse))
-xftpDecodeTClient = xftpDecodeTransmission tDecodeClient
-{-# INLINE xftpDecodeTClient #-}
-
-xftpDecodeTransmission ::
-  (THandleParams XFTPVersion p -> Either TransportError RawTransmission -> r) ->
-  THandleParams XFTPVersion p ->
-  ByteString ->
-  Either XFTPErrorType r
-xftpDecodeTransmission tDecode thParams t = do
+xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
+xftpDecodeTransmission thParams t = do
   t' <- first (const BLOCK) $ C.unPad t
   case tParse thParams t' of
-    t'' :| [] -> Right $ tDecode thParams t''
+    t'' :| [] -> Right $ tDecodeParseValidate thParams t''
     _ -> Left BLOCK
 
 $(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty)

src/Simplex/FileTransfer/Server.hs

@@ -26,12 +26,12 @@ import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
+import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
@@ -45,7 +45,6 @@ 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,16 +53,15 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
-import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
+import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
+import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
@@ -71,7 +69,6 @@ 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)
@@ -95,46 +92,39 @@ data XFTPTransportRequest = XFTPTransportRequest
 runXFTPServer :: XFTPServerConfig -> IO ()
 runXFTPServer cfg = do
   started <- newEmptyTMVarIO
-  runXFTPServerBlocking started cfg
+  runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes
 
-runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
-runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
+runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO ()
+runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_)
 
 data Handshake
   = HandshakeSent C.PrivateKeyX25519
   | HandshakeAccepted (THandleParams XFTPVersion 'TServer)
 
-xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
+xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M ()
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do
   mapM_ (expireServerFiles Nothing) fileExpiration
   restoreServerStats
-  raceAny_
-    ( runServer
-        : expireFilesThread_ cfg
-          <> serverStatsThread_ cfg
-          <> prometheusMetricsThread_ cfg
-          <> controlPortThread_ cfg
-    )
-    `finally` stopServer
+  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
   where
     runServer :: M ()
     runServer = do
       srvCreds@(chain, pk) <- asks tlsServerCreds
-      signKey <- liftIO $ case C.x509ToPrivate' pk of
+      signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
         Right pk' -> pure pk'
-        Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
+        Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
       env <- ask
       sessions <- liftIO TM.emptyIO
       let cleanup sessionId = atomically $ TM.delete sessionId sessions
-      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
+      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
         reqBody <- getHTTP2Body r xftpBlockSize
         let v = VersionXFTP 1
             thServerVRange = versionToRange v
-            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
+            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
             req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
         flip runReaderT env $ case sessionALPN of
           Nothing -> processRequest req0
-          Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
+          Just "xftp/1" ->
             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)
@@ -152,7 +142,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (B.null bodyHead) $ throwE HANDSHAKE
           (k, pk) <- atomically . C.generateKeyPair =<< asks random
           atomically $ TM.insert sessionId (HandshakeSent pk) sessions
-          let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
+          let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
           let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
           shs <- encodeXftp hs
 #ifdef slow_servers
@@ -168,7 +158,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (keyHash == kh) $ throwE HANDSHAKE
           case compatibleVRange' xftpServerVRange v of
             Just (Compatible vr) -> do
-              let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
+              let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
                   thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
               atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
 #ifdef slow_servers
@@ -231,49 +221,25 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0
           filesCount' <- readIORef filesCount
           filesSize' <- readIORef filesSize
-          T.hPutStrLn h $
-            T.intercalate
+          hPutStrLn h $
+            intercalate
               ","
-              [ T.pack $ iso8601Show $ utctDay fromTime',
-                tshow filesCreated',
-                tshow fileRecipients',
-                tshow filesUploaded',
-                tshow filesDeleted',
+              [ iso8601Show $ utctDay fromTime',
+                show filesCreated',
+                show fileRecipients',
+                show filesUploaded',
+                show filesDeleted',
                 dayCount files,
                 weekCount files,
                 monthCount files,
-                tshow fileDownloads',
-                tshow fileDownloadAcks',
-                tshow filesCount',
-                tshow filesSize',
-                tshow filesExpired'
+                show fileDownloads',
+                show fileDownloadAcks',
+                show filesCount',
+                show filesSize',
+                show filesExpired'
               ]
         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_ _ = []
@@ -311,9 +277,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> controlPortAuth h user admin role auth
+              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
                 where
-                  XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
+                  newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
+                    | Just auth == admin = CPRAdmin
+                    | Just auth == user = CPRUser
+                    | otherwise = CPRNone
               CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
               CPDelete fileId -> withUserRole $ unliftIO u $ do
                 fs <- asks store
@@ -348,20 +317,22 @@ data ServerFile = ServerFile
 processRequest :: XFTPTransportRequest -> M ()
 processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
-  | otherwise =
-      case xftpDecodeTServer thParams bodyHead of
-        Right (Right t@(_, _, (corrId, fId, _))) -> do
-          let THandleParams {thAuth} = thParams
-          verifyXFTPTransmission thAuth t >>= \case
-            VRVerified req -> uncurry send =<< processXFTPRequest body req
-            VRFailed e -> send (FRErr e) Nothing
+  | otherwise = do
+      case xftpDecodeTransmission thParams bodyHead of
+        Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
+          case cmdOrErr of
+            Right cmd -> do
+              let THandleParams {thAuth} = thParams
+              verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
+                VRVerified req -> uncurry send =<< processXFTPRequest body req
+                VRFailed e -> send (FRErr e) Nothing
+            Left e -> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
-        Right (Left (corrId, fId, e)) -> sendXFTPResponse (corrId, fId, FRErr e) Nothing
         Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
   where
-    sendXFTPResponse t' serverFile_ = do
-      let t_ = xftpEncodeTransmission thParams t'
+    sendXFTPResponse (corrId, fId, resp) serverFile_ = do
+      let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
 #ifdef slow_servers
       randomDelay
 #endif
@@ -390,8 +361,8 @@ randomDelay = do
 
 data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
 
-verifyXFTPTransmission :: Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M VerificationResult
-verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
+verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
+verifyXFTPTransmission auth_ tAuth authorized fId cmd =
   case cmd of
     FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
     FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
@@ -410,9 +381,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
                 EntityBlocked info -> VRFailed $ BLOCKED info
                 EntityOff -> noFileAuth
           Left _ -> pure noFileAuth
-        noFileAuth = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH
+        noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH
     -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
+    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -452,7 +423,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
-    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedFileTime -> M (Either XFTPErrorType XFTPFileId)
+    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts =
       retryAdd n $ \sId -> runExceptT $ do
         ExceptT $ addFile st sId file ts EntityActive
@@ -580,8 +551,8 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
       liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
       liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
-getFileTime :: IO RoundedFileTime
-getFileTime = getRoundedSystemTime
+getFileTime :: IO RoundedSystemTime
+getFileTime = getRoundedSystemTime fileTimePrecision
 
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do

src/Simplex/FileTransfer/Server/Env.hs

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

@@ -21,16 +21,16 @@ import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Description (FileSize (..))
 import Simplex.FileTransfer.Server (runXFTPServer)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
-import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes)
+import Simplex.FileTransfer.Transport (supportedFileServerVRange)
 import qualified Simplex.Messaging.Crypto as C
 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 (eitherToMaybe, safeDecodeUtf8, tshow)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
+import Simplex.Messaging.Util (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" <> simplexmqVersionCommit
+    serverVersion = "SimpleX XFTP server v" <> simplexMQVersion
     defaultServerPort = "443"
     executableName = "file-server"
     storeLogFilePath = combine logPath "file-server-store.log"
@@ -89,9 +89,6 @@ 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\
@@ -191,13 +188,10 @@ 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 <> httpALPN)
-                  False,
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  },
               responseDelay = 0
             }
 

src/Simplex/FileTransfer/Server/Prometheus.hs

@@ -1,134 +0,0 @@
-{-# 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/Server/Store.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -9,7 +8,6 @@ module Simplex.FileTransfer.Server.Store
   ( FileStore (..),
     FileRec (..),
     FileRecipient (..),
-    RoundedFileTime,
     newFileStore,
     addFile,
     setFilePath,
@@ -35,8 +33,7 @@ import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
-import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
-import Simplex.Messaging.SystemTime
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..), ServerEntityStatus (..))
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, ($>>=))
@@ -52,12 +49,10 @@ data FileRec = FileRec
     fileInfo :: FileInfo,
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
-    createdAt :: RoundedFileTime,
+    createdAt :: RoundedSystemTime,
     fileStatus :: TVar ServerEntityStatus
   }
 
-type RoundedFileTime = RoundedSystemTime 3600
-
 fileTimePrecision :: Int64
 fileTimePrecision = 3600 -- truncate creation time to 1 hour
 
@@ -75,14 +70,14 @@ newFileStore = do
   usedStorage <- newTVarIO 0
   pure FileStore {files, recipients, usedStorage}
 
-addFile :: FileStore -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM (Either XFTPErrorType ())
+addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM (Either XFTPErrorType ())
 addFile FileStore {files} sId fileInfo createdAt status =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
     f <- newFileRec sId fileInfo createdAt status
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
+newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM FileRec
 newFileRec senderId fileInfo createdAt status = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -34,13 +34,13 @@ import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Store
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
-import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..))
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus
+  = AddFile SenderId FileInfo RoundedSystemTime ServerEntityStatus
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
@@ -69,7 +69,7 @@ instance StrEncoding FileStoreLogRecord where
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO ()
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> IO ()
 logAddFile s = logFileStoreRecord s .:: AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()

src/Simplex/FileTransfer/Transport.hs

@@ -13,8 +13,7 @@ module Simplex.FileTransfer.Transport
     authCmdsXFTPVersion,
     blockedFilesXFTPVersion,
     xftpClientHandshakeStub,
-    alpnSupportedXFTPhandshakes,
-    xftpALPNv1,
+    supportedXFTPhandshakes,
     XFTPClientHandshake (..),
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
@@ -43,7 +42,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
@@ -51,6 +50,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.Word (Word16, Word32)
+import qualified Data.X509 as X
 import Network.HTTP2.Client (HTTP2Error)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -58,7 +58,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
-import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
+import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
 import Simplex.Messaging.Util (bshow, tshow)
 import Simplex.Messaging.Version
@@ -102,20 +102,17 @@ supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
 
 -- XFTP protocol does not use this handshake method
-xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
-xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion
+xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
+xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
 
-alpnSupportedXFTPhandshakes :: [ALPN]
-alpnSupportedXFTPhandshakes = [xftpALPNv1]
-
-xftpALPNv1 :: ALPN
-xftpALPNv1 = "xftp/1"
+supportedXFTPhandshakes :: [ALPN]
+supportedXFTPhandshakes = ["xftp/1"]
 
 data XFTPServerHandshake = XFTPServerHandshake
   { xftpVersionRange :: VersionRangeXFTP,
     sessionId :: SessionId,
     -- | pub key to agree shared secrets for command authorization and entity ID encryption.
-    authPubKey :: CertChainPubKey
+    authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey)
   }
 
 data XFTPClientHandshake = XFTPClientHandshake
@@ -135,12 +132,15 @@ instance Encoding XFTPClientHandshake where
 
 instance Encoding XFTPServerHandshake where
   smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
-    smpEncode (xftpVersionRange, sessionId, authPubKey)
+    smpEncode (xftpVersionRange, sessionId, auth)
+    where
+      auth = bimap C.encodeCertChain C.SignedObject authPubKey
   smpP = do
     (xftpVersionRange, sessionId) <- smpP
-    authPubKey <- smpP
+    cert <- C.certChainP
+    C.SignedObject key <- smpP
     Tail _compat <- smpP
-    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey}
+    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)}
 
 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go

src/Simplex/FileTransfer/Types.hs

@@ -15,7 +15,6 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Encoding
@@ -23,6 +22,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (XFTPServer)
 import System.FilePath ((</>))
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 
 type RcvFileId = ByteString -- Agent entity ID
 

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

@@ -27,6 +27,11 @@ module Simplex.Messaging.Agent.Env.SQLite
     serverHosts,
     defaultAgentConfig,
     defaultReconnectInterval,
+    tryAgentError,
+    tryAgentError',
+    catchAgentError,
+    catchAgentError',
+    agentFinally,
     Env (..),
     newSMPAgentEnv,
     createAgentStore,
@@ -40,6 +45,7 @@ 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
@@ -64,7 +70,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 (MigrationConfig (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -77,6 +83,7 @@ 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
@@ -90,8 +97,7 @@ data InitialAgentServers = InitialAgentServers
     ntf :: [NtfServer],
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
     netCfg :: NetworkConfig,
-    presetDomains :: [HostName],
-    presetServers :: [SMPServer]
+    presetDomains :: [HostName]
   }
 
 data ServerCfg p = ServerCfg
@@ -167,7 +173,6 @@ data AgentConfig = AgentConfig
     ntfBatchSize :: Int,
     ntfSubFirstCheckInterval :: NominalDiffTime,
     ntfSubCheckInterval :: NominalDiffTime,
-    maxPendingSubscriptions :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
@@ -239,7 +244,6 @@ defaultAgentConfig =
       ntfBatchSize = 150,
       ntfSubFirstCheckInterval = nominalDay,
       ntfSubCheckInterval = 3 * nominalDay,
-      maxPendingSubscriptions = 35000,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -269,7 +273,7 @@ newSMPAgentEnv config store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
+createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 
 data NtfSupervisor = NtfSupervisor
@@ -308,6 +312,33 @@ 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/Lock.hs

@@ -16,12 +16,11 @@ import Control.Monad.IO.Unlift
 import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Text (Text)
 import UnliftIO.Async (forConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type Lock = TMVar Text
+type Lock = TMVar String
 
 createLock :: STM Lock
 createLock = newEmptyTMVar
@@ -31,24 +30,24 @@ createLockIO :: IO Lock
 createLockIO = newEmptyTMVarIO
 {-# INLINE createLockIO #-}
 
-withLock :: MonadUnliftIO m => Lock -> Text -> ExceptT e m a -> ExceptT e m a
+withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
 withLock lock name = ExceptT . withLock' lock name . runExceptT
 {-# INLINE withLock #-}
 
-withLock' :: MonadUnliftIO m => Lock -> Text -> m a -> m a
+withLock' :: MonadUnliftIO m => Lock -> String -> m a -> m a
 withLock' lock name =
   E.bracket_
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
 
-withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> Text -> m a -> m a
+withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> String -> m a -> m a
 withGetLock getLock key name a =
   E.bracket
     (atomically $ getPutLock getLock key name)
     (atomically . takeTMVar)
     (const a)
 
-withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> Text -> m a -> m a
+withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a
 withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
   where
     holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
@@ -56,5 +55,5 @@ withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
 
 -- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
 -- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.
-getPutLock :: (k -> STM Lock) -> k -> Text -> STM Lock
+getPutLock :: (k -> STM Lock) -> k -> String -> STM Lock
 getPutLock getLock key name = getLock key >>= \l -> putTMVar l name $> l

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -14,7 +14,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     nsUpdateToken,
     nsRemoveNtfToken,
     sendNtfSubCommand,
-    hasInstantNotifications,
     instantNotifications,
     deleteToken,
     closeNtfSupervisor,
@@ -46,13 +45,12 @@ 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 (catchAllErrors, diffToMicroseconds, threadDelay', tryAllErrors, tshow, whenM)
+import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
 import System.Random (randomR)
 import UnliftIO
 import UnliftIO.Concurrent (forkIO)
@@ -217,7 +215,7 @@ runNtfWorker c srv Worker {doWork} =
     runNtfOperation :: AM ()
     runNtfOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (withStore' c $ \db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems c doWork (\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
@@ -357,7 +355,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 `catchAllErrors` \e -> workerInternalError c connId (show e) $> Nothing)
+        <$> runExceptT (action sub `catchAgentError` \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
@@ -365,7 +363,7 @@ runNtfWorker c srv Worker {doWork} =
         lift getNtfToken >>= \case
           Just tkn@NtfToken {ntfServer} -> do
             atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
-            tryAllErrors (agentNtfDeleteSubscription c nSubId tkn) >>= \case
+            tryAgentError (agentNtfDeleteSubscription c nSubId tkn) >>= \case
               Right _ -> do
                 atomically $ incNtfServerStat c userId ntfServer ntfDeleted
                 continue'
@@ -385,7 +383,7 @@ runNtfSMPWorker c srv Worker {doWork} = forever $ do
     runNtfSMPOperation :: AM ()
     runNtfSMPOperation = do
       ntfBatchSize <- asks $ ntfBatchSize . config
-      withWorkItems c doWork (withStore' c $ \db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
+      withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
         logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
         let (creates, deletes) = splitActions nextSubs
         retrySubActions c creates createNotifierKeys
@@ -513,7 +511,7 @@ notifyInternalError' AgentClient {subQ} internalErrStr = atomically $ writeTBQue
 {-# INLINE notifyInternalError' #-}
 
 notifyErrs :: MonadIO m => AgentClient -> [(ConnId, AgentErrorType)] -> m ()
-notifyErrs c = mapM_ (notifySub c . ERRS) . L.nonEmpty
+notifyErrs AgentClient {subQ} connErrs = unless (null connErrs) $ atomically $ writeTBQueue subQ ("", "", AEvt SAENone $ ERRS connErrs)
 {-# INLINE notifyErrs #-}
 
 getNtfToken :: AM' (Maybe NtfToken)
@@ -527,19 +525,15 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
 nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
-sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
-sendNtfSubCommand ns cmd =
-  whenM (hasInstantNotifications ns) $ atomically $ writeTBQueue (ntfSubQ ns) cmd
+sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
+sendNtfSubCommand ns cmd = do
+  tkn <- readTVar (ntfTkn ns)
+  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
 
-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 #-}
+instantNotifications :: Maybe NtfToken -> Bool
+instantNotifications = \case
+  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
+  _ -> False
 
 deleteToken :: AgentClient -> NtfToken -> AM ()
 deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
@@ -567,7 +561,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
           withRetryInterval ri $ \_ loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            processTknToDelete nextTknToDelete `catchAllErrors` retryTmpError loop nextTknToDelete
+            processTknToDelete nextTknToDelete `catchAgentError` retryTmpError loop nextTknToDelete
     retryTmpError :: AM () -> NtfTokenToDelete -> AgentErrorType -> AM ()
     retryTmpError loop (tknDbId, _, _) e = do
       logError $ "ntf tkn del error: " <> tshow e
@@ -578,7 +572,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
           notifyInternalError' c (show e)
     processTknToDelete :: NtfTokenToDelete -> AM ()
     processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
-      agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
+      agentNtfDeleteToken c srv ntfPrivKey tknId
       withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()

src/Simplex/Messaging/Agent/Protocol.hs

@@ -70,7 +70,6 @@ module Simplex.Messaging.Agent.Protocol
     MsgMeta (..),
     RcvQueueInfo (..),
     SndQueueInfo (..),
-    SubscriptionStatus (..),
     ConnectionStats (..),
     SwitchPhase (..),
     RcvSwitchStatus (..),
@@ -112,9 +111,6 @@ module Simplex.Messaging.Agent.Protocol
     ServiceScheme,
     FixedLinkData (..),
     ConnLinkData (..),
-    UserConnLinkData (..),
-    UserContactData (..),
-    UserLinkData (..),
     OwnerAuth (..),
     OwnerId,
     ConnectionLink (..),
@@ -126,9 +122,6 @@ module Simplex.Messaging.Agent.Protocol
     ContactConnType (..),
     ShortLinkScheme (..),
     LinkKey (..),
-    StoredClientService (..),
-    ClientService,
-    ClientServiceId,
     sameConnReqContact,
     sameShortLinkContact,
     simplexChat,
@@ -170,17 +163,12 @@ module Simplex.Messaging.Agent.Protocol
     updateSMPServerHosts,
     shortenShortLink,
     restoreShortLink,
-    isPresetServer,
     linkUserData,
-    linkUserData',
   )
 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
 import qualified Data.Aeson.TH as J
 import qualified Data.Aeson.Types as JT
 import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -199,20 +187,18 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word32)
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Transport (XFTPErrorType)
 import Simplex.FileTransfer.Types (FileErrorType)
 import Simplex.Messaging.Agent.QueryString
-import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
-import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Client (ProxyClientError)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
@@ -381,7 +367,7 @@ type SndQueueSecured = Bool
 
 -- | Parameterized type for SMP agent events
 data AEvent (e :: AEntity) where
-  INV :: AConnectionRequestUri -> Maybe ClientServiceId -> AEvent AEConn
+  INV :: AConnectionRequestUri -> AEvent AEConn
   CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender
   INFO :: PQSupport -> ConnInfo -> AEvent AEConn
@@ -407,9 +393,9 @@ data AEvent (e :: AEntity) where
   DEL_USER :: Int64 -> AEvent AENone
   STAT :: ConnectionStats -> AEvent AEConn
   OK :: AEvent AEConn
-  JOINED :: SndQueueSecured -> Maybe ClientServiceId -> AEvent AEConn
+  JOINED :: SndQueueSecured -> AEvent AEConn
   ERR :: AgentErrorType -> AEvent AEConn
-  ERRS :: NonEmpty (ConnId, AgentErrorType) -> AEvent AENone
+  ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
   SUSPENDED :: AEvent AENone
   RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
   RFDONE :: FilePath -> AEvent AERcvFile
@@ -507,7 +493,7 @@ aCommandTag = \case
 
 aEventTag :: AEvent e -> AEventTag e
 aEventTag = \case
-  INV {} -> INV_
+  INV _ -> INV_
   CONF {} -> CONF_
   REQ {} -> REQ_
   INFO {} -> INFO_
@@ -533,7 +519,7 @@ aEventTag = \case
   DEL_USER _ -> DEL_USER_
   STAT _ -> STAT_
   OK -> OK_
-  JOINED {} -> JOINED_
+  JOINED _ -> JOINED_
   ERR _ -> ERR_
   ERRS _ -> ERRS_
   SUSPENDED -> SUSPENDED_
@@ -647,34 +633,23 @@ instance FromJSON RatchetSyncState where
 
 data RcvQueueInfo = RcvQueueInfo
   { rcvServer :: SMPServer,
-    status :: QueueStatus,
     rcvSwitchStatus :: Maybe RcvSwitchStatus,
-    canAbortSwitch :: Bool,
-    subStatus :: SubscriptionStatus
+    canAbortSwitch :: Bool
   }
   deriving (Eq, Show)
 
 data SndQueueInfo = SndQueueInfo
   { sndServer :: SMPServer,
-    status :: QueueStatus,
     sndSwitchStatus :: Maybe SndSwitchStatus
   }
   deriving (Eq, Show)
 
-data SubscriptionStatus
-  = SSActive
-  | SSPending
-  | SSRemoved {subError :: String}
-  | SSNoSub
-  deriving (Eq, Ord, Show)
-
 data ConnectionStats = ConnectionStats
   { connAgentVersion :: VersionSMPA,
     rcvQueuesInfo :: [RcvQueueInfo],
     sndQueuesInfo :: [SndQueueInfo],
     ratchetSyncState :: RatchetSyncState,
-    ratchetSyncSupported :: Bool,
-    subStatus :: Maybe SubscriptionStatus
+    ratchetSyncSupported :: Bool
   }
   deriving (Eq, Show)
 
@@ -1145,7 +1120,7 @@ instance StrEncoding AConnectionRequestUri where
 
 connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri
 connReqUriP overrideScheme = do
-  crScheme <- (`fromMaybe` overrideScheme) <$> strP -- always parse, but use the passed one if any
+  crScheme <- (`fromMaybe` overrideScheme) <$> strP
   crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
   query <- strP
   aVRange <- queryParam "v" query
@@ -1169,39 +1144,22 @@ 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
 
@@ -1229,16 +1187,6 @@ instance Encoding ConnectionMode where
       'C' -> pure CMContact
       _ -> fail "bad connection mode"
 
-instance ToJSON ConnectionMode where
-  toJSON = J'.String . T.toLower . decodeLatin1 . strEncode
-  {-# INLINE toJSON #-}
-  toEncoding = JE.text . T.toLower . decodeLatin1 . strEncode
-  {-# INLINE toEncoding #-}
-
-instance FromJSON ConnectionMode where
-  parseJSON = J'.withText "ConnectionMode" $ either fail pure . parseAll strP . encodeUtf8 . T.toUpper
-  {-# INLINE parseJSON #-}
-
 connModeT :: Text -> Maybe ConnectionMode
 connModeT = \case
   "INV" -> Just CMInvitation
@@ -1461,21 +1409,10 @@ 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 | CCTRelay deriving (Eq, Show)
+data ContactConnType = CCTContact | CCTChannel | CCTGroup 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
-
 data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m)
   deriving (Eq, Show)
 
@@ -1484,11 +1421,6 @@ data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connSho
 
 data ACreatedConnLink = forall m. ConnectionModeI m => ACCL (SConnectionMode m) (CreatedConnLink m)
 
-instance Eq ACreatedConnLink where
-  ACCL m l == ACCL m' l' = case testEquality m m' of
-    Just Refl -> l == l'
-    _ -> False
-
 deriving instance Show ACreatedConnLink
 
 data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m)
@@ -1571,7 +1503,7 @@ instance StrEncoding AConnShortLink where
           <|> "https://" *> ((SLSServer,) . Just <$> strP)
           <|> fail "bad short link scheme"
       contactTypeP = do
-        Just <$> (A.anyChar >>= ctTypeP . toUpper)
+        Just <$> (A.anyChar >>= ctTypeP . toUpper)        
           <|> A.char 'i' $> Nothing
           <|> fail "unknown short link type"
       serverQueryP h_ =
@@ -1608,8 +1540,7 @@ ctTypeP :: Char -> Parser ContactConnType
 ctTypeP = \case
   'A' -> pure CCTContact
   'C' -> pure CCTChannel
-  'G' -> pure CCTGroup
-  'R' -> pure CCTRelay
+  'G' -> pure CCTGroup 
   _ -> fail "unknown contact address type"
 {-# INLINE ctTypeP #-}
 
@@ -1618,7 +1549,6 @@ 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.
@@ -1627,16 +1557,15 @@ shortenShortLink presetSrvs = \case
   CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (shortServer srv) lnkId linkKey
   CSLContact sch ct srv linkKey -> CSLContact sch ct (shortServer srv) linkKey
   where
-    shortServer srv@(SMPServer (h :| _) _ _) =
-      if isPresetServer srv presetSrvs then SMPServerOnlyHost h else srv
-
-isPresetServer :: Foldable t => SMPServer -> t SMPServer -> Bool
-isPresetServer srv@(SMPServer hs p kh) presetSrvs = case findPresetServer srv presetSrvs of
-  Just (SMPServer hs' p' kh') ->
-    all (`elem` hs') hs
-      && (p == p' || (null p' && (p == "443" || p == "5223")))
-      && kh == kh'
-  Nothing -> False
+    shortServer srv@(SMPServer hs@(h :| _) p kh) =
+      if isPresetServer then SMPServerOnlyHost h else srv
+      where
+        isPresetServer = case findPresetServer srv presetSrvs of
+          Just (SMPServer hs' p' kh') ->
+            all (`elem` hs') hs
+              && (p == p' || (null p' && (p == "443" || p == "5223")))
+              && kh == kh'
+          Nothing -> False
 
 -- explicit bidirectional is used for ghc 8.10.7 compatibility, [h]/[] patterns are not reversible.
 pattern SMPServerOnlyHost :: TransportHost -> SMPServer
@@ -1654,7 +1583,7 @@ restoreShortLink presetSrvs = \case
       s@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs
       s -> s
 
-findPresetServer :: Foldable t => SMPServer -> t SMPServer -> Maybe SMPServer
+findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer
 findPresetServer ProtocolServer {host = h :| _} = find (\ProtocolServer {host = h' :| _} -> h == h')
 {-# INLINE findPresetServer #-}
 
@@ -1691,36 +1620,24 @@ data FixedLinkData c = FixedLinkData
   }
 
 data ConnLinkData c where
-  InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
-  ContactLinkData :: VersionRangeSMPA -> UserContactData -> ConnLinkData 'CMContact
-
-data UserContactData = UserContactData
-  { -- 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
-  }
-
-newtype UserLinkData = UserLinkData ByteString
+  InvitationLinkData :: VersionRangeSMPA -> ConnInfo -> 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 :: ConnInfo
+    } -> ConnLinkData 'CMContact
 
 data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m)
 
-data UserConnLinkData c where
-  UserInvLinkData :: UserLinkData -> UserConnLinkData 'CMInvitation
-  UserContactLinkData :: UserContactData -> UserConnLinkData 'CMContact
-
-linkUserData :: ConnLinkData c -> UserLinkData
+linkUserData :: ConnLinkData c -> ConnInfo
 linkUserData = \case
   InvitationLinkData _ d -> d
-  ContactLinkData _ UserContactData {userData} -> userData
-{-# INLINE linkUserData #-}
-
-linkUserData' :: ConnLinkData c -> ByteString
-linkUserData' d = let UserLinkData s = linkUserData d in s
-{-# INLINE linkUserData' #-}
+  ContactLinkData {userData} -> userData
 
 type OwnerId = ByteString
 
@@ -1756,8 +1673,8 @@ instance ConnectionModeI c => Encoding (FixedLinkData c) where
 instance ConnectionModeI c => Encoding (ConnLinkData c) where
   smpEncode = \case
     InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData)
-    ContactLinkData vr UserContactData {direct, owners, relays, userData} ->
-      B.concat [smpEncode (CMContact, vr, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
+    ContactLinkData {agentVRange, direct, owners, relays, userData} ->
+      B.concat [smpEncode (CMContact, agentVRange, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
   smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP
   {-# INLINE smpP #-}
 
@@ -1767,31 +1684,14 @@ instance Encoding AConnLinkData where
   smpP =
     smpP >>= \case
       CMInvitation -> do
-        (vr, userData) <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
+        (vr, userData) <- smpP
         pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
       CMContact -> do
-        (vr, direct) <- smpP
+        (agentVRange, direct) <- smpP
         owners <- smpListP
         relays <- smpListP
-        userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
-        let cd = UserContactData {direct, owners, relays, userData}
-        pure $ ACLD SCMContact $ ContactLinkData vr cd
-
-instance Encoding UserLinkData where
-  smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s)
-  {-# INLINE smpEncode #-}
-  smpP = UserLinkData <$> ((A.char '\255' *> (unLarge <$> smpP)) <|> smpP)
-  {-# INLINE smpP #-}
-
-data StoredClientService (s :: DBStored) = ClientService
-  { dbServiceId :: DBEntityId' s,
-    serviceId :: SMP.ServiceId
-  }
-  deriving (Eq, Show)
-
-type ClientService = StoredClientService 'DBStored
-
-type ClientServiceId = DBEntityId
+        userData <- smpP
+        pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData}
 
 -- | SMP queue status.
 data QueueStatus
@@ -1862,7 +1762,7 @@ data AgentErrorType
   = -- | command or response error
     CMD {cmdErr :: CommandErrorType, errContext :: String}
   | -- | connection errors
-    CONN {connErr :: ConnectionErrorType, errContext :: String}
+    CONN {connErr :: ConnectionErrorType}
   | -- | user not found in database
     NO_USER
   | -- | SMP protocol errors forwarded to agent clients
@@ -1881,8 +1781,6 @@ data AgentErrorType
     BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
     AGENT {agentErr :: SMPAgentError}
-  | -- | client notice
-    NOTICE {server :: Text, preset :: Bool, expiresAt :: Maybe UTCTime}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
   | -- | critical agent errors that should be shown to the user, optionally with restart button
@@ -1891,12 +1789,6 @@ 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
@@ -2004,7 +1896,7 @@ commandP binaryP =
     s :: Parser a -> Parser a
     s p = A.space *> p
     pqIKP :: Parser InitialKeys
-    pqIKP = strP_ <|> pure (IKLinkPQ PQSupportOff)
+    pqIKP = strP_ <|> pure (IKNoPQ PQSupportOff)
     pqSupP :: Parser PQSupport
     pqSupP = strP_ <|> pure PQSupportOff
 
@@ -2024,10 +1916,6 @@ serializeCommand = \case
 serializeBinary :: ByteString -> ByteString
 serializeBinary body = bshow (B.length body) <> "\n" <> body
 
-$(J.deriveJSON (enumJSON fstToLower) ''QueueStatus)
-
-$(J.deriveJSON (sumTypeJSON $ dropPrefix "SS") ''SubscriptionStatus)
-
 $(J.deriveJSON defaultJSON ''RcvQueueInfo)
 
 $(J.deriveJSON defaultJSON ''SndQueueInfo)

src/Simplex/Messaging/Agent/Store.hs

@@ -29,11 +29,10 @@ 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 (MigrationConfig (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
 import Simplex.Messaging.Encoding.String
@@ -49,22 +48,34 @@ import Simplex.Messaging.Protocol
     RcvNtfDhSecret,
     RcvPrivateAuthKey,
     SndPrivateAuthKey,
+    SndPublicAuthKey,
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util (AnyError (..), bshow)
 
-createStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
+createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createStore dbOpts = createDBStore dbOpts appMigrations
 
 -- * Queue types
 
-type RcvQueue = StoredRcvQueue 'DBStored
+data QueueStored = QSStored | QSNew
 
-type NewRcvQueue = StoredRcvQueue 'DBNew
+data SQueueStored (q :: QueueStored) where
+  SQSStored :: SQueueStored 'QSStored
+  SQSNew :: SQueueStored 'QSNew
+
+data DBQueueId (q :: QueueStored) where
+  DBQueueId :: Int64 -> DBQueueId 'QSStored
+  DBNewQueue :: DBQueueId 'QSNew
+
+deriving instance Show (DBQueueId q)
+
+type RcvQueue = StoredRcvQueue 'QSStored
+
+type NewRcvQueue = StoredRcvQueue 'QSNew
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
-data StoredRcvQueue (q :: DBStored) = RcvQueue
+data StoredRcvQueue (q :: QueueStored) = RcvQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -84,16 +95,10 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
     queueMode :: Maybe QueueMode,
     -- | short link ID and credentials
     shortLink :: Maybe ShortLinkCreds,
-    -- | associated client service
-    clientService :: Maybe (StoredClientService q),
     -- | queue status
     status :: QueueStatus,
-    -- | to enable notifications for this queue - this field is duplicated from ConnData
-    enableNtfs :: Bool,
-    -- | client notice
-    clientNoticeId :: Maybe NoticeId,
     -- | database queue ID (within connection)
-    dbQueueId :: DBEntityId' q,
+    dbQueueId :: DBQueueId q,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
@@ -107,25 +112,6 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
   }
   deriving (Show)
 
-data RcvQueueSub = RcvQueueSub
-  { userId :: UserId,
-    connId :: ConnId,
-    server :: SMPServer,
-    rcvId :: SMP.RecipientId,
-    rcvPrivateKey :: RcvPrivateAuthKey,
-    status :: QueueStatus,
-    enableNtfs :: Bool,
-    clientNoticeId :: Maybe NoticeId,
-    dbQueueId :: Int64,
-    primary :: Bool,
-    dbReplaceQueueId :: Maybe Int64
-  }
-  deriving (Show)
-
-rcvQueueSub :: RcvQueue -> RcvQueueSub
-rcvQueueSub RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId = DBEntityId dbQueueId, primary, dbReplaceQueueId} =
-  RcvQueueSub {userId, connId, server, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
-
 data ShortLinkCreds = ShortLinkCreds
   { shortLinkId :: SMP.LinkId,
     shortLinkKey :: LinkKey,
@@ -134,13 +120,9 @@ data ShortLinkCreds = ShortLinkCreds
   }
   deriving (Show)
 
-clientServiceId :: RcvQueue -> Maybe ClientServiceId
-clientServiceId = fmap dbServiceId . clientService
-{-# INLINE clientServiceId #-}
-
-rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
-rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
-  SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
+rcvQueueInfo :: RcvQueue -> RcvQueueInfo
+rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
+  RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
 
 canAbortRcvSwitch :: RcvQueue -> Bool
 canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
@@ -173,16 +155,17 @@ data InvShortLink = InvShortLink
     linkId :: SMP.LinkId,
     linkKey :: LinkKey,
     sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries
+    sndPublicKey :: SndPublicAuthKey,
     sndId :: Maybe SMP.SenderId
   }
   deriving (Show)
 
-type SndQueue = StoredSndQueue 'DBStored
+type SndQueue = StoredSndQueue 'QSStored
 
-type NewSndQueue = StoredSndQueue 'DBNew
+type NewSndQueue = StoredSndQueue 'QSNew
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
-data StoredSndQueue (q :: DBStored) = SndQueue
+data StoredSndQueue (q :: QueueStored) = SndQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -190,7 +173,9 @@ data StoredSndQueue (q :: DBStored) = SndQueue
     sndId :: SMP.SenderId,
     -- | sender can secure the queue
     queueMode :: Maybe QueueMode,
-    -- | sender key used to authorize transmissions
+    -- | key pair used by the sender to authorize transmissions
+    -- TODO combine keys to key pair so that types match
+    sndPublicKey :: SndPublicAuthKey,
     sndPrivateKey :: SndPrivateAuthKey,
     -- | DH public key used to negotiate per-queue e2e encryption
     e2ePubKey :: Maybe C.PublicKeyX25519,
@@ -199,7 +184,7 @@ data StoredSndQueue (q :: DBStored) = SndQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: DBEntityId' q,
+    dbQueueId :: DBQueueId q,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
     primary :: Bool,
     -- | ID of the queue this one is replacing
@@ -210,6 +195,10 @@ data StoredSndQueue (q :: DBStored) = SndQueue
   }
   deriving (Show)
 
+sndQueueInfo :: SndQueue -> SndQueueInfo
+sndQueueInfo SndQueue {server, sndSwchStatus} =
+  SndQueueInfo {sndServer = server, sndSwitchStatus = sndSwchStatus}
+
 instance SMPQueue RcvQueue where
   qServer RcvQueue {server} = server
   {-# INLINE qServer #-}
@@ -222,12 +211,6 @@ instance SMPQueue NewRcvQueue where
   queueId RcvQueue {rcvId} = rcvId
   {-# INLINE queueId #-}
 
-instance SMPQueue RcvQueueSub where
-  qServer RcvQueueSub {server} = server
-  {-# INLINE qServer #-}
-  queueId RcvQueueSub {rcvId} = rcvId
-  {-# INLINE queueId #-}
-
 instance SMPQueue SndQueue where
   qServer SndQueue {server} = server
   {-# INLINE qServer #-}
@@ -267,7 +250,6 @@ class SMPQueue q => SMPQueueRec q where
   qUserId :: q -> UserId
   qConnId :: q -> ConnId
   dbQId :: q -> Int64
-  qPrimary :: q -> Bool
   dbReplaceQId :: q -> Maybe Int64
 
 instance SMPQueueRec RcvQueue where
@@ -275,48 +257,21 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qUserId #-}
   qConnId RcvQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId RcvQueue {dbQueueId = DBEntityId qId} = qId
+  dbQId RcvQueue {dbQueueId = DBQueueId qId} = qId
   {-# INLINE dbQId #-}
-  qPrimary RcvQueue {primary} = primary
-  {-# INLINE qPrimary #-}
   dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
 
-instance SMPQueueRec RcvQueueSub where
-  qUserId RcvQueueSub {userId} = userId
-  {-# INLINE qUserId #-}
-  qConnId RcvQueueSub {connId} = connId
-  {-# INLINE qConnId #-}
-  dbQId RcvQueueSub {dbQueueId} = dbQueueId
-  {-# INLINE dbQId #-}
-  qPrimary RcvQueueSub {primary} = primary
-  {-# INLINE qPrimary #-}
-  dbReplaceQId RcvQueueSub {dbReplaceQueueId} = dbReplaceQueueId
-  {-# INLINE dbReplaceQId #-}
-
 instance SMPQueueRec SndQueue where
   qUserId SndQueue {userId} = userId
   {-# INLINE qUserId #-}
   qConnId SndQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId SndQueue {dbQueueId = DBEntityId qId} = qId
+  dbQId SndQueue {dbQueueId = DBQueueId qId} = qId
   {-# INLINE dbQId #-}
-  qPrimary SndQueue {primary} = primary
-  {-# INLINE qPrimary #-}
   dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
 
-class SMPQueueRec q => SomeRcvQueue q where
-  rcvAuthKey :: q -> RcvPrivateAuthKey
-
-instance SomeRcvQueue RcvQueue where
-  rcvAuthKey RcvQueue {rcvPrivateKey} = rcvPrivateKey
-  {-# INLINE rcvAuthKey #-}
-
-instance SomeRcvQueue RcvQueueSub where
-  rcvAuthKey RcvQueueSub {rcvPrivateKey} = rcvPrivateKey
-  {-# INLINE rcvAuthKey #-}
-
 -- * Connection types
 
 -- | Type of a connection.
@@ -332,18 +287,16 @@ data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 --
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
-data Connection' (d :: ConnType) rq sq where
-  NewConnection :: ConnData -> Connection' CNew rq sq
-  RcvConnection :: ConnData -> rq -> Connection' CRcv rq sq
-  SndConnection :: ConnData -> sq -> Connection' CSnd rq sq
-  DuplexConnection :: ConnData -> NonEmpty rq -> NonEmpty sq -> Connection' CDuplex rq sq
-  ContactConnection :: ConnData -> rq -> Connection' CContact rq sq
+data Connection (d :: ConnType) where
+  NewConnection :: ConnData -> Connection CNew
+  RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
+  SndConnection :: ConnData -> SndQueue -> Connection CSnd
+  DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
+  ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
-deriving instance (Show rq, Show sq) => Show (Connection' d rq sq)
+deriving instance Show (Connection d)
 
-type Connection d = Connection' d RcvQueue SndQueue
-
-toConnData :: Connection' d rq sq -> ConnData
+toConnData :: Connection d -> ConnData
 toConnData = \case
   NewConnection cData -> cData
   RcvConnection cData _ -> cData
@@ -351,7 +304,7 @@ toConnData = \case
   DuplexConnection cData _ _ -> cData
   ContactConnection cData _ -> cData
 
-updateConnection :: ConnData -> Connection' d rq sq -> Connection' d rq sq
+updateConnection :: ConnData -> Connection d -> Connection d
 updateConnection cData = \case
   NewConnection _ -> NewConnection cData
   RcvConnection _ rq -> RcvConnection cData rq
@@ -384,13 +337,9 @@ instance TestEquality SConnType where
 
 -- | Connection of an unknown type.
 -- Used to refer to an arbitrary connection when retrieving from store.
-data SomeConn' rq sq = forall d. SomeConn (SConnType d) (Connection' d rq sq)
+data SomeConn = forall d. SomeConn (SConnType d) (Connection d)
 
-deriving instance (Show rq, Show sq) => Show (SomeConn' rq sq)
-
-type SomeConn = SomeConn' RcvQueue SndQueue
-
-type SomeConnSub = SomeConn' RcvQueueSub SndQueue
+deriving instance Show SomeConn
 
 data ConnData = ConnData
   { connId :: ConnId,
@@ -404,8 +353,6 @@ data ConnData = ConnData
   }
   deriving (Eq, Show)
 
-type NoticeId = Int64
-
 -- this function should be mirrored in the clients
 ratchetSyncAllowed :: ConnData -> Bool
 ratchetSyncAllowed ConnData {ratchetSyncState, connAgentVersion} =
@@ -569,7 +516,7 @@ data NewInvitation = NewInvitation
 
 data Invitation = Invitation
   { invitationId :: InvitationId,
-    contactConnId_ :: Maybe ConnId,
+    contactConnId :: ConnId,
     connReq :: ConnectionRequestUri 'CMInvitation,
     recipientConnInfo :: ConnInfo,
     ownConnInfo :: Maybe ConnInfo,
@@ -720,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 String ConnType
+    SEBadConnType ConnType
   | -- | Confirmation not found.
     SEConfirmationNotFound
   | -- | Invitation not found
     SEInvitationNotFound String InvitationId
   | -- | Message not found
-    SEMsgNotFound String
+    SEMsgNotFound
   | -- | Command not found
     SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
@@ -746,20 +693,7 @@ data StoreError
   | -- | XFTP Deleted snd chunk replica not found.
     SEDeletedSndChunkReplicaNotFound
   | -- | Error when reading work item that suspends worker - do not use!
-    SEWorkItemError {errContext :: String}
+    SEWorkItemError ByteString
   | -- | 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

@@ -28,7 +28,6 @@
 module Simplex.Messaging.Agent.Store.AgentStore
   ( -- * Users
     createUserRecord,
-    getUserIds,
     deleteUserRecord,
     setUserDeleted,
     deleteUserWithoutConns,
@@ -40,18 +39,11 @@ module Simplex.Messaging.Agent.Store.AgentStore
     updateNewConnRcv,
     updateNewConnSnd,
     createSndConn,
-    getClientNotices,
-    updateClientNotices,
-    getSubscriptionServers,
-    getUserServerRcvQueueSubs,
-    unsetQueuesToSubscribe,
-    getConnIds,
     getConn,
     getDeletedConn,
     getConns,
-    getConnSubs,
     getDeletedConns,
-    getConnsData,
+    getConnData,
     setConnDeleted,
     setConnUserId,
     setConnAgentVersion,
@@ -117,7 +109,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
     updateSndMsgRcpt,
     getPendingQueueMsg,
     getConnectionsForDelivery,
-    getAllSndQueuesForDelivery,
     updatePendingMsgRIState,
     deletePendingMsgs,
     getExpiredSndMessages,
@@ -145,7 +136,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
     -- Async commands
     createCommand,
     getPendingCommandServers,
-    getAllPendingCommandConns,
     getPendingServerCommand,
     updateCommandServer,
     deleteCommand,
@@ -247,8 +237,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
     firstRow',
     maybeFirstRow,
     fromOnlyBI,
-    getWorkItem,
-    getWorkItems,
   )
 where
 
@@ -266,11 +254,9 @@ import Data.Int (Int64)
 import Data.List (foldl', sortBy)
 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, mapMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
 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)
@@ -286,8 +272,6 @@ import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.Common
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
-import Simplex.Messaging.Agent.Store.Entity
-import Simplex.Messaging.Client (SMPTransportSession)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
@@ -299,16 +283,13 @@ import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Protocol.Types
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util
+import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
 import Simplex.Messaging.Version.Internal
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 #if defined(dbPostgres)
-import Data.List (sortOn)
-import Database.PostgreSQL.Simple (In (..), Only (..), Query, SqlError, (:.) (..))
+import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..))
 import Database.PostgreSQL.Simple.Errors (constraintViolation)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 #else
@@ -337,10 +318,6 @@ createUserRecord db = do
   DB.execute_ db "INSERT INTO users DEFAULT VALUES"
   insertedRowId db
 
-getUserIds :: DB.Connection -> IO [UserId]
-getUserIds db =
-  map fromOnly <$> DB.query_ db "SELECT user_id FROM users WHERE deleted = 0"
-
 checkUser :: DB.Connection -> UserId -> IO (Either StoreError ())
 checkUser db userId =
   firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $
@@ -403,22 +380,21 @@ createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode
 createNewConn db gVar cData cMode = do
   fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode)
 
--- TODO [certs rcv] store clientServiceId from NewRcvQueue
-updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
-updateNewConnRcv db connId rq subMode =
+updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
+updateNewConnRcv db connId rq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
     (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
-    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
   where
     updateConn :: IO (Either StoreError RcvQueue)
-    updateConn = Right <$> addConnRcvQueue_ db connId rq subMode
+    updateConn = Right <$> addConnRcvQueue_ db connId rq
 
 updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 updateNewConnSnd db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
-    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
   where
     updateConn :: IO (Either StoreError SndQueue)
     updateConn = Right <$> addConnSndQueue_ db connId sq
@@ -446,12 +422,15 @@ 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} =
-  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)
+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)
+      )
 
 getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
 getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
@@ -491,34 +470,32 @@ 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 "upgradeRcvConnToDuplex" $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
 
--- TODO [certs rcv] store clientServiceId from NewRcvQueue
-upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
-upgradeSndConnToDuplex db connId rq subMode =
+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 subMode
-    Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
+    Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
+    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
--- TODO [certs rcv] store clientServiceId from NewRcvQueue
-addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
-addConnRcvQueue db connId rq subMode =
+addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
+addConnRcvQueue db connId rq =
   getConn db connId >>= \case
-    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq subMode
-    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
+    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
+    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
-addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO RcvQueue
-addConnRcvQueue_ db connId rq@RcvQueue {server} subMode = do
+addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
+addConnRcvQueue_ db connId rq@RcvQueue {server} = do
   serverKeyHash_ <- createServer_ db server
-  insertRcvQueue_ db connId rq subMode serverKeyHash_
+  insertRcvQueue_ db connId rq serverKeyHash_
 
 addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 addConnSndQueue db connId sq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
 addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
@@ -747,7 +724,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)
 
@@ -764,8 +741,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 =
@@ -783,9 +760,12 @@ 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 -> InvitationId -> IO ()
-deleteInvitation db invId =
-  DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId))
+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
 
 getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
 getInvShortLink db server linkId =
@@ -800,12 +780,13 @@ getInvShortLink db server linkId =
       (host server, port server, linkId)
   where
     toInvShortLink :: (LinkKey, C.APrivateAuthKey, Maybe SenderId) -> InvShortLink
-    toInvShortLink (linkKey, sndPrivateKey, sndId) =
-      InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId}
+    toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk), sndId) =
+      let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk
+       in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId}
 
-getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.APrivateAuthKey))
+getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.AAuthKeyPair))
 getInvShortLinkKeys db srv sndId =
-  maybeFirstRow id $
+  maybeFirstRow toSndKeys $
     DB.query
       db
       [sql|
@@ -814,6 +795,9 @@ getInvShortLinkKeys db srv sndId =
         WHERE host = ? AND port = ? AND snd_id = ?
       |]
       (host srv, port srv, sndId)
+  where
+    toSndKeys :: (LinkId, C.APrivateAuthKey) -> (LinkId, C.AAuthKeyPair)
+    toSndKeys (linkId, privKey@(C.APrivateAuthKey a pk)) = (linkId, (C.APublicAuthKey a $ C.publicKey pk, privKey))
 
 deleteInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO ()
 deleteInvShortLink db srv lnkId =
@@ -874,7 +858,7 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta =
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
   setLastBrokerTs db connId dbQueueId brokerTs
 
-setLastBrokerTs :: DB.Connection -> ConnId -> DBEntityId -> UTCTime -> IO ()
+setLastBrokerTs :: DB.Connection -> ConnId -> DBQueueId 'QSStored -> UTCTime -> IO ()
 setLastBrokerTs db connId dbQueueId brokerTs =
   DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ? AND (last_broker_ts IS NULL OR last_broker_ts < ?)" (brokerTs, connId, dbQueueId, brokerTs)
 
@@ -900,13 +884,13 @@ createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do
   insertSndMsgDetails_ db connId sndMsgData
   updateSndMsgHash db connId internalSndId internalHash
 
-createSndMsgDelivery :: DB.Connection -> SndQueue -> InternalId -> IO ()
-createSndMsgDelivery db SndQueue {connId, dbQueueId} msgId =
+createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
+createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
   DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId)
 
 getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
 getSndMsgViaRcpt db connId sndMsgId =
-  firstRow toSndMsg (SEMsgNotFound "getSndMsgViaRcpt") $
+  firstRow toSndMsg SEMsgNotFound $
     DB.query
       db
       [sql|
@@ -933,15 +917,6 @@ getConnectionsForDelivery :: DB.Connection -> IO [ConnId]
 getConnectionsForDelivery db =
   map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0"
 
-getAllSndQueuesForDelivery :: DB.Connection -> IO [SndQueue]
-getAllSndQueuesForDelivery db = map toSndQueue <$> DB.query_ db (sndQueueQuery <> " " <> delivery)
-  where
-    delivery = [sql|
-      JOIN (SELECT DISTINCT conn_id, snd_queue_id FROM snd_message_deliveries WHERE failed = 0) d
-      ON d.conn_id = q.conn_id AND d.snd_queue_id = q.snd_queue_id
-      WHERE c.deleted = 0
-    |]
-
 getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
 getPendingQueueMsg db connId SndQueue {dbQueueId} =
   getWorkItem "message" getMsgId getMsgData markMsgFailed
@@ -990,25 +965,28 @@ 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, AnyStoreError e) => String -> IO (Maybe i) -> (i -> IO (Either e a)) -> (i -> IO ()) -> IO (Either e (Maybe a))
+getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
 getWorkItem itemName getId getItem markFailed =
   runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed)
 
-getWorkItems :: (Show i, AnyStoreError e) => String -> IO [i] -> (i -> IO (Either e a)) -> (i -> IO ()) -> IO (Either e [Either e a])
+getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a])
 getWorkItems itemName getIds getItem markFailed =
   runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
 
-tryGetItem :: (Show i, 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
+tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
+tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
   where
-    mark = handleWrkErr itemName ("markFailed ID " <> show itemId) $ markFailed itemId
+    mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
+
+catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
+catchStoreError = catchAllErrors (SEInternal . bshow)
 
 -- Errors caught by this function will suspend worker as if there is no more work,
-handleWrkErr :: forall e a. AnyStoreError e => String -> String -> IO a -> ExceptT e IO a
+handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
 handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
   where
-    mkError :: E.SomeException -> e
-    mkError e = mkWorkItemError $ itemName <> " " <> opName <> " error: " <> show e
+    mkError :: E.SomeException -> StoreError
+    mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
 
 updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
 updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
@@ -1048,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 "setMsgUserAck") $
+    ExceptT . firstRow id SEMsgNotFound $
       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)
@@ -1056,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 "getRcvMsg") $
+  firstRow toRcvMsg SEMsgNotFound $
     DB.query
       db
       [sql|
@@ -1094,16 +1072,19 @@ 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 =
-  maybeFirstRow' False fromOnlyBI $
-    DB.query
-      db
-      "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-      (connId, Binary hash)
+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)
+      )
 
 getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
 getRcvMsgBrokerTs db connId msgId =
-  firstRow fromOnly (SEMsgNotFound "getRcvMsgBrokerTs") $
+  firstRow fromOnly SEMsgNotFound $
     DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId)
 
 deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
@@ -1231,7 +1212,7 @@ getSndRatchet db connId v =
     DB.query db "SELECT ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem FROM ratchets WHERE conn_id = ?" (Only connId)
   where
     result = \case
-      (Just ratchetState, Just k1, Just k2, pKem_) ->
+      (Just ratchetState, Just k1, Just k2, pKem_) -> 
         let params = case pKem_ of
               Nothing -> CR.AE2ERatchetParams CR.SRKSProposed (CR.E2ERatchetParams v k1 k2 Nothing)
               Just (CR.ARKP s pKem) -> CR.AE2ERatchetParams s (CR.E2ERatchetParams v k1 k2 (Just pKem))
@@ -1323,41 +1304,21 @@ insertedRowId db = fromOnly . head <$> DB.query_ db q
     q = "SELECT last_insert_rowid()"
 #endif
 
-getPendingCommandServers :: DB.Connection -> [ConnId] -> IO [(ConnId, NonEmpty (Maybe SMPServer))]
-getPendingCommandServers db connIds =
+getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer]
+getPendingCommandServers db connId = do
   -- TODO review whether this can break if, e.g., the server has another key hash.
-  mapMaybe connServers . groupOn' rowConnId
-    <$> DB.query_
+  map smpServer
+    <$> DB.query
       db
       [sql|
-        SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
+        SELECT DISTINCT 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
-        ORDER BY c.conn_id
+        WHERE 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
-
-getAllPendingCommandConns :: DB.Connection -> IO [(ConnId, Maybe SMPServer)]
-getAllPendingCommandConns db =
-  map toResult
-    <$> DB.query_
-      db
-      [sql|
-        SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
-        FROM commands c
-        JOIN connections cs ON c.conn_id = cs.conn_id
-        LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
-        WHERE cs.deleted = 0
-      |]
-  where
-    toResult (connId, host, port, keyHash) = (connId, SMPServer <$> host <*> port <*> keyHash)
 
 getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
 getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
@@ -1850,6 +1811,15 @@ instance ToField QueueStatus where toField = toField . serializeQueueStatus
 
 instance FromField QueueStatus where fromField = fromTextField_ queueStatusT
 
+instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId
+
+instance FromField (DBQueueId 'QSStored) where 
+#if defined(dbPostgres)
+  fromField x dat = DBQueueId <$> fromField x dat
+#else
+  fromField x = DBQueueId <$> fromField x
+#endif
+
 instance ToField InternalRcvId where toField (InternalRcvId x) = toField x
 
 deriving newtype instance FromField InternalRcvId
@@ -1995,8 +1965,8 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> Maybe C.KeyHash -> IO RcvQueue
-insertRcvQueue_ db connId' rq@RcvQueue {..} subMode serverKeyHash_ = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue
+insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
   -- to preserve ID if the queue already exists.
   -- possibly, it can be done in one query.
   currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId)
@@ -2006,24 +1976,15 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} subMode serverKeyHash_ = do
     [sql|
       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, to_subscribe, 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,
-          ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
-        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
+          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 (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
-        :. (sndId, queueMode, status, BI toSubscribe, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
+        :. (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
-    toSubscribe = subMode == SMOnlyCreate
-    ntfCredsFields = case clientNtfCreds of
-      Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
-        (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
-      Nothing -> (Nothing, Nothing, Nothing, Nothing)
+  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
 
 -- * createSndConn helpers
 
@@ -2037,15 +1998,16 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
     db
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, queue_mode, conn_id, snd_private_key, e2e_pub_key, e2e_dh_secret,
+        (host, port, snd_id, queue_mode, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret,
          status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash)
-      VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+      VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
       ON CONFLICT (host, port, snd_id) DO UPDATE SET
         host=EXCLUDED.host,
         port=EXCLUDED.port,
         snd_id=EXCLUDED.snd_id,
         queue_mode=EXCLUDED.queue_mode,
         conn_id=EXCLUDED.conn_id,
+        snd_public_key=EXCLUDED.snd_public_key,
         snd_private_key=EXCLUDED.snd_private_key,
         e2e_pub_key=EXCLUDED.e2e_pub_key,
         e2e_dh_secret=EXCLUDED.e2e_dh_secret,
@@ -2056,116 +2018,16 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
         smp_client_version=EXCLUDED.smp_client_version,
         server_key_hash=EXCLUDED.server_key_hash
     |]
-    ((host server, port server, sndId, queueMode, connId', sndPrivateKey, e2ePubKey, e2eDhSecret)
+    ((host server, port server, sndId, queueMode, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) 
     :. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
   pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
 
-newQueueId_ :: [Only Int64] -> DBEntityId
-newQueueId_ [] = DBEntityId 1
-newQueueId_ (Only maxId : _) = DBEntityId (maxId + 1)
-
--- * subscribe all connections
-
-getClientNotices :: DB.Connection -> [SMPServer] -> IO (Map (Maybe SMPServer) (Maybe SystemSeconds))
-getClientNotices db presetSrvs =
-  M.map expiresAt . foldl' addNotice M.empty
-    <$> DB.query_
-      db
-      [sql|
-        SELECT n.host, n.port, n.entity_id, COALESCE(n.server_key_hash, s.key_hash), n.created_at, n.notice_ttl
-        FROM client_notices n
-        JOIN servers s ON n.host = s.host AND n.port = s.port
-        WHERE n.protocol = 'smp'
-      |]
-  where
-    expiresAt (createdAt, ttl)  = RoundedSystemTime . (createdAt +) <$> ttl
-    addNotice ::
-      Map (Maybe SMPServer) (Int64, Maybe Int64) ->
-      (NonEmpty TransportHost, ServiceName, RecipientId, C.KeyHash, Int64, Maybe Int64) ->
-      Map (Maybe SMPServer) (Int64, Maybe Int64)
-    addNotice m (host, port, _, keyHash, createdAt', ttl') =
-      let srv = SMPServer host port keyHash
-          srvKey
-            | isPresetServer srv presetSrvs = Nothing
-            | otherwise = Just srv
-       in M.alter (Just . addNoticeHost) srvKey m
-      where
-        -- sum of ttls starting from the latest createdAt
-        addNoticeHost :: Maybe (Int64, Maybe Int64) -> (Int64, Maybe Int64)
-        addNoticeHost = \case
-          Just (createdAt, ttl) -> (max createdAt createdAt', (+) <$> ttl <*> ttl')
-          Nothing -> (createdAt', ttl')
-
-updateClientNotices :: DB.Connection -> SMPTransportSession -> SystemSeconds -> [(RcvQueueSub, Maybe ClientNotice)] -> IO [(RecipientId, Maybe NoticeId)]
-updateClientNotices db (_, srv, _) now =
-  mapM $ \(rq, notice_) -> maybe (deleteNotice rq) (upsertNotice rq) notice_
-  where
-    deleteNotice RcvQueueSub {rcvId, clientNoticeId} = do
-      mapM_ (DB.execute db "DELETE FROM client_notices WHERE client_notice_id = ?" . Only) clientNoticeId
-      pure (rcvId, Nothing)
-    upsertNotice RcvQueueSub {rcvId, server} ClientNotice {ttl} =
-      getServerKeyHash_ db server >>= \case
-        Left _ -> pure (rcvId, Nothing)
-        Right keyHash_ -> do
-          noticeId_ <-
-            maybeFirstRow fromOnly $
-              DB.query
-                db
-                [sql|
-                  INSERT INTO client_notices(protocol, host, port, entity_id, server_key_hash, notice_ttl, created_at, updated_at)
-                    VALUES ('smp',?,?,?,?,?,?,?)
-                  ON CONFLICT (protocol, host, port, entity_id)
-                  DO UPDATE SET
-                    server_key_hash = EXCLUDED.server_key_hash,
-                    notice_ttl = EXCLUDED.notice_ttl,
-                    updated_at = EXCLUDED.updated_at
-                  RETURNING client_notice_id
-                |]
-                (host srv, port srv, rcvId, keyHash_, ttl, now, now)
-          forM_ noticeId_ $ \noticeId -> do
-            DB.execute
-              db
-              "UPDATE rcv_queues SET client_notice_id = ? WHERE host = ? AND port = ?AND rcv_id = ?"
-              (noticeId, host srv, port srv, rcvId)
-          pure (rcvId, noticeId_)
-
-getSubscriptionServers :: DB.Connection -> Bool -> IO [(UserId, SMPServer)]
-getSubscriptionServers db onlyNeeded =
-  map toUserServer <$> DB.query_ db (select <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0")
-  where
-    select =
-      [sql|
-        SELECT DISTINCT c.user_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash)
-        FROM rcv_queues q
-        JOIN servers s ON q.host = s.host AND q.port = s.port
-        JOIN connections c ON q.conn_id = c.conn_id
-      |]
-    toSubscribe
-      | onlyNeeded = " WHERE q.to_subscribe = 1 AND "
-      | otherwise = " WHERE "
-    toUserServer :: (UserId, NonEmpty TransportHost, ServiceName, C.KeyHash) -> (UserId, SMPServer)
-    toUserServer (userId, host, port, keyHash) = (userId, SMPServer host port keyHash)
-
-getUserServerRcvQueueSubs :: DB.Connection -> UserId -> SMPServer -> Bool -> IO [RcvQueueSub]
-getUserServerRcvQueueSubs db userId srv onlyNeeded =
-  map toRcvQueueSub
-    <$> DB.query
-      db
-      (rcvQueueSubQuery <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0 AND c.user_id = ? AND q.host = ? AND q.port = ?")
-      (userId, host srv, port srv)
-  where
-    toSubscribe
-      | onlyNeeded = " WHERE q.to_subscribe = 1 AND "
-      | otherwise = " WHERE "
-
-unsetQueuesToSubscribe :: DB.Connection -> IO ()
-unsetQueuesToSubscribe db = DB.execute_ db "UPDATE rcv_queues SET to_subscribe = 0 WHERE to_subscribe = 1"
+newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
+newQueueId_ [] = DBQueueId 1
+newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
 
 -- * getConn helpers
 
-getConnIds :: DB.Connection -> IO [ConnId]
-getConnIds db = map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted = 0"
-
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getConn = getAnyConn False
 {-# INLINE getConn #-}
@@ -2175,138 +2037,52 @@ getDeletedConn = getAnyConn True
 {-# INLINE getDeletedConn #-}
 
 getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getAnyConn = getAnyConn_ getRcvQueuesByConnId_ getSndQueuesByConnId_
-{-# INLINE getAnyConn #-}
-
-getAnyConn_ ::
-  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty rq))) ->
-  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty sq))) ->
-  (Bool -> DB.Connection -> ConnId -> IO (Either StoreError (SomeConn' rq sq)))
-getAnyConn_ getRQs getSQs deleted' db connId =
-  getConnData deleted' db connId >>= \case
-    Just (cData, cMode) -> do
-      rQ <- getRQs db connId
-      sQ <- getSQs 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
+getAnyConn deleted' dbConn connId =
+  getConnData dbConn connId >>= \case
     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
+getConns = getAnyConns_ False
 {-# INLINE getConns #-}
 
 getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getDeletedConns = getAnyConns True
+getDeletedConns = getAnyConns_ True
 {-# INLINE getDeletedConns #-}
 
-#if defined(dbPostgres)
-getAnyConns :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn)]
-getAnyConns = getAnyConns_ getRcvQueuesByConnIds_ getSndQueuesByConnIds_
-{-# INLINE getAnyConns #-}
-
-getConnSubs :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
-getConnSubs = getAnyConns_ getRcvQueueSubsByConnIds_ getSndQueuesByConnIds_ False
-{-# INLINE getConnSubs #-}
-
-getAnyConns_ ::
-  forall rq sq.
-  (DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty rq))) ->
-  (DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty sq))) ->
-  (Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn' rq sq)])
-getAnyConns_ getRQs getSQs deleted' db connIds = do
-  cs <- getConnsData_ deleted' db connIds
-  let connIds' = M.keys cs
-  rQs :: Map ConnId (NonEmpty rq) <- getRQs db connIds'
-  sQs :: Map ConnId (NonEmpty sq) <- getSQs db connIds'
-  pure $ map (result cs rQs sQs) connIds
+getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
   where
-    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
+    handleDBError :: E.SomeException -> IO (Either StoreError SomeConn)
+    handleDBError = pure . Left . SEInternal . bshow
 
-getRcvQueuesByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty RcvQueue))
-getRcvQueuesByConnIds_ db connIds' =
-  toQueueMap toRcvQueue <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id IN ? AND q.deleted = 0") (Only (In connIds'))
-
-getSndQueuesByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty SndQueue))
-getSndQueuesByConnIds_ db connIds' =
-  toQueueMap toSndQueue <$> DB.query db (sndQueueQuery <> " WHERE q.conn_id IN ?") (Only (In connIds'))
-
-getRcvQueueSubsByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty RcvQueueSub))
-getRcvQueueSubsByConnIds_ db connIds' =
-  toQueueMap toRcvQueueSub <$> DB.query db (rcvQueueSubQuery <> " WHERE q.conn_id IN ? AND q.deleted = 0") (Only (In connIds'))
-
-toQueueMap :: SMPQueueRec q => (a -> q) -> [a] -> Map ConnId (NonEmpty q)
-toQueueMap toQueue =
-  M.fromList . map (\qs@(q :| _) -> (qConnId q, L.sortBy primaryFirst qs)) . groupOn' qConnId . sortOn qConnId . map toQueue
-
-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) <$>
+getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData db connId' =
+  maybeFirstRow cData $
     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 IN ? AND deleted = ?
+        WHERE conn_id = ?
       |]
-      (In connIds, BI deleted')
-
-#else
-getAnyConns :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getAnyConns = getAnyConns_ getRcvQueuesByConnId_ getSndQueuesByConnId_
-{-# INLINE getAnyConns #-}
-
-getConnSubs :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
-getConnSubs = getAnyConns_ getRcvQueueSubsByConnId_ getSndQueuesByConnId_ False
-{-# INLINE getConnSubs #-}
-
-getAnyConns_ ::
-  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty rq))) ->
-  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty sq))) ->
-  (Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn' rq sq)])
-getAnyConns_ getRQs getSQs deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn_ getRQs getSQs 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)
+      (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)
 
 setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
 setConnDeleted db waitDelivery connId
@@ -2344,12 +2120,15 @@ 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 =
-  maybeFirstRow' False fromOnlyBI $
-    DB.query
-      db
-      "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-      (connId, Binary hash)
+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)
+      )
 
 deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
 deleteRatchetKeyHashesExpired db ttl = do
@@ -2361,16 +2140,16 @@ getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue
 getRcvQueuesByConnId_ db connId =
   L.nonEmpty . sortBy primaryFirst . map toRcvQueue
     <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
-
--- the current primary queue is ordered first, the next primary - second
-primaryFirst :: SMPQueueRec q => q -> q -> Ordering
-primaryFirst q q' = compare (Down (qPrimary q)) (Down (qPrimary q')) <> compare (dbReplaceQId q) (dbReplaceQId q')
+  where
+    primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
+      -- the current primary queue is ordered first, the next primary - second
+      compare (Down p) (Down p') <> compare i i'
 
 rcvQueueQuery :: Query
 rcvQueueQuery =
   [sql|
     SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
-      q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id,
+      q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status,
       q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
       q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
       q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data
@@ -2381,13 +2160,13 @@ rcvQueueQuery =
 
 toRcvQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, Maybe QueueMode)
-    :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, DBEntityId, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
+    :. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
     :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret)
     :. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) ->
   RcvQueue
 toRcvQueue
   ( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode)
-      :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
+      :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
       :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)
       :. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_)
   ) =
@@ -2399,30 +2178,7 @@ toRcvQueue
       shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
         (Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
         _ -> Nothing
-      enableNtfs = maybe True unBI enableNtfs_
-      -- TODO [certs rcv] read client service
-   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, clientService = Nothing, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
-
--- | returns all connection queue credentials, the first queue is the primary one
-getRcvQueueSubsByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueueSub))
-getRcvQueueSubsByConnId_ db connId =
-  L.nonEmpty . sortBy primaryFirst . map toRcvQueueSub
-    <$> DB.query db (rcvQueueSubQuery <> " WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
-
-rcvQueueSubQuery :: Query
-rcvQueueSubQuery =
-  [sql|
-    SELECT c.user_id, q.conn_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id,
-      q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id
-    FROM rcv_queues q
-    JOIN servers s ON q.host = s.host AND q.port = s.port
-    JOIN connections c ON q.conn_id = c.conn_id
-  |]
-
-toRcvQueueSub :: (UserId, ConnId, NonEmpty TransportHost, ServiceName, C.KeyHash, SMP.RecipientId, SMP.RcvPrivateAuthKey) :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, Int64, BoolInt, Maybe Int64) -> RcvQueueSub
-toRcvQueueSub ((userId, connId, host, port, keyHash, rcvId, rcvPrivateKey) :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId)) =
-  let enableNtfs = maybe True unBI enableNtfs_
-   in RcvQueueSub {userId, connId, server = SMPServer host port keyHash, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
+   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
 
 getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
 getRcvQueueById db connId dbRcvId =
@@ -2434,13 +2190,17 @@ getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue
 getSndQueuesByConnId_ dbConn connId =
   L.nonEmpty . sortBy primaryFirst . map toSndQueue
     <$> DB.query dbConn (sndQueueQuery <> " WHERE q.conn_id = ?") (Only connId)
+  where
+    primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
+      -- the current primary queue is ordered first, the next primary - second
+      compare (Down p) (Down p') <> compare i i'
 
 sndQueueQuery :: Query
 sndQueueQuery =
   [sql|
     SELECT
       c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.queue_mode,
-      q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
+      q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
       q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
     FROM snd_queues q
     JOIN servers s ON q.host = s.host AND q.port = s.port
@@ -2449,16 +2209,17 @@ sndQueueQuery =
 
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode)
-    :. (SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (DBEntityId, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
+    :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
+    :. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId, queueMode)
-      :. (sndPrivateKey, e2ePubKey, e2eDhSecret, status)
+      :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status)
       :. (dbQueueId, BI primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
     ) =
     let server = SMPServer host port keyHash
-     in SndQueue {userId, connId, server, sndId, queueMode, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
+        sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey
+     in SndQueue {userId, connId, server, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
 
 getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
 getSndQueueById db connId dbSndId =
@@ -2767,7 +2528,6 @@ getRcvFile db rcvFileId = runExceptT $ do
               SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path
               FROM rcv_file_chunks
               WHERE rcv_file_id = ?
-              ORDER BY chunk_no ASC
             |]
             (Only rcvFileId)
       forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do
@@ -3145,8 +2905,8 @@ deleteSndFile' db sndFileId =
 
 getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool
 getSndFileDeleted db sndFileId =
-  maybeFirstRow' True fromOnlyBI $
-    DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)
+  fromMaybe True
+    <$> maybeFirstRow 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/Entity.hs

@@ -1,72 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Simplex.Messaging.Agent.Store.Entity where
-
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson as J
-import qualified Data.Aeson.Encoding as JE
-import Data.Int (Int64)
-import Data.Scientific (floatingOrInteger)
-import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
-
-data DBStored = DBStored | DBNew
-
-data SDBStored (s :: DBStored) where
-  SDBStored :: SDBStored 'DBStored
-  SDBNew :: SDBStored 'DBNew
-
-deriving instance Show (SDBStored s)
-
-class DBStoredI s where sdbStored :: SDBStored s
-
-instance DBStoredI 'DBStored where sdbStored = SDBStored
-
-instance DBStoredI 'DBNew where sdbStored = SDBNew
-
-data DBEntityId' (s :: DBStored) where
-  DBEntityId :: Int64 -> DBEntityId' 'DBStored
-  DBNewEntity :: DBEntityId' 'DBNew
-
-deriving instance Show (DBEntityId' s)
-
-deriving instance Eq (DBEntityId' s)
-
-type DBEntityId = DBEntityId' 'DBStored
-
-type DBNewEntity = DBEntityId' 'DBNew
-
-instance ToJSON (DBEntityId' s) where
-  toEncoding = \case
-    DBEntityId i -> toEncoding i
-    DBNewEntity -> JE.null_
-  toJSON = \case
-    DBEntityId i -> toJSON i
-    DBNewEntity -> J.Null
-
-instance DBStoredI s => FromJSON (DBEntityId' s) where
-  parseJSON v = case (v, sdbStored @s) of
-    (J.Null, SDBNew) -> pure DBNewEntity
-    (J.Number n, SDBStored) -> case floatingOrInteger n of
-      Left (_ :: Double) -> fail "bad DBEntityId"
-      Right i -> pure $ DBEntityId (fromInteger i)
-    _ -> fail "bad DBEntityId"
-  omittedField = case sdbStored @s of
-    SDBStored -> Nothing
-    SDBNew -> Just DBNewEntity
-
-instance FromField DBEntityId where
-#if defined(dbPostgres)
-  fromField x dat = DBEntityId <$> fromField x dat
-#else
-  fromField x = DBEntityId <$> fromField x
-#endif
-
-instance ToField DBEntityId where toField (DBEntityId i) = toField i

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 (isJust, isNothing, mapMaybe)
+import Data.Maybe (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 :: Maybe (IO ())
+    backup :: 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 = sequence (backup dbm) >> run dbm ms $> Right ()
-    confirm' err = confirmOrExit $ migrationErrorDescription (isJust $ backup dbm) err
+    runWithBackup ms = backup dbm >> run dbm ms $> Right ()
+    confirm err = confirmOrExit $ migrationErrorDescription err
 
 confirmOrExit :: String -> IO ()
 confirmOrExit s = do

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

@@ -8,7 +8,6 @@ module Simplex.Messaging.Agent.Store.Postgres
   ( DBOpts (..),
     Migrations.getCurrentMigrations,
     checkSchemaExists,
-    migrateDBSchema,
     createDBStore,
     closeDBStore,
     reopenDBStore,
@@ -31,36 +30,33 @@ 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 (..), MigrationConfig (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), 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] -> MigrationConfig -> IO (Either MigrationError DBStore)
-createDBStore opts migrations migrationConfig = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createDBStore opts migrations confirmMigrations = do
   st <- connectPostgresStore opts
-  r <- migrateDBSchema st opts Nothing migrations migrationConfig `onException` closeDBStore st
+  r <- migrateSchema st `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
     Left e -> closeDBStore st $> Left e
-
-migrateDBSchema :: DBStore -> DBOpts -> Maybe Query -> [Migration] -> MigrationConfig -> IO (Either MigrationError ())
-migrateDBSchema st _opts migrationsTable migrations MigrationConfig {confirm} =
-  let initialize = Migrations.initialize st migrationsTable
-      getCurrent = withTransaction st $ Migrations.getCurrentMigrations migrationsTable
-      run = Migrations.run st migrationsTable
-      dbm = DBMigrate {initialize, getCurrent, run, backup = Nothing}
-   in sharedMigrateSchema dbm (dbNew st) migrations confirm
+  where
+    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
 
 connectPostgresStore :: DBOpts -> IO DBStore
 connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do
   dbPriorityPool <- newDBStorePool poolSize
   dbPool <- newDBStorePool poolSize
   dbClosed <- newTVarIO True
-  let dbConnect = fst <$> connectDB connstr schema False
-      st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbConnect, dbNew = False, dbClosed}
+  let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbNew = False, dbClosed}
   dbNew <- connectStore st createSchema
   pure st {dbNew}
 

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Common
@@ -20,7 +19,7 @@ where
 
 import Control.Concurrent.MVar
 import Control.Concurrent.STM
-import qualified Control.Exception as E
+import Control.Exception (bracket)
 import Data.ByteString (ByteString)
 import qualified Database.PostgreSQL.Simple as PSQL
 import Numeric.Natural (Natural)
@@ -33,7 +32,11 @@ data DBStore = DBStore
     dbPoolSize :: Int,
     dbPriorityPool :: DBStorePool,
     dbPool :: DBStorePool,
-    dbConnect :: IO PSQL.Connection,
+    -- 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 (),
     dbClosed :: TVar Bool,
     dbNew :: Bool
   }
@@ -52,23 +55,15 @@ data DBStorePool = DBStorePool
   }
 
 withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
-withConnectionPriority DBStore {dbPriorityPool, dbPool, dbConnect} priority =
-  withConnectionPool (if priority then dbPriorityPool else dbPool) dbConnect
+withConnectionPriority DBStore {dbPriorityPool, dbPool} priority =
+  withConnectionPool $ if priority then dbPriorityPool else dbPool
 {-# INLINE withConnectionPriority #-}
 
-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'
+withConnectionPool :: DBStorePool -> (PSQL.Connection -> IO a) -> IO a
+withConnectionPool DBStorePool {dbPoolConns, dbSem} =
+  bracket
+    (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPoolConns)
+    (atomically . writeTBQueue dbPoolConns)
 
 withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withConnection st = withConnectionPriority st False

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

@@ -14,50 +14,55 @@ where
 import Control.Exception (throwIO)
 import Control.Monad (void)
 import qualified Data.ByteString.Char8 as B
-import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import Data.Time.Clock (getCurrentTime)
 import qualified Database.PostgreSQL.LibPQ as LibPQ
-import Database.PostgreSQL.Simple (Only (..), Query)
+import Database.PostgreSQL.Simple (Only (..))
 import qualified Database.PostgreSQL.Simple as PSQL
 import Database.PostgreSQL.Simple.Internal (Connection (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Shared
 import Simplex.Messaging.Util (($>>=))
 import UnliftIO.MVar
 
-initialize :: DBStore -> Maybe Query -> IO ()
-initialize st migrationsTable = withTransaction' st $ \db ->
-  void $ PSQL.execute_ db $
-    "CREATE TABLE IF NOT EXISTS "
-      <> fromMaybe "migrations" migrationsTable
-      <> " (name TEXT NOT NULL PRIMARY KEY, ts TIMESTAMP NOT NULL, down TEXT)"
+initialize :: DBStore -> IO ()
+initialize st = withTransaction' st $ \db ->
+  void $
+    PSQL.execute_
+      db
+      [sql|
+      CREATE TABLE IF NOT EXISTS migrations (
+        name TEXT NOT NULL,
+        ts TIMESTAMP NOT NULL,
+        down TEXT,
+        PRIMARY KEY (name)
+      )
+    |]
 
-run :: DBStore -> Maybe Query -> MigrationsToRun -> IO ()
-run st migrationsTable = \case
+run :: DBStore -> MigrationsToRun -> IO ()
+run st = \case
   MTRUp [] -> pure ()
   MTRUp ms -> mapM_ runUp ms
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where
-    table = fromMaybe "migrations" migrationsTable
     runUp Migration {name, up, down} = withTransaction' st $ \db -> do
       insert db
       execSQL db up
       where
-        insert db = void $ PSQL.execute db ("INSERT INTO " <> table <> " (name, down, ts) VALUES (?,?,?)") . (name,down,) =<< getCurrentTime
+        insert db = void $ PSQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
     runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do
       execSQL db downQuery
-      void $ PSQL.execute db ("DELETE FROM " <> table <> " WHERE name = ?") (Only downName)
+      void $ PSQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
     execSQL db query =
       withMVar (connectionHandle db) $ \pqConn ->
         LibPQ.exec pqConn (TE.encodeUtf8 query) $>>= LibPQ.resultErrorMessage >>= \case
           Just e | not (B.null e) -> throwIO $ userError $ B.unpack e
           _ -> pure ()
 
-getCurrentMigrations :: Maybe Query -> PSQL.Connection -> IO [Migration]
-getCurrentMigrations migrationsTable db = map toMigration <$> PSQL.query_ db ("SELECT name, down FROM " <> table <> " ORDER BY name ASC;")
+getCurrentMigrations :: PSQL.Connection -> IO [Migration]
+getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
   where
-    table = fromMaybe "migrations" migrationsTable
     toMigration (name, down) = Migration {name, up = T.pack "", down}

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

@@ -7,19 +7,13 @@ 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.Postgres.Migrations.M20251009_queue_to_subscribe
-import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notices
 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),
-    ("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete),
-    ("20251009_queue_to_subscribe", m20251009_queue_to_subscribe, Just down_m20251009_queue_to_subscribe),
-    ("20251010_client_notices", m20251010_client_notices, Just down_m20251010_client_notices)
+    ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -1,14 +1,15 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import Text.RawString.QQ (r)
 
 m20241210_initial :: Text
 m20241210_initial =
-  [r|
+  T.pack
+    [r|
 CREATE TABLE users(
   user_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
   deleted SMALLINT NOT NULL DEFAULT 0

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

@@ -1,14 +1,15 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import Text.RawString.QQ (r)
 
 m20250203_msg_bodies :: Text
 m20250203_msg_bodies =
-  [r|
+  T.pack
+    [r|
 ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BYTEA;
 ALTER TABLE snd_messages ADD COLUMN padded_msg_len BIGINT;
 
@@ -24,7 +25,8 @@ CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_bo
 
 down_m20250203_msg_bodies :: Text
 down_m20250203_msg_bodies =
-  [r|
+  T.pack
+    [r|
 DROP INDEX idx_snd_messages_snd_message_body_id;
 ALTER TABLE snd_messages DROP COLUMN snd_message_body_id;
 DROP TABLE snd_message_bodies;

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

@@ -1,14 +1,15 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import Text.RawString.QQ (r)
 
 m20250322_short_links :: Text
 m20250322_short_links =
-  [r|
+  T.pack    
+    [r|
 ALTER TABLE rcv_queues ADD COLUMN link_id BYTEA;
 ALTER TABLE rcv_queues ADD COLUMN link_key BYTEA;
 ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BYTEA;
@@ -41,7 +42,8 @@ CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, l
 
 down_m20250322_short_links :: Text
 down_m20250322_short_links =
-  [r|
+  T.pack
+    [r|
 DROP INDEX idx_rcv_queues_link_id;
 ALTER TABLE rcv_queues DROP COLUMN link_id;
 ALTER TABLE rcv_queues DROP COLUMN link_key;

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

@@ -1,35 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where
-
-import Data.Text (Text)
-import Text.RawString.QQ (r)
-
-m20250702_conn_invitations_remove_cascade_delete :: Text
-m20250702_conn_invitations_remove_cascade_delete =
-  [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 =
-  [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/Postgres/Migrations/M20251009_queue_to_subscribe.hs

@@ -1,21 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251009_queue_to_subscribe where
-
-import Data.Text (Text)
-import Text.RawString.QQ (r)
-
-m20251009_queue_to_subscribe :: Text
-m20251009_queue_to_subscribe =
-  [r|
-ALTER TABLE rcv_queues ADD COLUMN to_subscribe SMALLINT NOT NULL DEFAULT 0;
-CREATE INDEX idx_rcv_queues_to_subscribe ON rcv_queues(to_subscribe);
-|]
-
-down_m20251009_queue_to_subscribe :: Text
-down_m20251009_queue_to_subscribe =
-  [r|
-DROP INDEX idx_rcv_queues_to_subscribe;
-ALTER TABLE rcv_queues DROP COLUMN to_subscribe;
-|]

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

@@ -1,40 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notices where
-
-import Data.Text (Text)
-import Text.RawString.QQ (r)
-
-m20251010_client_notices :: Text
-m20251010_client_notices =
-  [r|
-CREATE TABLE client_notices(
-  client_notice_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
-  protocol TEXT NOT NULL,
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  entity_id BYTEA NOT NULL,
-  server_key_hash BYTEA,
-  notice_ttl BIGINT,
-  created_at BIGINT NOT NULL,
-  updated_at BIGINT NOT NULL
-);
-
-CREATE UNIQUE INDEX idx_client_notices_entity ON client_notices(protocol, host, port, entity_id);
-
-ALTER TABLE rcv_queues ADD COLUMN client_notice_id BIGINT
-REFERENCES client_notices ON UPDATE RESTRICT ON DELETE SET NULL;
-
-CREATE INDEX idx_rcv_queues_client_notice_id ON rcv_queues(client_notice_id);
-|]
-
-down_m20251010_client_notices :: Text
-down_m20251010_client_notices =
-  [r|
-DROP INDEX idx_rcv_queues_client_notice_id;
-ALTER TABLE rcv_queues DROP COLUMN client_notice_id;
-
-DROP INDEX idx_client_notices_entity;
-DROP TABLE client_notices;
-|]

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

@@ -27,7 +27,6 @@
 module Simplex.Messaging.Agent.Store.SQLite
   ( DBOpts (..),
     Migrations.getCurrentMigrations,
-    migrateDBSchema,
     createDBStore,
     closeDBStore,
     reopenDBStore,
@@ -58,38 +57,33 @@ 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 (..), MigrationConfig (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
-import System.FilePath (takeDirectory, takeFileName, (</>))
+import System.FilePath (takeDirectory)
 import UnliftIO.Exception (bracketOnError, onException)
 import UnliftIO.MVar
 import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
-createDBStore opts@DBOpts {dbFilePath, dbKey, keepKey, track} migrations migrationConfig = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
   st <- connectSQLiteStore dbFilePath dbKey keepKey track
-  r <- migrateDBSchema st opts Nothing migrations migrationConfig `onException` closeDBStore st
+  r <- migrateSchema st `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
     Left e -> closeDBStore st $> Left e
   where
-
-migrateDBSchema :: DBStore -> DBOpts -> Maybe Query -> [Migration] -> MigrationConfig -> IO (Either MigrationError ())
-migrateDBSchema st DBOpts {dbFilePath, vacuum} migrationsTable migrations MigrationConfig {confirm, backupPath} =
-  let initialize = Migrations.initialize st migrationsTable
-      getCurrent = withTransaction st $ Migrations.getCurrentMigrations migrationsTable
-      run = Migrations.run st migrationsTable vacuum
-      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 confirm
+    migrateSchema st =
+      let initialize = Migrations.initialize st
+          getCurrent = withTransaction st Migrations.getCurrentMigrations
+          run = Migrations.run st vacuum
+          backup = copyFile dbFilePath (dbFilePath <> ".bak")
+          dbm = DBMigrate {initialize, getCurrent, run, backup}
+       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
 
 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 a = Binary {fromBinary :: a}
+newtype Binary = Binary {fromBinary :: ByteString}
   deriving newtype (FromField, ToField)
 
 data Connection = Connection

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

@@ -17,12 +17,12 @@ where
 import Control.Monad (forM_, when)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (getCurrentTime)
 import Database.SQLite.Simple (Only (..), Query (..))
 import qualified Database.SQLite.Simple as SQL
+import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -32,16 +32,13 @@ import Simplex.Messaging.Agent.Store.Shared
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Transport.Client (TransportHost)
 
-getCurrentMigrations :: Maybe Query -> DB.Connection -> IO [Migration]
-getCurrentMigrations migrationsTable DB.Connection {DB.conn} =
-  map toMigration
-    <$> SQL.query_ conn ("SELECT name, down FROM " <> table <> " ORDER BY name ASC;")
+getCurrentMigrations :: DB.Connection -> IO [Migration]
+getCurrentMigrations DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;"
   where
-    table = fromMaybe "migrations" migrationsTable
     toMigration (name, down) = Migration {name, up = "", down}
 
-run :: DBStore -> Maybe Query -> Bool -> MigrationsToRun -> IO ()
-run st migrationsTable vacuum = \case
+run :: DBStore -> Bool -> MigrationsToRun -> IO ()
+run st vacuum = \case
   MTRUp [] -> pure ()
   MTRUp ms -> do
     mapM_ runUp ms
@@ -49,12 +46,11 @@ run st migrationsTable vacuum = \case
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where
-    table = fromMaybe "migrations" migrationsTable
     runUp Migration {name, up, down} = withTransaction' st $ \db -> do
       when (name == "m20220811_onion_hosts") $ updateServers db
       insert db >> execSQL db up'
       where
-        insert db = SQL.execute db ("INSERT INTO " <> table <> " (name, down, ts) VALUES (?,?,?)") . (name,down,) =<< getCurrentTime
+        insert db = SQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
         up'
           | dbNew st && name == "m20230110_users" = fromQuery new_m20230110_users
           | otherwise = up
@@ -63,19 +59,24 @@ run st migrationsTable vacuum = \case
            in SQL.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
     runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do
       execSQL db downQuery
-      SQL.execute db ("DELETE FROM " <> table <> " WHERE name = ?") (Only downName)
+      SQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
     execSQL db = SQLite3.exec $ SQL.connectionHandle db
 
-initialize :: DBStore -> Maybe Query -> IO ()
-initialize st migrationsTable = withTransaction' st $ \db -> do
-  cs :: [Text] <- map fromOnly <$> SQL.query_ db ("SELECT name FROM pragma_table_info('" <> table <> "')")
+initialize :: DBStore -> IO ()
+initialize st = withTransaction' st $ \db -> do
+  cs :: [Text] <- map fromOnly <$> SQL.query_ db "SELECT name FROM pragma_table_info('migrations')"
   case cs of
     [] -> createMigrations db
-    _ -> when ("down" `notElem` cs) $ SQL.execute_ db $ "ALTER TABLE " <> table <> " ADD COLUMN down TEXT"
+    _ -> when ("down" `notElem` cs) $ SQL.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
   where
-    table = fromMaybe "migrations" migrationsTable
     createMigrations db =
-      SQL.execute_ db $
-        "CREATE TABLE IF NOT EXISTS "
-          <> table
-          <> " (name TEXT NOT NULL PRIMARY KEY, ts TEXT NOT NULL, down TEXT)"
+      SQL.execute_
+        db
+        [sql|
+          CREATE TABLE IF NOT EXISTS migrations (
+            name TEXT NOT NULL,
+            ts TEXT NOT NULL,
+            down TEXT,
+            PRIMARY KEY (name)
+          );
+        |]

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

@@ -43,9 +43,6 @@ 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.SQLite.Migrations.M20251009_queue_to_subscribe
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -88,10 +85,7 @@ 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),
-    ("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete),
-    ("m20251009_queue_to_subscribe", m20251009_queue_to_subscribe, Just down_m20251009_queue_to_subscribe),
-    ("m20251010_client_notices", m20251010_client_notices, Just down_m20251010_client_notices)
+    ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -1,40 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs where
-
-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|
-CREATE TABLE server_certs(
-  server_cert_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  user_id INTEGER NOT NULL REFERENCES users ON UPDATE RESTRICT ON DELETE CASCADE,
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  certificate BLOB NOT NULL,
-  priv_key BLOB NOT NULL,
-  service_id BLOB,
-  FOREIGN KEY(host, port) REFERENCES servers ON UPDATE CASCADE ON DELETE RESTRICT,
-);
-
-CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON server_certs(user_id, host, port);
-
-CREATE INDEX idx_server_certs_host_port ON server_certs(host, port);
-
-ALTER TABLE rcv_queues ADD COLUMN rcv_service_id BLOB;
-  |]
-
-down_m20250517_service_certs :: Query
-down_m20250517_service_certs =
-  [sql|
-ALTER TABLE rcv_queues DROP COLUMN rcv_service_id;
-
-DROP INDEX idx_server_certs_host_port;
-
-DROP INDEX idx_server_certs_user_id_host_port;
-
-DROP TABLE server_certs;
-  |]

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

@@ -1,38 +0,0 @@
-{-# 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/M20251009_queue_to_subscribe.hs

@@ -1,20 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251009_queue_to_subscribe where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20251009_queue_to_subscribe :: Query
-m20251009_queue_to_subscribe =
-  [sql|
-ALTER TABLE rcv_queues ADD COLUMN to_subscribe INTEGER NOT NULL DEFAULT 0;
-CREATE INDEX idx_rcv_queues_to_subscribe ON rcv_queues(to_subscribe);
-|]
-
-down_m20251009_queue_to_subscribe :: Query
-down_m20251009_queue_to_subscribe =
-  [sql|
-DROP INDEX idx_rcv_queues_to_subscribe;
-ALTER TABLE rcv_queues DROP COLUMN to_subscribe;
-|]

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

@@ -1,39 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20251010_client_notices :: Query
-m20251010_client_notices =
-  [sql|
-CREATE TABLE client_notices(
-  client_notice_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  protocol TEXT NOT NULL,
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  entity_id BLOB NOT NULL,
-  server_key_hash BLOB,
-  notice_ttl INTEGER,
-  created_at INTEGER NOT NULL,
-  updated_at INTEGER NOT NULL
-);
-
-CREATE UNIQUE INDEX idx_client_notices_entity ON client_notices(protocol, host, port, entity_id);
-
-ALTER TABLE rcv_queues ADD COLUMN client_notice_id INTEGER
-REFERENCES client_notices ON UPDATE RESTRICT ON DELETE SET NULL;
-
-CREATE INDEX idx_rcv_queues_client_notice_id ON rcv_queues(client_notice_id);
-|]
-
-down_m20251010_client_notices :: Query
-down_m20251010_client_notices =
-  [sql|
-DROP INDEX idx_rcv_queues_client_notice_id;
-ALTER TABLE rcv_queues DROP COLUMN client_notice_id;
-
-DROP INDEX idx_client_notices_entity;
-DROP TABLE client_notices;
-|]

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

@@ -1,7 +1,8 @@
 CREATE TABLE migrations(
-  name TEXT NOT NULL PRIMARY KEY,
+  name TEXT NOT NULL,
   ts TEXT NOT NULL,
-  down TEXT
+  down TEXT,
+  PRIMARY KEY(name)
 );
 CREATE TABLE servers(
   host TEXT NOT NULL,
@@ -60,9 +61,6 @@ CREATE TABLE rcv_queues(
   link_priv_sig_key BLOB,
   link_enc_fixed_data BLOB,
   queue_mode TEXT,
-  to_subscribe INTEGER NOT NULL DEFAULT 0,
-  client_notice_id INTEGER
-  REFERENCES client_notices ON UPDATE RESTRICT ON DELETE SET NULL,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -156,7 +154,7 @@ CREATE TABLE conn_confirmations(
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
-  contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL,
+  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
   cr_invitation BLOB NOT NULL,
   recipient_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL DEFAULT 0,
@@ -439,17 +437,6 @@ CREATE TABLE inv_short_links(
   snd_id BLOB,
   FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
 );
-CREATE TABLE client_notices(
-  client_notice_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  protocol TEXT NOT NULL,
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  entity_id BLOB NOT NULL,
-  server_key_hash BLOB,
-  notice_ttl INTEGER,
-  created_at INTEGER NOT NULL,
-  updated_at INTEGER NOT NULL
-);
 CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
 CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
 CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
@@ -585,11 +572,3 @@ CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(
   port,
   link_id
 );
-CREATE INDEX idx_rcv_queues_to_subscribe ON rcv_queues(to_subscribe);
-CREATE UNIQUE INDEX idx_client_notices_entity ON client_notices(
-  protocol,
-  host,
-  port,
-  entity_id
-);
-CREATE INDEX idx_rcv_queues_client_notice_id ON rcv_queues(client_notice_id);

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

@@ -9,7 +9,6 @@ module Simplex.Messaging.Agent.Store.Shared
     DownMigration (..),
     MTRError (..),
     mtrErrorDescription,
-    MigrationConfig (..),
     MigrationConfirmation (..),
     MigrationError (..),
     UpMigration (..),
@@ -56,15 +55,13 @@ data MigrationError
   | MigrationError {mtrError :: MTRError}
   deriving (Eq, Show)
 
-migrationErrorDescription :: Bool -> MigrationError -> String
-migrationErrorDescription withBackup = \case
+migrationErrorDescription :: MigrationError -> String
+migrationErrorDescription = \case
   MEUpgrade ums ->
-    "The app has a newer version than the database.\nConfirm to " <> backupStr <> "upgrade using these migrations: " <> intercalate ", " (map upName ums)
+    "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
   MEDowngrade dms ->
-    "Database version is newer than the app.\nConfirm to " <> backupStr <> "downgrade using these migrations: " <> intercalate ", " dms
+    "Database version is newer than the app.\nConfirm to back up and 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)
@@ -72,11 +69,6 @@ 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/Agent/TRcvQueues.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Simplex.Messaging.Agent.TRcvQueues
+  ( TRcvQueues (getRcvQueues, getConnections),
+    Queue (..),
+    empty,
+    clear,
+    deleteConn,
+    hasConn,
+    addQueue,
+    batchAddQueues,
+    deleteQueue,
+    hasSessQueues,
+    getSessQueues,
+    getDelSessQueues,
+  )
+where
+
+import Control.Concurrent.STM
+import Data.Foldable (foldl')
+import Data.List.NonEmpty (NonEmpty (..), (<|))
+import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
+import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
+import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
+import Simplex.Messaging.Protocol (RecipientId, SMPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport
+
+class Queue q where
+  connId' :: q -> ConnId
+  qKey :: q -> (UserId, SMPServer, RecipientId)
+
+-- the fields in this record have the same data with swapped keys for lookup efficiency,
+-- and all methods must maintain this invariant.
+data TRcvQueues q = TRcvQueues
+  { getRcvQueues :: TMap (UserId, SMPServer, RecipientId) q,
+    getConnections :: TMap ConnId (NonEmpty (UserId, SMPServer, RecipientId))
+  }
+
+empty :: IO (TRcvQueues q)
+empty = TRcvQueues <$> TM.emptyIO <*> TM.emptyIO
+
+clear :: TRcvQueues q -> STM ()
+clear (TRcvQueues qs cs) = TM.clear qs >> TM.clear cs
+
+deleteConn :: ConnId -> TRcvQueues q -> STM ()
+deleteConn cId (TRcvQueues qs cs) =
+  TM.lookupDelete cId cs >>= \case
+    Just ks -> modifyTVar' qs $ \qs' -> foldl' (flip M.delete) qs' ks
+    Nothing -> pure ()
+
+hasConn :: ConnId -> TRcvQueues q -> STM Bool
+hasConn cId (TRcvQueues _ cs) = TM.member cId cs
+
+addQueue :: Queue q => q -> TRcvQueues q -> STM ()
+addQueue rq (TRcvQueues qs cs) = do
+  TM.insert k rq qs
+  TM.alter addQ (connId' rq) cs
+  where
+    addQ = Just . maybe (k :| []) (k <|)
+    k = qKey rq
+
+-- Save time by aggregating modifyTVar'
+batchAddQueues :: (Foldable t, Queue q) => TRcvQueues q -> t q -> STM ()
+batchAddQueues (TRcvQueues qs cs) rqs = do
+  modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs
+  modifyTVar' cs $ \now -> foldl' (\cs' rq -> M.alter (addQ $ qKey rq) (connId' rq) cs') now rqs
+  where
+    addQ k = Just . maybe (k :| []) (k <|)
+
+deleteQueue :: RcvQueue -> TRcvQueues RcvQueue -> STM ()
+deleteQueue rq (TRcvQueues qs cs) = do
+  TM.delete k qs
+  TM.update delQ (connId rq) cs
+  where
+    delQ = L.nonEmpty . L.filter (/= k)
+    k = qKey rq
+
+hasSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues RcvQueue -> STM Bool
+hasSessQueues tSess (TRcvQueues qs _) = any (`isSession` tSess) <$> readTVar qs
+
+getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues RcvQueue -> IO [RcvQueue]
+getSessQueues tSess (TRcvQueues qs _) = M.foldl' addQ [] <$> readTVarIO qs
+  where
+    addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs'
+
+getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> SessionId -> TRcvQueues (SessionId, RcvQueue) -> STM ([RcvQueue], [ConnId])
+getDelSessQueues tSess sessId' (TRcvQueues qs cs) = do
+  (removedQs, qs'') <- (\qs' -> M.foldl' delQ ([], qs') qs') <$> readTVar qs
+  writeTVar qs $! qs''
+  removedConns <- stateTVar cs $ \cs' -> foldl' delConn ([], cs') removedQs
+  pure (removedQs, removedConns)
+  where
+    delQ acc@(removed, qs') (sessId, rq)
+      | rq `isSession` tSess && sessId == sessId' = (rq : removed, M.delete (qKey rq) qs')
+      | otherwise = acc
+    delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId)))
+    delConn (removed, cs') rq = M.alterF f cId cs'
+      where
+        cId = connId rq
+        f = \case
+          Just ks -> case L.nonEmpty $ L.filter (qKey rq /=) ks of
+            Just ks' -> (removed, Just ks')
+            Nothing -> (cId : removed, Nothing)
+          Nothing -> (removed, Nothing) -- "impossible" in invariant holds, because we get keys from the known queues
+
+isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool
+isSession rq (uId, srv, connId_) =
+  userId rq == uId && server rq == srv && maybe True (connId rq ==) connId_
+
+instance Queue RcvQueue where
+  connId' = connId
+  qKey rq = (userId rq, server rq, rcvId rq)
+
+instance Queue (SessionId, RcvQueue) where
+  connId' = connId . snd
+  qKey = qKey . snd

src/Simplex/Messaging/Agent/TSessionSubs.hs

@@ -1,201 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Agent.TSessionSubs
-  ( TSessionSubs (sessionSubs),
-    SessSubs (..),
-    emptyIO,
-    clear,
-    hasActiveSub,
-    hasPendingSub,
-    addPendingSub,
-    setSessionId,
-    addActiveSub,
-    batchAddActiveSubs,
-    batchAddPendingSubs,
-    deletePendingSub,
-    batchDeletePendingSubs,
-    deleteSub,
-    batchDeleteSubs,
-    hasPendingSubs,
-    getPendingSubs,
-    getActiveSubs,
-    setSubsPending,
-    updateClientNotices,
-    foldSessionSubs,
-    mapSubs,
-  )
-where
-
-import Control.Concurrent.STM
-import Control.Monad
-import Data.Int (Int64)
-import Data.List (foldl')
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Maybe (isJust)
-import qualified Data.Set as S
-import Simplex.Messaging.Agent.Protocol (SMPQueue (..))
-import Simplex.Messaging.Agent.Store (RcvQueueSub (..), SomeRcvQueue)
-import Simplex.Messaging.Client (SMPTransportSession, TransportSessionMode (..))
-import Simplex.Messaging.Protocol (RecipientId)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (($>>=))
-
-data TSessionSubs = TSessionSubs
-  { sessionSubs :: TMap SMPTransportSession SessSubs
-  }
-
-data SessSubs = SessSubs
-  { subsSessId :: TVar (Maybe SessionId),
-    activeSubs :: TMap RecipientId RcvQueueSub,
-    pendingSubs :: TMap RecipientId RcvQueueSub
-  }
-
-emptyIO :: IO TSessionSubs
-emptyIO = TSessionSubs <$> TM.emptyIO
-{-# INLINE emptyIO #-}
-
-clear :: TSessionSubs -> STM ()
-clear = TM.clear . sessionSubs
-{-# INLINE clear #-}
-
-lookupSubs :: SMPTransportSession -> TSessionSubs -> STM (Maybe SessSubs)
-lookupSubs tSess = TM.lookup tSess . sessionSubs
-{-# INLINE lookupSubs #-}
-
-getSessSubs :: SMPTransportSession -> TSessionSubs -> STM SessSubs
-getSessSubs tSess ss = lookupSubs tSess ss >>= maybe new pure
-  where
-    new = do
-      s <- SessSubs <$> newTVar Nothing <*> newTVar M.empty <*> newTVar M.empty
-      TM.insert tSess s $ sessionSubs ss
-      pure s
-
-hasActiveSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM Bool
-hasActiveSub = hasQueue_ activeSubs
-{-# INLINE hasActiveSub #-}
-
-hasPendingSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM Bool
-hasPendingSub = hasQueue_ pendingSubs
-{-# INLINE hasPendingSub #-}
-
-hasQueue_ :: (SessSubs -> TMap RecipientId RcvQueueSub) -> SMPTransportSession -> RecipientId -> TSessionSubs -> STM Bool
-hasQueue_ subs tSess rId ss = isJust <$> (lookupSubs tSess ss $>>= TM.lookup rId . subs)
-{-# INLINE hasQueue_ #-}
-
-addPendingSub :: SMPTransportSession -> RcvQueueSub -> TSessionSubs -> STM ()
-addPendingSub tSess rq ss = getSessSubs tSess ss >>= TM.insert (rcvId rq) rq . pendingSubs
-
-setSessionId :: SMPTransportSession -> SessionId -> TSessionSubs -> STM ()
-setSessionId tSess sessId ss = do
-  s <- getSessSubs tSess ss
-  readTVar (subsSessId s) >>= \case
-    Nothing -> writeTVar (subsSessId s) (Just sessId)
-    Just sessId' -> unless (sessId == sessId') $ void $ setSubsPending_ s $ Just sessId
-
-addActiveSub :: SMPTransportSession -> SessionId -> RcvQueueSub -> TSessionSubs -> STM ()
-addActiveSub tSess sessId rq ss = do
-  s <- getSessSubs tSess ss
-  sessId' <- readTVar $ subsSessId s
-  let rId = rcvId rq
-  if Just sessId == sessId'
-    then do
-      TM.insert rId rq $ activeSubs s
-      TM.delete rId $ pendingSubs s
-    else TM.insert rId rq $ pendingSubs s
-
-batchAddActiveSubs :: SMPTransportSession -> SessionId -> [RcvQueueSub] -> TSessionSubs -> STM ()
-batchAddActiveSubs tSess sessId rqs ss = do
-  s <- getSessSubs tSess ss
-  sessId' <- readTVar $ subsSessId s
-  let qs = M.fromList $ map (\rq -> (rcvId rq, rq)) rqs
-  if Just sessId == sessId'
-    then do
-      TM.union qs $ activeSubs s
-      modifyTVar' (pendingSubs s) (`M.difference` qs)
-    else TM.union qs $ pendingSubs s
-
-batchAddPendingSubs :: SMPTransportSession -> [RcvQueueSub] -> TSessionSubs -> STM ()
-batchAddPendingSubs tSess rqs ss = do
-  s <- getSessSubs tSess ss
-  modifyTVar' (pendingSubs s) $ M.union $ M.fromList $ map (\rq -> (rcvId rq, rq)) rqs
-
-deletePendingSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM ()
-deletePendingSub tSess rId = lookupSubs tSess >=> mapM_ (TM.delete rId . pendingSubs)
-
-batchDeletePendingSubs :: SMPTransportSession -> S.Set RecipientId -> TSessionSubs -> STM ()
-batchDeletePendingSubs tSess rIds = lookupSubs tSess >=> mapM_ (delete . pendingSubs)
-  where
-    delete = (`modifyTVar'` (`M.withoutKeys` rIds))
-
-deleteSub :: SMPTransportSession -> RecipientId -> TSessionSubs -> STM ()
-deleteSub tSess rId = lookupSubs tSess >=> mapM_ (\s -> TM.delete rId (activeSubs s) >> TM.delete rId (pendingSubs s))
-
-batchDeleteSubs :: SomeRcvQueue q => SMPTransportSession -> [q] -> TSessionSubs -> STM ()
-batchDeleteSubs tSess rqs = lookupSubs tSess >=> mapM_ (\s -> delete (activeSubs s) >> delete (pendingSubs s))
-  where
-    rIds = S.fromList $ map queueId rqs
-    delete = (`modifyTVar'` (`M.withoutKeys` rIds))
-
-hasPendingSubs :: SMPTransportSession -> TSessionSubs -> STM Bool
-hasPendingSubs tSess = lookupSubs tSess >=> maybe (pure False) (fmap (not . null) . readTVar . pendingSubs)
-
-getPendingSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
-getPendingSubs = getSubs_ pendingSubs
-{-# INLINE getPendingSubs #-}
-
-getActiveSubs :: SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
-getActiveSubs = getSubs_ activeSubs
-{-# INLINE getActiveSubs #-}
-
-getSubs_ :: (SessSubs -> TMap RecipientId RcvQueueSub) -> SMPTransportSession -> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
-getSubs_ subs tSess = lookupSubs tSess >=> maybe (pure M.empty) (readTVar . subs)
-
-setSubsPending :: TransportSessionMode -> SMPTransportSession -> SessionId -> TSessionSubs -> STM (Map RecipientId RcvQueueSub)
-setSubsPending mode tSess@(uId, srv, connId_) sessId tss@(TSessionSubs ss)
-  | entitySession == isJust connId_ =
-      TM.lookup tSess ss >>= withSessSubs (`setSubsPending_` Nothing)
-  | otherwise =
-      TM.lookupDelete tSess ss >>= withSessSubs setPendingChangeMode
-  where
-    entitySession = mode == TSMEntity
-    sessEntId = if entitySession then Just else const Nothing
-    withSessSubs run = \case
-      Nothing -> pure M.empty
-      Just s -> do
-        sessId' <- readTVar $ subsSessId s
-        if Just sessId == sessId' then run s else pure M.empty
-    setPendingChangeMode s = do
-      subs <- M.union <$> readTVar (activeSubs s) <*> readTVar (pendingSubs s)
-      unless (null subs) $
-        forM_ subs $ \rq -> addPendingSub (uId, srv, sessEntId (connId rq)) rq tss
-      pure subs
-
-setSubsPending_ :: SessSubs -> Maybe SessionId -> STM (Map RecipientId RcvQueueSub)
-setSubsPending_ s sessId_ = do
-  writeTVar (subsSessId s) sessId_
-  let as = activeSubs s
-  subs <- readTVar as
-  unless (null subs) $ do
-    writeTVar as M.empty
-    modifyTVar' (pendingSubs s) $ M.union subs
-  pure subs
-
-updateClientNotices :: SMPTransportSession -> [(RecipientId, Maybe Int64)] -> TSessionSubs -> STM ()
-updateClientNotices tSess noticeIds ss = do
-  s <- getSessSubs tSess ss
-  modifyTVar' (pendingSubs s) $ \m -> foldl' (\m' (rcvId, clientNoticeId) -> M.adjust (\rq -> rq {clientNoticeId}) rcvId m') m noticeIds
-
-foldSessionSubs :: (a -> (SMPTransportSession, SessSubs) -> IO a) -> a -> TSessionSubs -> IO a
-foldSessionSubs f a = foldM f a . M.assocs <=< readTVarIO . sessionSubs
-
-mapSubs :: (Map RecipientId RcvQueueSub -> a) -> SessSubs -> IO (a, a)
-mapSubs f s = do
-  active <- readTVarIO $ activeSubs s
-  pending <- readTVarIO $ pendingSubs s
-  pure (f active, f pending)

src/Simplex/Messaging/Client.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
@@ -29,7 +28,6 @@
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
     TransportSession,
-    SMPTransportSession,
     ProtocolClient (thParams, sessionTs),
     SMPClient,
     ProxiedRelay (..),
@@ -39,8 +37,6 @@ module Simplex.Messaging.Client
     protocolClientServer',
     transportHost',
     transportSession',
-    useWebPort,
-    isPresetDomain,
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -50,8 +46,6 @@ module Simplex.Messaging.Client
     getSMPMessage,
     subscribeSMPQueueNotifications,
     subscribeSMPQueuesNtfs,
-    subscribeService,
-    smpClientService,
     secureSMPQueue,
     secureSndSMPQueue,
     proxySecureSndSMPQueue,
@@ -85,16 +79,12 @@ module Simplex.Messaging.Client
     unexpectedResponse,
     ProtocolClientConfig (..),
     NetworkConfig (..),
-    NetworkTimeout (..),
-    NetworkRequestMode (..),
-    pattern NRMInteractive,
     TransportSessionMode (..),
     HostMode (..),
     SocksMode (..),
     SMPProxyMode (..),
     SMPProxyFallback (..),
     SMPWebPortServers (..),
-    netTimeoutInt,
     defaultClientConfig,
     defaultSMPClientConfig,
     defaultNetworkConfig,
@@ -102,9 +92,7 @@ module Simplex.Messaging.Client
     clientSocksCredentials,
     chooseTransportHost,
     temporaryClientError,
-    smpClientServiceError,
     smpProxyError,
-    smpErrorClientNotice,
     textToHostMode,
     ServerTransmissionBatch,
     ServerTransmission (..),
@@ -159,15 +147,13 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Protocol.Types
 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, runTransportClient)
-import Simplex.Messaging.Transport.HTTP2 (httpALPN11)
+import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util
+import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tryWriteTBQueue, tshow, whenM)
 import Simplex.Messaging.Version
 import System.Mem.Weak (Weak, deRefWeak)
 import System.Timeout (timeout)
@@ -186,15 +172,15 @@ data PClient v err msg = PClient
   { connected :: TVar Bool,
     transportSession :: TransportSession msg,
     transportHost :: TransportHost,
-    tcpConnectTimeout :: NetworkTimeout,
-    tcpTimeout :: NetworkTimeout,
+    tcpConnectTimeout :: Int,
+    tcpTimeout :: Int,
     sendPings :: TVar Bool,
     lastReceived :: TVar UTCTime,
     timeoutErrorCount :: TVar Int,
     clientCorrId :: TVar ChaChaDRG,
     sentCommands :: TMap CorrId (Request err msg),
     sndQ :: TBQueue (Maybe (Request err msg), ByteString),
-    rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg))),
+    rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
     msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
   }
 
@@ -209,7 +195,6 @@ smpClientStub g sessionId thVersion thAuth = do
   timeoutErrorCount <- newTVarIO 0
   sndQ <- newTBQueueIO 100
   rcvQ <- newTBQueueIO 100
-  let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig
   return
     ProtocolClient
       { action = Nothing,
@@ -222,8 +207,7 @@ smpClientStub g sessionId thVersion thAuth = do
               blockSize = smpBlockSize,
               implySessId = thVersion >= authCmdsSMPVersion,
               encryptBlock = Nothing,
-              batch = True,
-              serviceAuth = thVersion >= serviceCertsSMPVersion
+              batch = True
             },
         sessionTs = ts,
         client_ =
@@ -231,8 +215,8 @@ smpClientStub g sessionId thVersion thAuth = do
             { connected,
               transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
               transportHost = "localhost",
-              tcpConnectTimeout,
-              tcpTimeout,
+              tcpConnectTimeout = 20_000_000,
+              tcpTimeout = 15_000_000,
               sendPings,
               lastReceived,
               timeoutErrorCount,
@@ -247,7 +231,7 @@ smpClientStub g sessionId thVersion thAuth = do
 type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
 
 -- | Type for client command data
-type ClientCommand msg = (EntityId, Maybe C.APrivateAuthKey, ProtoCommand msg)
+type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
 
 -- | Type synonym for transmission from SPM servers.
 -- Batch response is presented as a single `ServerTransmissionBatch` tuple.
@@ -310,9 +294,9 @@ data NetworkConfig = NetworkConfig
     -- | use web port 443 for SMP protocol
     smpWebPortServers :: SMPWebPortServers,
     -- | timeout for the initial client TCP/TLS connection (microseconds)
-    tcpConnectTimeout :: NetworkTimeout,
+    tcpConnectTimeout :: Int,
     -- | timeout of protocol commands (microseconds)
-    tcpTimeout :: NetworkTimeout,
+    tcpTimeout :: Int,
     -- | additional timeout per kilobyte (1024 bytes) to be sent
     tcpTimeoutPerKb :: Int64,
     -- | break response timeouts into groups, so later responses get later deadlines
@@ -327,28 +311,6 @@ 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)
 
@@ -421,8 +383,8 @@ defaultNetworkConfig =
       smpProxyMode = SPMNever,
       smpProxyFallback = SPFAllow,
       smpWebPortServers = SWPPreset,
-      tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000},
-      tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000},
+      tcpConnectTimeout = defaultTcpConnectTimeout,
+      tcpTimeout = 15_000_000,
       tcpTimeoutPerKb = 5_000,
       rcvConcurrency = 8,
       tcpKeepAlive = Just defaultKeepAliveOpts,
@@ -431,11 +393,10 @@ defaultNetworkConfig =
       logTLSErrors = False
     }
 
-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}
+transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI =
+  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI}
   where
-    tOut = netTimeoutInt tcpConnectTimeout nm
     socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
     useSocksProxy SMAlways = socksProxy'
     useSocksProxy SMOnion = case host of
@@ -463,11 +424,10 @@ data ProtocolClientConfig v = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
-    defaultTransport :: (ServiceName, ATransport 'TClient),
+    defaultTransport :: (ServiceName, ATransport),
     -- | network configuration
     networkConfig :: NetworkConfig,
     clientALPN :: Maybe [ALPN],
-    serviceCredentials :: Maybe ServiceCredentials,
     -- | client-server protocol version range
     serverVRange :: VersionRange v,
     -- | agree shared session secret (used in SMP proxy for additional encryption layer)
@@ -486,7 +446,6 @@ defaultClientConfig clientALPN useSNI serverVRange =
       defaultTransport = ("443", transport @TLS),
       networkConfig = defaultNetworkConfig,
       clientALPN,
-      serviceCredentials = Nothing,
       serverVRange,
       agreeSecret = False,
       proxyServer = False,
@@ -496,7 +455,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
 
 defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
 defaultSMPClientConfig =
-  (defaultClientConfig (Just alpnSupportedSMPHandshakes) False supportedClientSMPRelayVRange)
+  (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
     { defaultTransport = (show defaultSMPPort, transport @TLS),
       agreeSecret = True
     }
@@ -553,22 +512,20 @@ type UserId = Int64
 -- Please note that for SMP connection ID is used as entity ID, not queue ID.
 type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 
-type SMPTransportSession = TransportSession BrokerMsg
-
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> 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
+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, 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 {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
     mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
     mkProtocolClient transportHost ts = do
       connected <- newTVarIO False
@@ -596,39 +553,38 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+    runClient :: (ServiceName, ATransport) -> 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 nm useHost useSNI useALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
+      let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
           socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
       tId <-
         runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c 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)
+          `forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
+      c_ <- tcpConnectTimeout `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 NETimeoutError)
+        Nothing -> killThread tId $> Left PCENetworkError
 
-    useTransport :: (ServiceName, ATransport 'TClient)
+    useTransport :: (ServiceName, ATransport)
     useTransport = case port srv of
       "" -> case protocolTypeI @(ProtoType msg) of
-        SPSMP | web -> ("443", transport @TLS)
+        SPSMP | smpWebPort -> ("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 :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
     client _ c cVar h = do
       ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
-      serviceKeys_ <- mapM (\creds -> (creds,) <$> atomically (C.generateKeyPair g)) serviceCredentials
-      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer serviceKeys_) >>= \case
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {params} -> do
           sessionTs <- getCurrentTime
@@ -652,7 +608,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
 
     receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
-      tGetClient h >>= atomically . writeTBQueue rcvQ
+      tGet h >>= atomically . writeTBQueue rcvQ
       getCurrentTime >>= atomically . writeTVar lastReceived
       atomically $ writeTVar timeoutErrorCount 0
 
@@ -668,7 +624,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
           if remaining > 1_000_000 -- delay pings only for significant time
             then loop remaining
             else do
-              whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c NRMBackground Nothing NoEntity (protocolPing @v @err @msg)
+              whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
               -- sendProtocolCommand/getResponse updates counter for each command
               cnt <- readTVarIO timeoutErrorCount
               -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
@@ -679,14 +635,14 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
     process :: ProtocolClient v err msg -> IO ()
     process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c
 
-    processMsgs :: ProtocolClient v err msg -> NonEmpty (Transmission (Either err msg)) -> IO ()
+    processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO ()
     processMsgs c ts = do
       ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts)
       forM_ msgQ $ \q ->
         mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts')
 
-    processMsg :: ProtocolClient v err msg -> Transmission (Either err msg) -> IO (Maybe (EntityId, ServerTransmission err msg))
-    processMsg ProtocolClient {client_ = PClient {sentCommands}} (corrId, entId, respOrErr)
+    processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
+    processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
       | B.null $ bs corrId = sendMsg $ STEvent clientResp
       | otherwise =
           TM.lookupIO corrId sentCommands >>= \case
@@ -717,17 +673,6 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
               Left e -> logError $ "SMP client error: " <> tshow e
               Right _ -> logWarn "SMP client unprocessed event"
 
-useWebPort :: NetworkConfig -> [HostName] -> ProtocolServer p -> Bool
-useWebPort cfg presetDomains ProtocolServer {host = h :| _} = case smpWebPortServers cfg of
-  SWPAll -> True
-  SWPPreset -> isPresetDomain presetDomains h
-  SWPOff -> False
-
-isPresetDomain :: [HostName] -> TransportHost -> Bool
-isPresetDomain presetDomains = \case
-  THDomainName h -> any (`isSuffixOf` h) presetDomains
-  _ -> False
-
 unexpectedResponse :: Show r => r -> ProtocolClientError err
 unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
 
@@ -754,11 +699,9 @@ data ProtocolClientError err
     PCEResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
-    PCENetworkError NetworkError
+    PCENetworkError
   | -- | No host compatible with network configuration
     PCEIncompatibleHost
-  | -- | Service is unavailable for command that requires service connection
-    PCEServiceUnavailable
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
@@ -772,20 +715,12 @@ type SMPClientError = ProtocolClientError ErrorType
 
 temporaryClientError :: ProtocolClientError err -> Bool
 temporaryClientError = \case
-  PCENetworkError _ -> True
+  PCENetworkError -> True
   PCEResponseTimeout -> True
   PCEIOError _ -> True
   _ -> False
 {-# INLINE temporaryClientError #-}
 
-smpClientServiceError :: SMPClientError -> Bool
-smpClientServiceError = \case
-  PCEServiceUnavailable -> True
-  PCETransportError (TEHandshake BAD_SERVICE) -> True -- TODO [certs] this error may be temporary, so we should possibly resubscribe.
-  PCEProtocolError SERVICE -> True
-  PCEProtocolError (PROXY (BROKER NO_SERVICE)) -> True -- for completeness, it cannot happen.
-  _ -> False
-
 -- converts error of client running on proxy to the error sent to client connected to proxy
 smpProxyError :: SMPClientError -> ErrorType
 smpProxyError = \case
@@ -793,72 +728,62 @@ smpProxyError = \case
   PCEResponseError e -> PROXY $ BROKER $ RESPONSE $ B.unpack $ strEncode e
   PCEUnexpectedResponse e -> PROXY $ BROKER $ UNEXPECTED $ B.unpack e
   PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
-  PCENetworkError e -> PROXY $ BROKER $ NETWORK e
+  PCENetworkError -> PROXY $ BROKER NETWORK
   PCEIncompatibleHost -> PROXY $ BROKER HOST
-  PCEServiceUnavailable -> PROXY $ BROKER $ NO_SERVICE -- for completeness, it cannot happen.
   PCETransportError t -> PROXY $ BROKER $ TRANSPORT t
   PCECryptoError _ -> CRYPTO
   PCEIOError _ -> INTERNAL
 
-smpErrorClientNotice :: SMPClientError -> Maybe (Maybe ClientNotice)
-smpErrorClientNotice = \case
-  PCEProtocolError (BLOCKED BlockingInfo {notice}) -> Just notice
-  _ -> Nothing
-{-# INLINE smpErrorClientNotice #-}
-
 -- | Create a new SMP queue.
 --
 -- 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 ->
-  Maybe NewNtfCreds ->
+  -- TODO [notifications]
+  -- Maybe NewNtfCreds ->
   ExceptT SMPClientError IO QueueIdsKeys
-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
+createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd =
+  sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \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 :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 subscribeSMPQueue c rpKey rId = do
   liftIO $ enablePings c
-  sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
+  sendSMPCommand c (Just rpKey) rId SUB >>= \case
+    OK -> pure ()
+    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
+    r -> throwE $ unexpectedResponse r
 
 -- | 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 :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueues c qs = do
   liftIO $ enablePings c
-  sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c)
+  sendProtocolCommands c cs >>= mapM (processSUBResponse c)
   where
-    cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
+    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, 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 NRMBackground cs $ mapM process >=> cb
+streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO ()
+streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
   where
-    cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
+    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
     process r@(Response rId _) = (rId,) <$> processSUBResponse c r
 
-processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
-processSUBResponse c (Response rId r) = pure r $>>= processSUBResponse_ c rId
-
-processSUBResponse_ :: SMPClient -> RecipientId -> BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
-processSUBResponse_ c rId = \case
-  OK -> pure $ Right Nothing
-  SOK serviceId_ -> pure $ Right serviceId_
-  cmd@MSG {} -> writeSMPMessage c rId cmd $> Right Nothing
-  r' -> pure . Left $ unexpectedResponse r'
+processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError ())
+processSUBResponse c (Response rId r) = case r of
+  Right OK -> pure $ Right ()
+  Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
+  Right r' -> pure . Left $ unexpectedResponse r'
+  Left e -> pure $ Left e
 
 writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
 writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c)
@@ -870,10 +795,9 @@ 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 NRMInteractive (Just rpKey) rId GET >>= \case
+  sendSMPCommand c (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
     cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
     r -> throwE $ unexpectedResponse r
@@ -882,50 +806,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 :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications c npKey nId = do
   liftIO $ enablePings c
-  sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_
+  okSMPCommand NSUB c npKey nId
+{-# INLINE subscribeSMPQueueNotifications #-}
 
 -- | 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 :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueuesNtfs c qs = do
   liftIO $ enablePings c
-  L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs
-  where
-    cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
-
-nsubResponse :: Response ErrorType BrokerMsg -> Either SMPClientError (Maybe ServiceId)
-nsubResponse (Response _ r) = r >>= nsubResponse_
-{-# INLINE nsubResponse #-}
-
-nsubResponse_ :: BrokerMsg -> Either SMPClientError (Maybe ServiceId)
-nsubResponse_ = \case
-  OK -> Right Nothing
-  SOK serviceId_ -> Right serviceId_
-  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 NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
-      SOKS n -> pure n
-      r -> throwE $ unexpectedResponse r
-    where
-      subCmd :: Command p
-      subCmd = case party of
-        SRecipientService -> SUBS
-        SNotifierService -> NSUBS
-  Nothing -> throwE PCEServiceUnavailable
-
-smpClientService :: SMPClient -> Maybe THClientService
-smpClientService = thAuth . thParams >=> clientService
-{-# INLINE smpClientService #-}
+  okSMPCommands NSUB c qs
+{-# INLINE subscribeSMPQueuesNtfs #-}
 
 enablePings :: SMPClient -> IO ()
 enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeTVar sendPings True
@@ -934,54 +826,53 @@ 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 -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
-secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKey rId
+secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
+secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 {-# INLINE secureSMPQueue #-}
 
 -- | Secure the SMP queue via sender queue ID.
-secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO ()
-secureSndSMPQueue c nm spKey sId = okSMPCommand (SKEY $ C.toPublic spKey) c nm spKey sId
+secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
+secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
 {-# INLINE secureSndSMPQueue #-}
 
-proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySecureSndSMPQueue c nm proxiedRelay spKey sId = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY $ C.toPublic spKey)
+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)
 {-# INLINE proxySecureSndSMPQueue #-}
 
 -- | Add or update date for queue link
-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
+addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
+addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId
 {-# INLINE addSMPQueueLink #-}
 
 -- | Delete queue link
-deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
+deleteSMPQueueLink :: SMPClient -> 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 -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
-secureGetSMPQueueLink c nm spKey lnkId =
-  sendSMPCommand c nm (Just spKey) lnkId (LKEY $ C.toPublic spKey) >>= \case
+secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
+secureGetSMPQueueLink c spKey lnkId senderKey =
+  sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case
     LNK sId d -> pure (sId, d)
     r -> throwE $ unexpectedResponse r
 
-proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
-proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId =
-  proxySMPCommand  c nm proxiedRelay (Just spKey) lnkId (LKEY $ C.toPublic spKey) >>= \case
+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
     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 -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
-getSMPQueueLink c nm lnkId =
-  sendSMPCommand c nm Nothing lnkId LGET >>= \case
+getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
+getSMPQueueLink c lnkId =
+  sendSMPCommand c Nothing lnkId LGET >>= \case
     LNK sId d -> pure (sId, d)
     r -> throwE $ unexpectedResponse r
 
--- 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
+proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
+proxyGetSMPQueueLink c proxiedRelay lnkId =
+  proxySMPCommand  c proxiedRelay Nothing lnkId LGET >>= \case
     Right (LNK sId d) -> pure $ Right (sId, d)
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e
@@ -991,16 +882,15 @@ proxyGetSMPQueueLink c nm 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 NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
+  sendSMPCommand c (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 NRMBackground cs
+enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
+enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
   where
-    cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
+    cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
     process (Response _ r) = case r of
       Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
       Right r' -> Left $ unexpectedResponse r'
@@ -1009,36 +899,33 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackgroun
 -- | 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 c = okSMPCommand NDEL c NRMBackground
+disableSMPQueueNotifications = okSMPCommand NDEL
 {-# 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 c = okSMPCommands NDEL c NRMBackground
+disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+disableSMPQueuesNtfs = okSMPCommands NDEL
 {-# INLINE disableSMPQueuesNtfs #-}
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-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
+sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
+sendSMPMessage c spKey sId flags msg =
+  sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
     r -> throwE $ unexpectedResponse r
 
-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)
+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)
 
 -- | 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 NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
+  sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
     cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE $ unexpectedResponse r
@@ -1047,45 +934,46 @@ 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 -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
+suspendSMPQueue :: SMPClient -> 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 -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 {-# INLINE deleteSMPQueue #-}
 
 -- | Delete multiple SMP queues batching commands if supported.
-deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
+deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> 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 -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
-connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
+connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
+connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
   | thVersion (thParams c) >= sendingProxySMPVersion =
-      sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
-        PKEY sId vr (CertChainPubKey chain key) ->
+      sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
+        PKEY sId vr (chain, key) ->
           case supportedClientSMPRelayVRange `compatibleVersion` vr of
             Nothing -> throwE $ transportErr TEVersion
             Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key
         r -> throwE $ unexpectedResponse r
   | otherwise = throwE $ PCETransportError TEVersion
   where
-    tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm
+    tOut = Just $ tcpConnectTimeout + tcpTimeout
     transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
     validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
     validateRelay (X.CertificateChain cert) exact = do
       serverKey <- case cert of
         [leaf, ca]
           | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 ->
-              C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned leaf
+              C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned leaf, []) >>= C.pubKey
         _ -> throwError "bad certificate"
-      C.x509ToPublic' =<< C.verifyX509 serverKey exact
+      pubKey <- C.verifyX509 serverKey exact
+      C.x509ToPublic (pubKey, []) >>= C.pubKey
 
 data ProxiedRelay = ProxiedRelay
   { prSessionId :: SessionId,
@@ -1142,9 +1030,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 -> 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
+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
     Right OK -> pure $ Right ()
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e
@@ -1153,7 +1041,6 @@ proxySMPCommand ::
   forall p.
   PartyI p =>
   SMPClient ->
-  NetworkRequestMode ->
   -- proxy session from PKEY
   ProxiedRelay ->
   -- message to deliver
@@ -1161,33 +1048,32 @@ proxySMPCommand ::
   SenderId ->
   Command p ->
   ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
-proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
+proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
   -- prepare params
-  let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
+  let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
       serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
   (cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
   let cmdSecret = C.dh' serverKey cmdPrivKey
   nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
   -- encode
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
-  -- serviceAuth is False here – proxied commands are not used with service certificates
-  auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey nonce tForAuth
-  b <- case batchTransmissions serverThParams [Right (auth, tToSend)] of
+  auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
+  b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
     [] -> throwE $ PCETransportError TELargeMsg
     TBError e _ : _ -> throwE $ PCETransportError e
     TBTransmission s _ : _ -> pure s
     TBTransmissions s _ _ : _ -> pure s
   et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
   -- proxy interaction errors are wrapped
-  let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
-  tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
+  let tOut = Just $ 2 * tcpTimeout
+  tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
     Right r -> case r of
       PRES (EncResponse er) -> do
         -- server interaction errors are thrown directly
         t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
         case tParse serverThParams t' of
-          t'' :| [] -> case tDecodeClient serverThParams t'' of
-            (_, _, cmd) -> case cmd of
+          t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
+            (_auth, _signed, (_c, _e, cmd)) -> case cmd of
               Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
               Right r' -> pure $ Right r'
               Left e -> throwE $ PCEResponseError e
@@ -1204,7 +1090,6 @@ 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
@@ -1216,7 +1101,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 NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
+  sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case
     RRES (EncFwdResponse efr) -> do
       -- unwrap
       r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -1224,41 +1109,40 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
       pure fwdResponse
     r -> throwE $ unexpectedResponse r
 
--- 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
+getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
+getSMPQueueInfo c pKey qId =
+  sendSMPCommand c (Just pKey) qId QUE >>= \case
     INFO info -> pure info
     r -> throwE $ unexpectedResponse r
 
-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
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
+okSMPCommand cmd c pKey qId =
+  sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
     r -> throwE $ unexpectedResponse r
 
-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
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
+okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
   where
     aCmd = Cmd sParty cmd
-    cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
+    cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
     process (Response _ r) = case r of
       Right OK -> Right ()
       Right r' -> Left $ unexpectedResponse r'
       Left e -> Left e
 
 -- | Send SMP command
-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)
+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)
 {-# 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 -> 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 nm) bs
+sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
+sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
+  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+  validate . concat =<< mapM (sendBatch c) bs
   where
     validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
     validate rs
@@ -1272,13 +1156,13 @@ sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
       where
         diff = L.length cs - length rs
 
-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 nm) bs
+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 = THandleParams {batch, blockSize}} cs cb = do
+  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+  mapM_ (cb <=< sendBatch c) bs
 
-sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
-sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
+sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
+sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
   case b of
     TBError e Request {entityId} -> do
       putStrLn "send error: large message"
@@ -1286,15 +1170,15 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
     TBTransmissions s n rs
       | n > 0 -> do
           nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
-          mapConcurrently (getResponse c nm Nothing) rs
+          mapConcurrently (getResponse c Nothing) rs
       | otherwise -> pure []
     TBTransmission s r -> do
       nonBlockingWriteTBQueue sndQ (Nothing, s)
-      (: []) <$> getResponse c nm Nothing r
+      (: []) <$> getResponse c Nothing r
 
 -- | Send Protocol command
-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
+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
 
 -- 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.
@@ -1302,9 +1186,9 @@ sendProtocolCommand c nm = sendProtocolCommand_ c nm 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 -> 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)
+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}} nonce_ tOut pKey entId cmd =
+  ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
   where
     -- two separate "atomically" needed to avoid blocking
     sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
@@ -1314,20 +1198,20 @@ 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 nm tOut r
+            response <$> getResponse c tOut r
         where
           s
-            | batch = tEncodeBatch1 serviceAuth t
-            | otherwise = tEncode serviceAuth t
+            | batch = tEncodeBatch1 t
+            | otherwise = tEncode t
 
 nonBlockingWriteTBQueue :: TBQueue a -> a -> IO ()
 nonBlockingWriteTBQueue q x = do
   sent <- atomically $ tryWriteTBQueue q x
   unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
 
-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)
+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)
   response <- atomically $ do
     writeTVar pending False
     -- Try to read response again in case it arrived after timeout expired
@@ -1338,14 +1222,14 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} n
       Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout
   pure Response {entityId, response}
 
-mkTransmission :: Protocol v err msg => ProtocolClient v err msg ->  ClientCommand msg -> IO (PCTransmission err msg)
+mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
 mkTransmission c = mkTransmission_ c Nothing
 
 mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
-mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (entityId, pKey_, command) = do
+mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, command) = do
   nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command)
-      auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ nonce tForAuth
+      auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth
   r <- mkRequest (CorrId corrId)
   pure ((,tToSend) <$> auth, r)
   where
@@ -1364,25 +1248,18 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC
       atomically $ TM.insert corrId r sentCommands
       pure r
 
-authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations)
-authTransmission thAuth serviceAuth pKey_ nonce t = traverse authenticate pKey_
+authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TransmissionAuth)
+authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_
   where
-    authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations
-    authenticate (C.APrivateAuthKey a pk) = (,serviceSig) <$> case a of
+    authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
+    authenticate (C.APrivateAuthKey a pk) = case a of
       C.SX25519 -> case thAuth of
-        Just THAuthClient {peerServerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t'
+        Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t
         Nothing -> Left TENoServerAuth
       C.SEd25519 -> sign pk
       C.SEd448 -> sign pk
-    -- When command is signed by both entity key and service key,
-    -- entity key must sign over both transmission and service certificate hash,
-    -- to prevent any service substitution via MITM inside TLS.
-    (t', serviceSig) = case clientService =<< thAuth of
-      Just THClientService {serviceCertHash = XV.Fingerprint fp, serviceKey} | serviceAuth ->
-        (fp <> t, Just $ C.sign' serviceKey t) -- service key only needs to sign transmission itself
-      _ -> (t, Nothing)
     sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
-    sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t')
+    sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
 
 data TBQueueInfo = TBQueueInfo
   { qLength :: Int,
@@ -1414,8 +1291,6 @@ $(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

@@ -1,8 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -11,27 +9,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Simplex.Messaging.Client.Agent
-  ( SMPClientAgent (..),
-    SMPClientAgentConfig (..),
-    SMPClientAgentEvent (..),
-    OwnServer,
-    defaultSMPClientAgentConfig,
-    newSMPClientAgent,
-    getSMPServerClient'',
-    getConnectedSMPServerClient,
-    closeSMPClientAgent,
-    lookupSMPServerClient,
-    isOwnServer,
-    subscribeServiceNtfs,
-    subscribeQueuesNtfs,
-    activeClientSession',
-    removeActiveSub,
-    removeActiveSubs,
-    removePendingSub,
-    removePendingSubs,
-  )
-where
+module Simplex.Messaging.Client.Agent where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
@@ -42,38 +20,24 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
+import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Constraint (Dict (..))
-import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isJust, isNothing)
+import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text.Encoding
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
+import Data.Tuple (swap)
 import Numeric.Natural
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol
-  ( BrokerMsg,
-    ErrorType,
-    NotifierId,
-    NtfPrivateAuthKey,
-    Party (..),
-    PartyI,
-    ProtocolServer (..),
-    QueueId,
-    SMPServer,
-    SParty (..),
-    ServiceParty,
-    serviceParty,
-    partyServiceRole
-  )
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
 import Simplex.Messaging.Session
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -87,18 +51,17 @@ import UnliftIO.STM
 type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient))
 
 data SMPClientAgentEvent
-  = CAConnected SMPServer (Maybe ServiceId)
-  | CADisconnected SMPServer (NonEmpty QueueId)
-  | CASubscribed SMPServer (Maybe ServiceId) (NonEmpty QueueId)
-  | CASubError SMPServer (NonEmpty (QueueId, SMPClientError))
-  | CAServiceDisconnected SMPServer (ServiceId, Int64)
-  | CAServiceSubscribed SMPServer (ServiceId, Int64) Int64
-  | CAServiceSubError SMPServer (ServiceId, Int64) SMPClientError
-  -- CAServiceUnavailable is used when service ID in pending subscription is different from the current service in connection.
-  -- This will require resubscribing to all queues associated with this service ID individually, creating new associations.
-  -- It may happen if, for example, SMP server deletes service information (e.g. via downgrade and upgrade)
-  -- and assigns different service ID to the service certificate.
-  | CAServiceUnavailable SMPServer (ServiceId, Int64)
+  = CAConnected SMPServer
+  | CADisconnected SMPServer (Set SMPSub)
+  | CASubscribed SMPServer SMPSubParty (NonEmpty QueueId)
+  | CASubError SMPServer SMPSubParty (NonEmpty (QueueId, SMPClientError))
+
+data SMPSubParty = SPRecipient | SPNotifier
+  deriving (Eq, Ord, Show)
+
+type SMPSub = (SMPSubParty, QueueId)
+
+-- type SMPServerSub = (SMPServer, SMPSub)
 
 data SMPClientAgentConfig = SMPClientAgentConfig
   { smpCfg :: ProtocolClientConfig SMPVersion,
@@ -129,9 +92,8 @@ defaultSMPClientAgentConfig =
   where
     second = 1000000
 
-data SMPClientAgent p = SMPClientAgent
+data SMPClientAgent = SMPClientAgent
   { agentCfg :: SMPClientAgentConfig,
-    agentParty :: SParty p,
     active :: TVar Bool,
     startedAt :: UTCTime,
     msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
@@ -139,39 +101,29 @@ data SMPClientAgent p = SMPClientAgent
     randomDrg :: TVar ChaChaDRG,
     smpClients :: TMap SMPServer SMPClientVar,
     smpSessions :: TMap SessionId (OwnServer, SMPClient),
-    -- Only one service subscription can exist per server with this agent.
-    -- With correctly functioning SMP server, queue and service subscriptions can't be
-    -- active at the same time.
-    activeServiceSubs :: TMap SMPServer (TVar (Maybe ((ServiceId, Int64), SessionId))),
-    activeQueueSubs :: TMap SMPServer (TMap QueueId (SessionId, C.APrivateAuthKey)),
-    -- Pending service subscriptions can co-exist with pending queue subscriptions
-    -- on the same SMP server during subscriptions being transitioned from per-queue to service.
-    pendingServiceSubs :: TMap SMPServer (TVar (Maybe (ServiceId, Int64))),
-    pendingQueueSubs :: TMap SMPServer (TMap QueueId C.APrivateAuthKey),
+    srvSubs :: TMap SMPServer (TMap SMPSub (SessionId, C.APrivateAuthKey)),
+    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
     smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
     workerSeq :: TVar Int
   }
 
 type OwnServer = Bool
 
-newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO (SMPClientAgent p)
-newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
+newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
+newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
   active <- newTVarIO True
   startedAt <- getCurrentTime
   msgQ <- newTBQueueIO msgQSize
   agentQ <- newTBQueueIO agentQSize
   smpClients <- TM.emptyIO
   smpSessions <- TM.emptyIO
-  activeServiceSubs <- TM.emptyIO
-  activeQueueSubs <- TM.emptyIO
-  pendingServiceSubs <- TM.emptyIO
-  pendingQueueSubs <- TM.emptyIO
+  srvSubs <- TM.emptyIO
+  pendingSrvSubs <- TM.emptyIO
   smpSubWorkers <- TM.emptyIO
   workerSeq <- newTVarIO 0
   pure
     SMPClientAgent
       { agentCfg,
-        agentParty,
         active,
         startedAt,
         msgQ,
@@ -179,20 +131,18 @@ newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize
         randomDrg,
         smpClients,
         smpSessions,
-        activeServiceSubs,
-        activeQueueSubs,
-        pendingServiceSubs,
-        pendingQueueSubs,
+        srvSubs,
+        pendingSrvSubs,
         smpSubWorkers,
         workerSeq
       }
 
 -- | Get or create SMP client for SMPServer
-getSMPServerClient' :: SMPClientAgent p -> SMPServer -> ExceptT SMPClientError IO SMPClient
+getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
 getSMPServerClient' ca srv = snd <$> getSMPServerClient'' ca srv
 {-# INLINE getSMPServerClient' #-}
 
-getSMPServerClient'' :: SMPClientAgent p -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
+getSMPServerClient'' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
 getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, workerSeq} srv = do
   ts <- liftIO getCurrentTime
   atomically (getClientVar ts) >>= either (ExceptT . newSMPClient) waitForSMPClient
@@ -203,7 +153,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 $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
+      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
       case smpClient_ of
         Just (Right smpClient) -> pure smpClient
         Just (Left (e, ts_)) -> case ts_ of
@@ -226,8 +176,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
           atomically $ do
             putTMVar (sessionVar v) (Right c)
             TM.insert (sessionId $ thParams smp) c smpSessions
-          let serviceId_ = (\THClientService {serviceId} -> serviceId) <$> smpClientService smp
-          notify ca $ CAConnected srv serviceId_
+          notify ca $ CAConnected srv
           pure $ Right c
         Left e -> do
           let ei = persistErrorInterval agentCfg
@@ -241,68 +190,49 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
           reconnectClient ca srv
           pure $ Left e
 
-isOwnServer :: SMPClientAgent p -> SMPServer -> OwnServer
+isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer
 isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
   let srv = strEncode $ L.head host
    in any (\s -> s == srv || B.cons '.' s `B.isSuffixOf` srv) (ownServerDomains agentCfg)
 
 -- | Run an SMP client for SMPClientVar
-connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
+connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
 connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
-  getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
+  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
   where
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected smp = do
-      removeClientAndSubs smp >>= serverDown
+      removeClientAndSubs smp >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    removeClientAndSubs :: SMPClient -> IO (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey))
-    removeClientAndSubs smp = do
-      -- Looking up subscription vars outside of STM transaction to reduce re-evaluation.
-      -- It is possible because these vars are never removed, they are only added.
-      sVar_ <- TM.lookupIO srv $ activeServiceSubs ca
-      qVar_ <- TM.lookupIO srv $ activeQueueSubs ca
-      atomically $ do
-        TM.delete sessId smpSessions
-        removeSessVar v srv smpClients
-        sSub <- pure sVar_ $>>= updateServiceSub
-        qSubs <- pure qVar_ $>>= updateQueueSubs
-        pure (sSub, qSubs)
+    removeClientAndSubs :: SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey))
+    removeClientAndSubs smp = atomically $ do
+      TM.delete sessId smpSessions
+      removeSessVar v srv smpClients
+      TM.lookup srv (srvSubs ca) >>= mapM updateSubs
       where
         sessId = sessionId $ thParams smp
-        updateServiceSub sVar = do -- (sub, sessId')
-          -- We don't change active subscription in case session ID is different from disconnected client
-          serviceSub_ <- stateTVar sVar $ \case
-            Just (serviceSub, sessId') | sessId == sessId' -> (Just serviceSub, Nothing)
-            s -> (Nothing, s)
-          -- We don't reset pending subscription to Nothing here to avoid any race conditions
-          -- with subsequent client sessions that might have set pending already.
-          when (isJust serviceSub_) $ setPendingServiceSub ca srv serviceSub_
-          pure serviceSub_
-        updateQueueSubs qVar = do
+        updateSubs sVar = do
           -- removing subscriptions that have matching sessionId to disconnected client
           -- and keep the other ones (they can be made by the new client)
-          subs <- M.map snd <$> stateTVar qVar (M.partition ((sessId ==) . fst))
-          if M.null subs
-            then pure Nothing
-            else Just subs <$ addSubs_ (pendingQueueSubs ca) srv subs
+          pending <- M.map snd <$> stateTVar sVar (M.partition ((sessId ==) . fst))
+          addSubs_ (pendingSrvSubs ca) srv pending
+          pure pending
 
-    serverDown :: (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey)) -> IO ()
-    serverDown (sSub, qSubs) = do
-      mapM_ (notify ca . CAServiceDisconnected srv) sSub
-      let qIds = L.nonEmpty . M.keys =<< qSubs
-      mapM_ (notify ca . CADisconnected srv) qIds
-      when (isJust sSub || isJust qIds) $ reconnectClient ca srv
+    serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
+    serverDown ss = unless (M.null ss) $ do
+      notify ca . CADisconnected srv $ M.keysSet ss
+      reconnectClient ca srv
 
 -- | Spawn reconnect worker if needed
-reconnectClient :: SMPClientAgent p -> SMPServer -> IO ()
+reconnectClient :: SMPClientAgent -> SMPServer -> IO ()
 reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} srv = do
   ts <- getCurrentTime
   whenM (readTVarIO active) $ atomically (getWorkerVar ts) >>= mapM_ (either newSubWorker (\_ -> pure ()))
   where
     getWorkerVar ts =
       ifM
-        (noPending <$> getPending TM.lookup readTVar)
+        (noPending)
         (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
         (Just <$> getSessVar workerSeq srv smpSubWorkers ts)
     newSubWorker :: SessionVar (Async ()) -> IO ()
@@ -311,17 +241,13 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       atomically $ putTMVar (sessionVar v) a
     runSubWorker =
       withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
-        subs <- getPending TM.lookupIO readTVarIO
-        unless (noPending subs) $ whenM (readTVarIO active) $ do
-          void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
+        pending <- liftIO getPending
+        unless (null pending) $ whenM (readTVarIO active) $ do
+          void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending)
           loop
     ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-    noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs
-    getPending :: Monad m => (forall a. SMPServer -> TMap SMPServer a -> m (Maybe a)) -> (forall a. TVar a -> m a) -> m (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey))
-    getPending lkup rd = do
-      sSub <- lkup srv (pendingServiceSubs ca) $>>= rd
-      qSubs <- lkup srv (pendingQueueSubs ca) >>= mapM rd
-      pure (sSub, qSubs)
+    noPending = maybe (pure True) (fmap M.null . readTVar) =<< TM.lookup srv (pendingSrvSubs ca)
+    getPending = maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (pendingSrvSubs ca)
     cleanup :: SessionVar (Async ()) -> STM ()
     cleanup v = do
       -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
@@ -329,28 +255,32 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       whenM (isEmptyTMVar $ sessionVar v) retry
       removeSessVar v srv smpSubWorkers
 
-reconnectSMPClient :: forall p. SMPClientAgent p -> SMPServer -> (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey)) -> ExceptT SMPClientError IO ()
-reconnectSMPClient ca@SMPClientAgent {agentCfg, agentParty} srv (sSub_, qSubs_) =
-  withSMP ca srv $ \smp -> liftIO $ case serviceParty agentParty of
-    Just Dict -> resubscribe smp
-    Nothing -> pure ()
+reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO ()
+reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs =
+  withSMP ca srv $ \smp -> liftIO $ do
+    currSubs <- maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (srvSubs ca)
+    let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs
+    subscribe_ smp SPNotifier nSubs
+    subscribe_ smp SPRecipient rSubs
   where
-    resubscribe :: (PartyI p, ServiceParty p) => SMPClient -> IO ()
-    resubscribe smp = do
-      mapM_ (smpSubscribeService ca smp srv) sSub_
-      forM_ qSubs_ $ \qSubs -> do
-        currSubs_ <- mapM readTVarIO =<< TM.lookupIO srv (activeQueueSubs ca)
-        let qSubs' :: [(QueueId, C.APrivateAuthKey)] =
-              maybe id (\currSubs -> filter ((`M.notMember` currSubs) . fst)) currSubs_ $ M.assocs qSubs
-        mapM_ (smpSubscribeQueues @p ca smp srv) $ toChunks (agentSubsBatchSize agentCfg) qSubs'
+    groupSub :: Map SMPSub (SessionId, C.APrivateAuthKey) -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
+    groupSub currSubs (s@(party, qId), k) acc@(nSubs, rSubs)
+      | M.member s currSubs = acc
+      | otherwise = case party of
+          SPNotifier -> (s' : nSubs, rSubs)
+          SPRecipient -> (nSubs, s' : rSubs)
+      where
+        s' = (qId, k)
+    subscribe_ :: SMPClient -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> IO ()
+    subscribe_ smp party = mapM_ (smpSubscribeQueues party ca smp srv) . toChunks (agentSubsBatchSize agentCfg)
 
-notify :: MonadIO m => SMPClientAgent p -> SMPClientAgentEvent -> m ()
+notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
 notify ca evt = atomically $ writeTBQueue (agentQ ca) evt
 {-# INLINE notify #-}
 
 -- Returns already connected client for proxying messages or Nothing if client is absent, not connected yet or stores expired error.
 -- If Nothing is return proxy will spawn a new thread to wait or to create another client connection to destination relay.
-getConnectedSMPServerClient :: SMPClientAgent p -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
+getConnectedSMPServerClient :: SMPClientAgent -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
 getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
   atomically (TM.lookup srv smpClients $>>= \v -> (v,) <$$> tryReadTMVar (sessionVar v)) -- Nothing: client is absent or not connected yet
     $>>= \case
@@ -363,10 +293,10 @@ getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
             (Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection
             (pure $ Just $ Left e) -- not expired, returning error
 
-lookupSMPServerClient :: SMPClientAgent p -> SessionId -> IO (Maybe (OwnServer, SMPClient))
+lookupSMPServerClient :: SMPClientAgent -> SessionId -> IO (Maybe (OwnServer, SMPClient))
 lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookupIO sessId smpSessions
 
-closeSMPClientAgent :: SMPClientAgent p -> IO ()
+closeSMPClientAgent :: SMPClientAgent -> IO ()
 closeSMPClientAgent c = do
   atomically $ writeTVar (active c) False
   closeSMPServerClients c
@@ -375,7 +305,7 @@ closeSMPClientAgent c = do
     cancelReconnect :: SessionVar (Async ()) -> IO ()
     cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel
 
-closeSMPServerClients :: SMPClientAgent p -> IO ()
+closeSMPServerClients :: SMPClientAgent -> IO ()
 closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient)
   where
     closeClient v =
@@ -386,30 +316,30 @@ closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_
 cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
 cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
 
-withSMP :: SMPClientAgent p -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
+withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
 withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
   where
     logSMPError :: SMPClientError -> ExceptT SMPClientError IO a
     logSMPError e = do
-      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode srv) <> "): " <> tshow e
+      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host srv) <> "): " <> tshow e
       throwE e
 
-subscribeQueuesNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
-subscribeQueuesNtfs = subscribeQueues_
-{-# INLINE subscribeQueuesNtfs #-}
+subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO ()
+subscribeQueuesSMP = subscribeQueues_ SPRecipient
 
-subscribeQueues_ :: ServiceParty p => SMPClientAgent p -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
-subscribeQueues_ ca srv subs = do
-  atomically $ addPendingSubs ca srv $ L.toList subs
+subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
+subscribeQueuesNtfs = subscribeQueues_ SPNotifier
+
+subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
+subscribeQueues_ party ca srv subs = do
+  atomically $ addPendingSubs ca srv party $ L.toList subs
   runExceptT (getSMPServerClient' ca srv) >>= \case
-    Right smp -> smpSubscribeQueues ca smp srv subs
+    Right smp -> smpSubscribeQueues party ca smp srv subs
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
 
-smpSubscribeQueues :: ServiceParty p => SMPClientAgent p -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
-smpSubscribeQueues ca smp srv subs = do
-  rs <- case agentParty ca of
-    SRecipientService -> subscribeSMPQueues smp subs
-    SNotifierService -> subscribeSMPQueuesNtfs smp subs
+smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
+smpSubscribeQueues party ca smp srv subs = do
+  rs <- subscribe smp $ L.map swap subs
   rs' <-
     atomically $
       ifM
@@ -417,164 +347,87 @@ smpSubscribeQueues ca smp srv subs = do
         (Just <$> processSubscriptions rs)
         (pure Nothing)
   case rs' of
-    Just (tempErrs, finalErrs, (qOks, sQs), _) -> do
-      notify_ (`CASubscribed` Nothing) $ map fst qOks
-      when (isJust smpServiceId) $ notify_ (`CASubscribed` smpServiceId) sQs
+    Just (tempErrs, finalErrs, oks, _) -> do
+      notify_ CASubscribed $ map fst oks
       notify_ CASubError finalErrs
       when tempErrs $ reconnectClient ca srv
     Nothing -> reconnectClient ca srv
   where
-    processSubscriptions :: NonEmpty (Either SMPClientError (Maybe ServiceId)) -> STM (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId])
+    processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
     processSubscriptions rs = do
-      pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingQueueSubs ca)
-      let acc@(_, _, (qOks, sQs), notPending) = foldr (groupSub pending) (False, [], ([], []), []) (L.zip subs rs)
-      unless (null qOks) $ addActiveSubs ca srv qOks
-      unless (null sQs) $ forM_ smpServiceId $ \serviceId ->
-        updateActiveServiceSub ca srv ((serviceId, fromIntegral $ length sQs), sessId)
-      unless (null notPending) $ removePendingSubs ca srv notPending
+      pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
+      let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs)
+      unless (null oks) $ addSubscriptions ca srv party oks
+      unless (null notPending) $ removePendingSubs ca srv party notPending
       pure acc
     sessId = sessionId $ thParams smp
-    smpServiceId = (\THClientService {serviceId} -> serviceId) <$> smpClientService smp
-    groupSub ::
-      Map QueueId C.APrivateAuthKey ->
-      ((QueueId, C.APrivateAuthKey), Either SMPClientError (Maybe ServiceId)) ->
-      (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) ->
-      (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId])
-    groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks@(qOks, sQs), notPending) = case r of
-      Right serviceId_
-        | M.member qId pending ->
-            let oks' = case (smpServiceId, serviceId_) of
-                  (Just sId, Just sId') | sId == sId' -> (qOks, qId : sQs)
-                  _ -> ((qId, (sessId, pk)) : qOks, sQs)
-             in (tempErrs, finalErrs, oks', qId : notPending)
+    groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
+    groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
+      Right ()
+        | M.member (party, qId) pending -> (tempErrs, finalErrs, (qId, (sessId, pk)) : oks, qId : notPending)
         | otherwise -> acc
       Left e
         | temporaryClientError e -> (True, finalErrs, oks, notPending)
         | otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending)
-    notify_ :: (SMPServer -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
-    notify_ evt qs = mapM_ (notify ca . evt srv) $ L.nonEmpty qs
+    subscribe = case party of
+      SPRecipient -> subscribeSMPQueues
+      SPNotifier -> subscribeSMPQueuesNtfs
+    notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
+    notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs
 
-subscribeServiceNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> (ServiceId, Int64) -> IO ()
-subscribeServiceNtfs = subscribeService_
-{-# INLINE subscribeServiceNtfs #-}
-
-subscribeService_ :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPServer -> (ServiceId, Int64) -> IO ()
-subscribeService_ ca srv serviceSub = do
-  atomically $ setPendingServiceSub ca srv $ Just serviceSub
-  runExceptT (getSMPServerClient' ca srv) >>= \case
-    Right smp -> smpSubscribeService ca smp srv serviceSub
-    Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
-
-smpSubscribeService :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPClient -> SMPServer -> (ServiceId, Int64) -> IO ()
-smpSubscribeService ca smp srv serviceSub@(serviceId, _) = case smpClientService smp of
-  Just service | serviceAvailable service -> subscribe
-  _ -> notifyUnavailable
-  where
-    subscribe = do
-      r <- runExceptT $ subscribeService smp $ agentParty ca
-      ok <-
-        atomically $
-          ifM
-            (activeClientSession ca smp srv)
-            (True <$ processSubscription r)
-            (pure False)
-      if ok
-        then case r of
-          Right n -> notify ca $ CAServiceSubscribed srv serviceSub n
-          Left e
-            | smpClientServiceError e -> notifyUnavailable
-            | temporaryClientError e -> reconnectClient ca srv
-            | otherwise -> notify ca $ CAServiceSubError srv serviceSub e
-        else reconnectClient ca srv
-    processSubscription = mapM_ $ \n -> do
-      setActiveServiceSub ca srv $ Just ((serviceId, n), sessId)
-      setPendingServiceSub ca srv Nothing
-    serviceAvailable THClientService {serviceRole, serviceId = serviceId'} =
-      serviceId == serviceId' && partyServiceRole (agentParty ca) == serviceRole
-    notifyUnavailable = do
-      atomically $ setPendingServiceSub ca srv Nothing
-      notify ca $ CAServiceUnavailable srv serviceSub -- this will resubscribe all queues directly
-    sessId = sessionId $ thParams smp
-
-activeClientSession' :: SMPClientAgent p -> SessionId -> SMPServer -> STM Bool
+activeClientSession' :: SMPClientAgent -> SessionId -> SMPServer -> STM Bool
 activeClientSession' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
   where
     sameSess = \case
       Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
       _ -> False
 
-activeClientSession :: SMPClientAgent p -> SMPClient -> SMPServer -> STM Bool
+activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
 activeClientSession ca = activeClientSession' ca . sessionId . thParams
 
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
 
-addActiveSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
-addActiveSubs = addSubsList_ . activeQueueSubs
-{-# INLINE addActiveSubs #-}
+addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
+addSubscriptions = addSubsList_ . srvSubs
+{-# INLINE addSubscriptions #-}
 
-addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> STM ()
-addPendingSubs = addSubsList_ . pendingQueueSubs
+addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
+addPendingSubs = addSubsList_ . pendingSrvSubs
 {-# INLINE addPendingSubs #-}
 
-addSubsList_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [(QueueId, s)] -> STM ()
-addSubsList_ subs srv ss = addSubs_ subs srv $ M.fromList ss
-  -- where
-  --   ss' = M.fromList $ map (first (party,)) ss
+addSubsList_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [(QueueId, s)] -> STM ()
+addSubsList_ subs srv party ss = addSubs_ subs srv ss'
+  where
+    ss' = M.fromList $ map (first (party,)) ss
 
-addSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> STM ()
+addSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> Map SMPSub s -> STM ()
 addSubs_ subs srv ss =
   TM.lookup srv subs >>= \case
     Just m -> TM.union ss m
-    _ -> TM.insertM srv (newTVar ss) subs
+    _ -> newTVar ss >>= \v -> TM.insert srv v subs
 
-setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe ((ServiceId, Int64), SessionId) -> STM ()
-setActiveServiceSub = setServiceSub_ activeServiceSubs
-{-# INLINE setActiveServiceSub #-}
+removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
+removeSubscription = removeSub_ . srvSubs
+{-# INLINE removeSubscription #-}
 
-setPendingServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceId, Int64) -> STM ()
-setPendingServiceSub = setServiceSub_ pendingServiceSubs
-{-# INLINE setPendingServiceSub #-}
-
-setServiceSub_ ::
-  (SMPClientAgent p -> TMap SMPServer (TVar (Maybe sub))) ->
-  SMPClientAgent p ->
-  SMPServer ->
-  Maybe sub ->
-  STM ()
-setServiceSub_ subsSel ca srv sub =
-  TM.lookup srv (subsSel ca) >>= \case
-    Just v -> writeTVar v sub
-    Nothing -> TM.insertM srv (newTVar sub) (subsSel ca)
-
-updateActiveServiceSub :: SMPClientAgent p -> SMPServer -> ((ServiceId, Int64), SessionId) -> STM ()
-updateActiveServiceSub ca srv sub@((serviceId', n'), sessId') =
-  TM.lookup srv (activeServiceSubs ca) >>= \case
-    Just v -> modifyTVar' v $ \case
-      Just ((serviceId, n), sessId) | serviceId == serviceId' && sessId == sessId' ->
-        Just ((serviceId, n + n'), sessId)
-      _ -> Just sub
-    Nothing -> TM.insertM srv (newTVar $ Just sub) (activeServiceSubs ca)
-
-removeActiveSub :: SMPClientAgent p -> SMPServer -> QueueId -> STM ()
-removeActiveSub = removeSub_ . activeQueueSubs
-{-# INLINE removeActiveSub #-}
-
-removePendingSub :: SMPClientAgent p -> SMPServer -> QueueId -> STM ()
-removePendingSub = removeSub_ . pendingQueueSubs
+removePendingSub :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
+removePendingSub = removeSub_ . pendingSrvSubs
 {-# INLINE removePendingSub #-}
 
-removeSub_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> QueueId -> STM ()
+removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM ()
 removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
 
-removeActiveSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
-removeActiveSubs = removeSubs_ . activeQueueSubs
-{-# INLINE removeActiveSubs #-}
+removeSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
+removeSubscriptions = removeSubs_ . srvSubs
+{-# INLINE removeSubscriptions #-}
 
-removePendingSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
-removePendingSubs = removeSubs_ . pendingQueueSubs
+removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
+removePendingSubs = removeSubs_ . pendingSrvSubs
 {-# INLINE removePendingSubs #-}
 
-removeSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [QueueId] -> STM ()
-removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` S.fromList qs))
+removeSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
+removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss))
+  where
+    ss = S.fromList $ map (party,) qs

src/Simplex/Messaging/Crypto.hs

@@ -64,7 +64,6 @@ module Simplex.Messaging.Crypto
     AAuthKeyPair,
     KeyPair,
     KeyPairX25519,
-    KeyPairEd25519,
     ASignatureKeyPair,
     DhSecret (..),
     DhSecretX25519,
@@ -76,13 +75,10 @@ module Simplex.Messaging.Crypto
     generateKeyPair,
     generateSignatureKeyPair,
     generateAuthKeyPair,
-    generatePrivateAuthKey,
     generateDhKeyPair,
     privateToX509,
     x509ToPublic,
-    x509ToPublic',
     x509ToPrivate,
-    x509ToPrivate',
     publicKey,
     signatureKeyPair,
     publicToX509,
@@ -183,6 +179,8 @@ module Simplex.Messaging.Crypto
     unPad,
 
     -- * X509 Certificates
+    SignedCertificate,
+    Certificate,
     signCertificate,
     signX509,
     verifyX509,
@@ -242,7 +240,7 @@ import Data.String
 import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
 import Data.Word (Word32)
-import qualified Data.X509 as X
+import Data.X509
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
@@ -330,10 +328,10 @@ type PublicKeyX448 = PublicKey X448
 
 -- | GADT for private keys.
 data PrivateKey (a :: Algorithm) where
-  PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519
-  PrivateKeyEd448 :: Ed448.SecretKey -> PrivateKey Ed448
-  PrivateKeyX25519 :: X25519.SecretKey -> PrivateKey X25519
-  PrivateKeyX448 :: X448.SecretKey -> PrivateKey X448
+  PrivateKeyEd25519 :: Ed25519.SecretKey -> Ed25519.PublicKey -> PrivateKey Ed25519
+  PrivateKeyEd448 :: Ed448.SecretKey -> Ed448.PublicKey -> PrivateKey Ed448
+  PrivateKeyX25519 :: X25519.SecretKey -> X25519.PublicKey -> PrivateKey X25519
+  PrivateKeyX448 :: X448.SecretKey -> X448.PublicKey -> PrivateKey X448
 
 deriving instance Eq (PrivateKey a)
 
@@ -617,66 +615,48 @@ class CryptoPrivateKey pk where
   type PublicKeyType pk
   toPrivKey :: (forall a. AlgorithmI a => PrivateKey a -> b) -> pk -> b
   privKey :: APrivateKey -> Either String pk
-  toPublic :: pk -> PublicKeyType pk
 
 instance CryptoPrivateKey APrivateKey where
   type PublicKeyType APrivateKey = APublicKey
   toPrivKey f (APrivateKey _ k) = f k
-  {-# INLINE toPrivKey #-}
   privKey = Right
-  {-# INLINE privKey #-}
-  toPublic (APrivateKey a k) = APublicKey a (toPublic k)
-  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateSignKey where
   type PublicKeyType APrivateSignKey = APublicVerifyKey
   toPrivKey f (APrivateSignKey _ k) = f k
-  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case signatureAlgorithm a of
     Just Dict -> Right $ APrivateSignKey a k
     _ -> Left "key does not support signature algorithms"
-  toPublic (APrivateSignKey a k) = APublicVerifyKey a (toPublic k)
-  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateAuthKey where
   type PublicKeyType APrivateAuthKey = APublicAuthKey
   toPrivKey f (APrivateAuthKey _ k) = f k
-  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case authAlgorithm a of
     Just Dict -> Right $ APrivateAuthKey a k
     _ -> Left "key does not support auth algorithms"
-  toPublic (APrivateAuthKey a k) = APublicAuthKey a (toPublic k)
-  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateDhKey where
   type PublicKeyType APrivateDhKey = APublicDhKey
   toPrivKey f (APrivateDhKey _ k) = f k
-  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case dhAlgorithm a of
     Just Dict -> Right $ APrivateDhKey a k
     _ -> Left "key does not support DH algorithm"
-  toPublic (APrivateDhKey a k) = APublicDhKey a (toPublic k)
-  {-# INLINE toPublic #-}
 
 instance AlgorithmI a => CryptoPrivateKey (PrivateKey a) where
   type PublicKeyType (PrivateKey a) = PublicKey a
   toPrivKey = id
-  {-# INLINE toPrivKey #-}
   privKey (APrivateKey _ k) = checkAlgorithm k
-  {-# INLINE privKey #-}
-  toPublic = publicKey
-  {-# INLINE toPublic #-}
 
 publicKey :: PrivateKey a -> PublicKey a
 publicKey = \case
-  PrivateKeyEd25519 pk -> PublicKeyEd25519 (Ed25519.toPublic pk)
-  PrivateKeyEd448 pk -> PublicKeyEd448 (Ed448.toPublic pk)
-  PrivateKeyX25519 pk -> PublicKeyX25519 (X25519.toPublic pk)
-  PrivateKeyX448 pk -> PublicKeyX448 (X448.toPublic pk)
+  PrivateKeyEd25519 _ k -> PublicKeyEd25519 k
+  PrivateKeyEd448 _ k -> PublicKeyEd448 k
+  PrivateKeyX25519 _ k -> PublicKeyX25519 k
+  PrivateKeyX448 _ k -> PublicKeyX448 k
 
 -- | Expand signature private key to a key pair.
 signatureKeyPair :: APrivateSignKey -> ASignatureKeyPair
-signatureKeyPair ak@(APrivateSignKey a k) = (APublicVerifyKey a (toPublic k), ak)
+signatureKeyPair ak@(APrivateSignKey a k) = (APublicVerifyKey a (publicKey k), ak)
 
 encodePrivKey :: CryptoPrivateKey pk => pk -> ByteString
 encodePrivKey = toPrivKey $ encodeASNObj . privateToX509
@@ -700,8 +680,6 @@ type KeyPair a = KeyPairType (PrivateKey a)
 
 type KeyPairX25519 = KeyPair X25519
 
-type KeyPairEd25519 = KeyPair Ed25519
-
 -- TODO narrow key pair types to have the same algorithm in both keys
 type AKeyPair = KeyPairType APrivateKey
 
@@ -726,9 +704,6 @@ generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$
 generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
 generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g
 
-generatePrivateAuthKey :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM APrivateAuthKey
-generatePrivateAuthKey a g = APrivateAuthKey a <$> generatePrivateKey g
-
 generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair
 generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g
 
@@ -736,19 +711,23 @@ generateKeyPair :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (KeyPair a)
 generateKeyPair g = stateTVar g (`withDRG` generateKeyPair_)
 
 generateKeyPair_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (KeyPair a)
-generateKeyPair_ = do
-  pk <- generatePrivateKey_
-  pure (toPublic pk, pk)
-
-generatePrivateKey :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (PrivateKey a)
-generatePrivateKey g = stateTVar g (`withDRG` generatePrivateKey_)
-
-generatePrivateKey_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (PrivateKey a)
-generatePrivateKey_ = case sAlgorithm @a of
-  SEd25519 -> PrivateKeyEd25519 <$> Ed25519.generateSecretKey
-  SEd448 -> PrivateKeyEd448 <$> Ed448.generateSecretKey
-  SX25519 -> PrivateKeyX25519 <$> X25519.generateSecretKey
-  SX448 -> PrivateKeyX448 <$> X448.generateSecretKey
+generateKeyPair_ = case sAlgorithm @a of
+  SEd25519 ->
+    Ed25519.generateSecretKey >>= \pk ->
+      let k = Ed25519.toPublic pk
+       in pure (PublicKeyEd25519 k, PrivateKeyEd25519 pk k)
+  SEd448 ->
+    Ed448.generateSecretKey >>= \pk ->
+      let k = Ed448.toPublic pk
+       in pure (PublicKeyEd448 k, PrivateKeyEd448 pk k)
+  SX25519 ->
+    X25519.generateSecretKey >>= \pk ->
+      let k = X25519.toPublic pk
+       in pure (PublicKeyX25519 k, PrivateKeyX25519 pk k)
+  SX448 ->
+    X448.generateSecretKey >>= \pk ->
+      let k = X448.toPublic pk
+       in pure (PublicKeyX448 k, PrivateKeyX448 pk k)
 
 instance ToField APrivateSignKey where toField = toField . Binary . encodePrivKey
 
@@ -872,8 +851,8 @@ instance SignatureSize APublicVerifyKey where
 
 instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where
   signatureSize = \case
-    PrivateKeyEd25519 _ -> Ed25519.signatureSize
-    PrivateKeyEd448 _ -> Ed448.signatureSize
+    PrivateKeyEd25519 _ _ -> Ed25519.signatureSize
+    PrivateKeyEd448 _ _ -> Ed448.signatureSize
   {-# INLINE signatureSize #-}
 
 instance SignatureAlgorithm a => SignatureSize (PublicKey a) where
@@ -1173,20 +1152,20 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
 --
 -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages.
 sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
-sign' (PrivateKeyEd25519 pk) msg = SignatureEd25519 $ Ed25519.sign pk (Ed25519.toPublic pk) msg
-sign' (PrivateKeyEd448 pk) msg = SignatureEd448 $ Ed448.sign pk (Ed448.toPublic pk) msg
+sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
+sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
 {-# INLINE sign' #-}
 
 sign :: APrivateSignKey -> ByteString -> ASignature
 sign (APrivateSignKey a k) = ASignature a . sign' k
 {-# INLINE sign #-}
 
-signCertificate :: APrivateSignKey -> X.Certificate -> X.SignedCertificate
+signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
 signCertificate = signX509
 {-# INLINE signCertificate #-}
 
-signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> X.SignedExact o
-signX509 key = fst . X.objectToSignedExact f
+signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
+signX509 key = fst . objectToSignedExact f
   where
     f bytes =
       ( signatureBytes $ sign key bytes,
@@ -1195,33 +1174,33 @@ signX509 key = fst . X.objectToSignedExact f
       )
 {-# INLINE signX509 #-}
 
-verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> X.SignedExact o -> Either String o
+verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o
 verifyX509 key exact = do
   signature <- case signedAlg of
-    X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
-    X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
+    SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
+    SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
     _ -> Left "unknown x509 signature algorithm"
-  if verify key signature $ X.getSignedData exact then Right signedObject else Left "bad signature"
+  if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature"
   where
-    X.Signed {signedObject, signedAlg, signedSignature} = X.getSigned exact
+    Signed {signedObject, signedAlg, signedSignature} = getSigned exact
 {-# INLINE verifyX509 #-}
 
-certificateFingerprint :: X.SignedCertificate -> KeyHash
+certificateFingerprint :: SignedCertificate -> KeyHash
 certificateFingerprint = signedFingerprint
 {-# INLINE certificateFingerprint #-}
 
-signedFingerprint :: (ASN1Object o, Eq o, Show o) => X.SignedExact o -> KeyHash
+signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
 signedFingerprint o = KeyHash fp
   where
-    Fingerprint fp = getFingerprint o X.HashSHA256
+    Fingerprint fp = getFingerprint o HashSHA256
 
 class SignatureAlgorithmX509 a where
-  signatureAlgorithmX509 :: a -> X.SignatureALG
+  signatureAlgorithmX509 :: a -> SignatureALG
 
 instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
   signatureAlgorithmX509 = \case
-    SEd25519 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519
-    SEd448 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448
+    SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
+    SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
   {-# INLINE signatureAlgorithmX509 #-}
 
 instance SignatureAlgorithmX509 APrivateSignKey where
@@ -1238,31 +1217,31 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
   {-# INLINE signatureAlgorithmX509 #-}
 
 -- | A wrapper to marshall signed ASN1 objects, like certificates.
-newtype SignedObject a = SignedObject {getSignedExact :: X.SignedExact a}
+newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
 
 instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
 #if defined(dbPostgres)
-  fromField f dat = SignedObject <$> blobFieldDecoder X.decodeSignedObject f dat
+  fromField f dat = SignedObject <$> blobFieldDecoder decodeSignedObject f dat
 #else
-  fromField = fmap SignedObject . blobFieldDecoder X.decodeSignedObject
+  fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
 #endif
 
 instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
-  toField (SignedObject s) = toField . Binary $ X.encodeSignedObject s
+  toField (SignedObject s) = toField . Binary $ encodeSignedObject s
 
 instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
-  smpEncode (SignedObject exact) = smpEncode . Large $ X.encodeSignedObject exact
-  smpP = fmap SignedObject . X.decodeSignedObject . unLarge <$?> smpP
+  smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
+  smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP
 
-encodeCertChain :: X.CertificateChain -> L.NonEmpty Large
+encodeCertChain :: CertificateChain -> L.NonEmpty Large
 encodeCertChain cc = L.fromList $ map Large blobs
   where
-    X.CertificateChainRaw blobs = X.encodeCertificateChain cc
+    CertificateChainRaw blobs = encodeCertificateChain cc
 
-certChainP :: A.Parser X.CertificateChain
+certChainP :: A.Parser CertificateChain
 certChainP = do
-  rawChain <- X.CertificateChainRaw . map unLarge . L.toList <$> smpP
-  either (fail . show) pure $ X.decodeCertificateChain rawChain
+  rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP
+  either (fail . show) pure $ decodeCertificateChain rawChain
 
 -- | Signature verification.
 --
@@ -1278,8 +1257,8 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
   _ -> False
 
 dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
-dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk) = DhSecretX25519 $ X25519.dh k pk
-dh' (PublicKeyX448 k) (PrivateKeyX448 pk) = DhSecretX448 $ X448.dh k pk
+dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
+dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 {-# INLINE dh' #-}
 
 -- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
@@ -1474,19 +1453,19 @@ xSalsa20 secret nonce msg = (rs, msg')
     (rs, state2) = XSalsa.generate state1 32
     (msg', _) = XSalsa.combine state2 msg
 
-publicToX509 :: PublicKey a -> X.PubKey
+publicToX509 :: PublicKey a -> PubKey
 publicToX509 = \case
-  PublicKeyEd25519 k -> X.PubKeyEd25519 k
-  PublicKeyEd448 k -> X.PubKeyEd448 k
-  PublicKeyX25519 k -> X.PubKeyX25519 k
-  PublicKeyX448 k -> X.PubKeyX448 k
+  PublicKeyEd25519 k -> PubKeyEd25519 k
+  PublicKeyEd448 k -> PubKeyEd448 k
+  PublicKeyX25519 k -> PubKeyX25519 k
+  PublicKeyX448 k -> PubKeyX448 k
 
-privateToX509 :: PrivateKey a -> X.PrivKey
+privateToX509 :: PrivateKey a -> PrivKey
 privateToX509 = \case
-  PrivateKeyEd25519 k -> X.PrivKeyEd25519 k
-  PrivateKeyEd448 k -> X.PrivKeyEd448 k
-  PrivateKeyX25519 k -> X.PrivKeyX25519 k
-  PrivateKeyX448 k -> X.PrivKeyX448 k
+  PrivateKeyEd25519 k _ -> PrivKeyEd25519 k
+  PrivateKeyEd448 k _ -> PrivKeyEd448 k
+  PrivateKeyX25519 k _ -> PrivKeyX25519 k
+  PrivateKeyX448 k _ -> PrivKeyX448 k
 
 encodeASNObj :: ASN1Object a => a -> ByteString
 encodeASNObj k = toStrict . encodeASN1 DER $ toASN1 k []
@@ -1499,30 +1478,22 @@ decodePubKey = decodeKey >=> x509ToPublic >=> pubKey
 decodePrivKey :: CryptoPrivateKey k => ByteString -> Either String k
 decodePrivKey = decodeKey >=> x509ToPrivate >=> privKey
 
-x509ToPublic :: (X.PubKey, [ASN1]) -> Either String APublicKey
+x509ToPublic :: (PubKey, [ASN1]) -> Either String APublicKey
 x509ToPublic = \case
-  (X.PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k
-  (X.PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k
-  (X.PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k
-  (X.PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k
+  (PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k
+  (PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k
+  (PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k
+  (PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k
   r -> keyError r
 
-x509ToPublic' :: CryptoPublicKey k => X.PubKey -> Either String k
-x509ToPublic' k = x509ToPublic (k, []) >>= pubKey
-{-# INLINE x509ToPublic' #-}
-
-x509ToPrivate :: (X.PrivKey, [ASN1]) -> Either String APrivateKey
+x509ToPrivate :: (PrivKey, [ASN1]) -> Either String APrivateKey
 x509ToPrivate = \case
-  (X.PrivKeyEd25519 k, []) -> Right $ APrivateKey SEd25519 $ PrivateKeyEd25519 k
-  (X.PrivKeyEd448 k, []) -> Right $ APrivateKey SEd448 $ PrivateKeyEd448 k
-  (X.PrivKeyX25519 k, []) -> Right $ APrivateKey SX25519 $ PrivateKeyX25519 k
-  (X.PrivKeyX448 k, []) -> Right $ APrivateKey SX448 $ PrivateKeyX448 k
+  (PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k
+  (PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k
+  (PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 . PrivateKeyX25519 k $ X25519.toPublic k
+  (PrivKeyX448 k, []) -> Right . APrivateKey SX448 . PrivateKeyX448 k $ X448.toPublic k
   r -> keyError r
 
-x509ToPrivate' :: CryptoPrivateKey k => X.PrivKey -> Either String k
-x509ToPrivate' pk = x509ToPrivate (pk, []) >>= privKey
-{-# INLINE x509ToPrivate' #-}
-
 decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1])
 decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict
 

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -55,10 +55,8 @@ module Simplex.Messaging.Crypto.Ratchet
     supportedE2EEncryptVRange,
     generateRcvE2EParams,
     generateSndE2EParams,
-    mkRcvE2ERatchetParams,
     initialPQEncryption,
     connPQEncryption,
-    joinContactInitialKeys,
     replyKEM_,
     pqSupportToEnc,
     pqEncToSupport,
@@ -197,8 +195,6 @@ 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)
@@ -312,7 +308,7 @@ instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri
             RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)]
   strP = toE2ERatchetParamsUri <$?> strP
   {-# INLINE strP #-}
-
+    
 toE2ERatchetParamsUri :: RatchetKEMStateI s => AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
 toE2ERatchetParamsUri = \case
   AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing
@@ -409,12 +405,6 @@ 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
@@ -861,39 +851,32 @@ instance StrEncoding PQSupport where
   strP = pqEncToSupport <$> strP
   {-# INLINE strP #-}
 
-data InitialKeys
-  = IKUsePQ -- use PQ keys in contact request and short link data
-  | IKLinkPQ PQSupport -- use PQ keys in short link data only, if PQSupport enabled
+data InitialKeys = IKUsePQ | IKNoPQ PQSupport
   deriving (Eq, Show)
 
 pattern IKPQOn :: InitialKeys
-pattern IKPQOn = IKLinkPQ PQSupportOn
+pattern IKPQOn = IKNoPQ PQSupportOn
 
 pattern IKPQOff :: InitialKeys
-pattern IKPQOff = IKLinkPQ PQSupportOff
+pattern IKPQOff = IKNoPQ PQSupportOff
 
 instance StrEncoding InitialKeys where
   strEncode = \case
     IKUsePQ -> "pq=invitation"
-    IKLinkPQ pq -> strEncode pq
-  strP = IKLinkPQ <$> strP <|> "pq=invitation" $> IKUsePQ
+    IKNoPQ pq -> strEncode pq
+  strP = IKNoPQ <$> strP <|> "pq=invitation" $> IKUsePQ
 
 -- determines whether PQ key should be included in invitation link
-initialPQEncryption :: Bool -> InitialKeys -> PQSupport
-initialPQEncryption shortLink = \case
+initialPQEncryption :: InitialKeys -> PQSupport
+initialPQEncryption = \case
   IKUsePQ -> PQSupportOn
-  IKLinkPQ (PQSupport enable) -> PQSupport $ enable && shortLink
+  IKNoPQ _ -> PQSupportOff -- default
 
 -- determines whether PQ encryption should be used in connection
 connPQEncryption :: InitialKeys -> PQSupport
 connPQEncryption = \case
   IKUsePQ -> PQSupportOn
-  IKLinkPQ pq -> pq -- default for creating connection is IKLinkPQ PQEncOn
-
-joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
-joinContactInitialKeys pqCompatible = \case
-  PQSupportOn | pqCompatible -> IKUsePQ
-  pqEnc -> IKLinkPQ pqEnc
+  IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn
 
 rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
 rcCheckCanPad paddedMsgLen msg =
@@ -1204,7 +1187,7 @@ instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = b
 
 instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField (BI pqEnc)
 
-instance FromField PQEncryption where
+instance FromField PQEncryption where 
 #if defined(dbPostgres)
   fromField f dat = PQEncryption . unBI <$> fromField f dat
 #else

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs

@@ -10,10 +10,11 @@ import Data.Bifunctor (bimap)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
+import Foreign (nullPtr)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
-import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (rngFuncPtr, withDRG)
+import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 
@@ -42,7 +43,7 @@ sntrup761Keypair drg =
       c_SNTRUP761_SECRETKEY_SIZE
       ( \skPtr ->
           BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr ->
-            withDRG drg $ \cxtPtr -> c_sntrup761_keypair pkPtr skPtr cxtPtr rngFuncPtr
+            withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr
       )
 
 sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
@@ -53,7 +54,7 @@ sntrup761Enc drg (KEMPublicKey pk) =
         c_SNTRUP761_SIZE
         ( \kPtr ->
             BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr ->
-              withDRG drg $ \cxtPtr -> c_sntrup761_enc cPtr kPtr pkPtr cxtPtr rngFuncPtr
+              withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr
         )
 
 sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs

@@ -1,6 +1,5 @@
 module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
   ( withDRG,
-    rngFuncPtr,
     RNGContext,
     RNGFunc,
   ) where
@@ -13,20 +12,19 @@ import Foreign
 import Foreign.C
 import qualified Simplex.Messaging.Crypto as C
 
-withDRG :: TVar ChaChaDRG -> (Ptr RNGContext -> IO a) -> IO a
-withDRG drg = bracket (castStablePtrToPtr <$> newStablePtr drg) (freeStablePtr . castPtrToStablePtr)
+withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a
+withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr
 
-rngFunc :: RNGFunc
-rngFunc cxt sz buf = do
-  drg <- deRefStablePtr $ castPtrToStablePtr cxt
-  bs <- atomically $ C.randomBytes (fromIntegral sz) drg
-  copyByteArrayToPtr bs buf
+createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc)
+createRNGFunc drg =
+  mkRNGFunc $ \_ctx sz buf -> do
+    bs <- atomically $ C.randomBytes (fromIntegral sz) drg
+    copyByteArrayToPtr bs buf
 
 type RNGContext = ()
 
 -- typedef void random_func (void *ctx, size_t length, uint8_t *dst);
 type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO ()
 
-foreign export ccall "haskell_rng_func" rngFunc :: RNGFunc
-
-foreign import ccall "&haskell_rng_func" rngFuncPtr :: FunPtr RNGFunc
+foreign import ccall "wrapper"
+  mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc)

src/Simplex/Messaging/Crypto/ShortLink.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -49,20 +48,20 @@ contactShortLinkKdf (LinkKey k) =
 invShortLinkKdf :: LinkKey -> C.SbKey
 invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
 
-encodeSignLinkData :: ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> UserConnLinkData c -> (LinkKey, (ByteString, ByteString))
+encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
 encodeSignLinkData (rootKey, pk) agentVRange connReq userData =
   let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq}
-      md = smpEncode $ connLinkData agentVRange userData
+      md = smpEncode $ connLinkData @c agentVRange userData
    in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md))
 
-encodeSignUserData :: ConnectionModeI c => SConnectionMode c -> C.PrivateKeyEd25519 -> VersionRangeSMPA -> UserConnLinkData c -> ByteString
-encodeSignUserData _ pk agentVRange userLinkData =
-  encodeSign pk $ smpEncode $ connLinkData agentVRange userLinkData
+encodeSignUserData :: C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString
+encodeSignUserData pk agentVRange userData =
+  encodeSign pk $ smpEncode $ connLinkData @'CMContact agentVRange userData
 
-connLinkData :: VersionRangeSMPA -> UserConnLinkData c -> ConnLinkData c
-connLinkData vr = \case
-  UserInvLinkData d -> InvitationLinkData vr d
-  UserContactLinkData d -> ContactLinkData vr d
+connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> ConnInfo -> ConnLinkData c
+connLinkData agentVRange userData = case sConnectionMode @c of
+  SCMInvitation -> InvitationLinkData agentVRange userData
+  SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData}
 
 encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString
 encodeSign pk s = smpEncode (C.sign' pk s) <> s

src/Simplex/Messaging/Encoding/String.hs

@@ -10,9 +10,6 @@ module Simplex.Messaging.Encoding.String
     strToJSON,
     strToJEncoding,
     strParseJSON,
-    textToJSON,
-    textToEncoding,
-    textParseJSON,
     base64urlP,
     strEncodeList,
     strListP,
@@ -42,11 +39,9 @@ import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
-import qualified Data.X509 as X
-import qualified Data.X509.Validation as XV
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
+import Simplex.Messaging.Util (bshow, (<$?>))
 
 class TextEncoding a where
   textEncode :: a -> Text
@@ -94,10 +89,6 @@ instance StrEncoding String where
   strEncode = strEncode . B.pack
   strP = B.unpack <$> strP
 
-instance StrEncoding Text where
-  strEncode = encodeUtf8
-  strP = safeDecodeUtf8 <$> A.takeTill (\c -> c == ' ' || c == '\n')
-
 instance ToJSON Str where
   toJSON (Str s) = strToJSON s
   toEncoding (Str s) = strToJEncoding s
@@ -155,18 +146,6 @@ instance StrEncoding UTCTime where
   strEncode = B.pack . iso8601Show
   strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n' || c == ',' || c == ';')
 
-instance StrEncoding X.CertificateChain where
-  strEncode = (\(X.CertificateChainRaw blobs) -> strEncodeList blobs) . X.encodeCertificateChain
-  {-# INLINE strEncode #-}
-  strP = either (fail . show) pure . X.decodeCertificateChain . X.CertificateChainRaw =<< strListP
-  {-# INLINE strP #-}
-
-instance StrEncoding XV.Fingerprint where
-  strEncode (XV.Fingerprint s) = strEncode s
-  {-# INLINE strEncode #-}
-  strP = XV.Fingerprint <$> strP
-  {-# INLINE strP #-}
-
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
 strEncodeList = B.intercalate "," . map strEncode
@@ -228,22 +207,9 @@ _strP = A.space *> strP
 
 strToJSON :: StrEncoding a => a -> J.Value
 strToJSON = J.String . decodeLatin1 . strEncode
-{-# INLINE strToJSON #-}
 
 strToJEncoding :: StrEncoding a => a -> J.Encoding
 strToJEncoding = JE.text . decodeLatin1 . strEncode
-{-# INLINE strToJEncoding #-}
 
 strParseJSON :: StrEncoding a => String -> J.Value -> JT.Parser a
 strParseJSON name = J.withText name $ either fail pure . parseAll strP . encodeUtf8
-
-textToJSON :: TextEncoding a => a -> J.Value
-textToJSON = J.String . textEncode
-{-# INLINE textToJSON #-}
-
-textToEncoding :: TextEncoding a => a -> J.Encoding
-textToEncoding = JE.text . textEncode
-{-# INLINE textToEncoding #-}
-
-textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
-textParseJSON name = J.withText name $ maybe (fail name) pure . textDecode

src/Simplex/Messaging/Notifications/Client.hs

@@ -14,7 +14,7 @@ import Data.Word (Word16)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, alpnSupportedNTFHandshakes)
+import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
 import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
@@ -24,45 +24,45 @@ type NtfClientError = ProtocolClientError ErrorType
 
 defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
 defaultNTFClientConfig =
-  (defaultClientConfig (Just alpnSupportedNTFHandshakes) False supportedClientNTFVRange)
+  (defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange)
     {defaultTransport = ("443", transport @TLS)}
 {-# INLINE defaultNTFClientConfig #-}
 
-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
+ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
+ntfRegisterToken c pKey newTkn =
+  sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE $ unexpectedResponse r
 
-ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
-ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId
+ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
+ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
 
-ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
-ntfCheckToken c nm pKey tknId =
-  sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case
+ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
+ntfCheckToken c pKey tknId =
+  sendNtfCommand c (Just pKey) tknId TCHK >>= \case
     NRTkn stat -> pure stat
     r -> throwE $ unexpectedResponse r
 
-ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
-ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
+ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
+ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
 
-ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
+ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
 
 -- set to 0 to disable
-ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
-ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm pKey tknId
+ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
+ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
 ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
 ntfCreateSubscription c pKey newSub =
-  sendNtfCommand c NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case
+  sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
     r -> throwE $ unexpectedResponse r
 
 ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
-ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs
+ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
   where
-    cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs
+    cs = L.map (\newSub -> (Just pKey, NoEntity, NtfCmd SSubscription $ SNEW newSub)) newSubs
     process (Response _ r) = case r of
       Right (NRSubId subId) -> Right subId
       Right r' -> Left $ unexpectedResponse r'
@@ -70,28 +70,28 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c
 
 ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
-  sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case
+  sendNtfCommand c (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 NRMBackground cs
+ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
   where
-    cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds
+    cs = L.map (\subId -> (Just pKey, subId, NtfCmd SSubscription SCHK)) subIds
     process (Response _ r) = case r of
       Right (NRSub stat) -> Right stat
       Right r' -> Left $ unexpectedResponse r'
       Left e -> Left e
 
 ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
-ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground
+ntfDeleteSubscription = okNtfCommand SDEL
 
 -- | Send notification server command
-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)
+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)
 
-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
+okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
+okNtfCommand cmd c pKey entId =
+  sendNtfCommand c (Just pKey) entId cmd >>= \case
     NROk -> return ()
     r -> throwE $ unexpectedResponse r

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -154,15 +154,10 @@ instance Protocol NTFVersion ErrorType NtfResponse where
   type ProtoCommand NtfResponse = NtfCmd
   type ProtoType NtfResponse = 'PNTF
   protocolClientHandshake c _ks = ntfClientHandshake c
-  {-# INLINE protocolClientHandshake #-}
-  useServiceAuth _ = False
-  {-# INLINE useServiceAuth #-}
   protocolPing = NtfCmd SSubscription PING
-  {-# INLINE protocolPing #-}
   protocolError = \case
     NRErr e -> Just e
     _ -> Nothing
-  {-# INLINE protocolError #-}
 
 data NtfCommand (e :: NtfEntity) where
   -- | register new device token for notifications
@@ -214,7 +209,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh
   fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials auth (EntityId entityId) cmd = case cmd of
+  checkCredentials (auth, _, EntityId entityId, _) cmd = case cmd of
     -- TNEW and SNEW must have signature but NOT token/subscription IDs
     TNEW {} -> sigNoEntity
     SNEW {} -> sigNoEntity
@@ -254,7 +249,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfCmd where
   fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials tAuth entId (NtfCmd e c) = NtfCmd e <$> checkCredentials tAuth entId c
+  checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
 
 data NtfResponseTag
   = NRTknId_
@@ -334,7 +329,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials _ (EntityId entId) cmd = case cmd of
+  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
     -- IDTKN response must not have queue ID
     NRTknId {} -> noEntity
     -- IDSUB response must not have queue ID
@@ -483,8 +478,6 @@ data NtfSubStatus
     NSDeleted
   | -- | SMP AUTH error
     NSAuth
-  | -- | SMP SERVICE error - rejected service signature on individual subscriptions
-    NSService
   | -- | SMP error other than AUTH
     NSErr ByteString
   deriving (Eq, Ord, Show)
@@ -498,7 +491,6 @@ ntfShouldSubscribe = \case
   NSEnd -> False
   NSDeleted -> False
   NSAuth -> False
-  NSService -> True
   NSErr _ -> False
 
 instance Encoding NtfSubStatus where
@@ -510,7 +502,6 @@ instance Encoding NtfSubStatus where
     NSEnd -> "END"
     NSDeleted -> "DELETED"
     NSAuth -> "AUTH"
-    NSService -> "SERVICE"
     NSErr err -> "ERR " <> err
   smpP =
     A.takeTill (== ' ') >>= \case
@@ -521,7 +512,6 @@ instance Encoding NtfSubStatus where
       "END" -> pure NSEnd
       "DELETED" -> pure NSDeleted
       "AUTH" -> pure NSAuth
-      "SERVICE" -> pure NSService
       "ERR" -> NSErr <$> (A.space *> A.takeByteString)
       _ -> fail "bad NtfSubStatus"
 

src/Simplex/Messaging/Notifications/Server.hs

@@ -32,11 +32,11 @@ import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
 import qualified Data.IntSet as IS
-import Data.List (foldl')
+import Data.List (foldl', intercalate)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (isJust, mapMaybe)
+import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -56,22 +56,22 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Prometheus
-import Simplex.Messaging.Notifications.Server.Push (PushNotification(..), PushProviderError(..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf)
 import Simplex.Messaging.Notifications.Server.Store.Postgres
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), NotifierId, Party (..), ProtocolServer (host), SMPServer, ServiceId, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGetServer, tPut)
+import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
+import Simplex.Messaging.Server.QueueStore (getSystemDate)
 import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats)
 import Simplex.Messaging.Session
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
-import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
 import Simplex.Messaging.Util
@@ -120,14 +120,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
     )
     `finally` stopServer
   where
-    runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
+    runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, _addHTTP) = do
       srvCreds <- asks tlsServerCreds
-      serverSignKey <- either fail pure $ C.x509ToPrivate' $ snd srvCreds
+      serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
       env <- ask
-      liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
+      liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
+    fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
-    runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
+    runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
     runClient signKey _ h = do
       kh <- asks serverIdentity
       ks <- atomically . C.generateKeyPair =<< asks random
@@ -187,31 +188,31 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
           ntfVrfInvalidTkn' <- atomicSwapIORef ntfVrfInvalidTkn 0
           tkn <- liftIO $ periodStatCounts activeTokens ts
           sub <- liftIO $ periodStatCounts activeSubs ts
-          T.hPutStrLn h $
-            T.intercalate
+          hPutStrLn h $
+            intercalate
               ","
-              [ T.pack $ iso8601Show $ utctDay fromTime',
-                tshow tknCreated',
-                tshow tknVerified',
-                tshow tknDeleted',
-                tshow subCreated',
-                tshow subDeleted',
-                tshow ntfReceived',
-                tshow ntfDelivered',
+              [ iso8601Show $ utctDay fromTime',
+                show tknCreated',
+                show tknVerified',
+                show tknDeleted',
+                show subCreated',
+                show subDeleted',
+                show ntfReceived',
+                show ntfDelivered',
                 dayCount tkn,
                 weekCount tkn,
                 monthCount tkn,
                 dayCount sub,
                 weekCount sub,
                 monthCount sub,
-                tshow tknReplaced',
-                tshow ntfFailed',
-                tshow ntfCronDelivered',
-                tshow ntfCronFailed',
-                tshow ntfVrfQueued',
-                tshow ntfVrfDelivered',
-                tshow ntfVrfFailed',
-                tshow ntfVrfInvalidTkn'
+                show tknReplaced',
+                show ntfFailed',
+                show ntfCronDelivered',
+                show ntfCronFailed',
+                show ntfVrfQueued',
+                show ntfVrfDelivered',
+                show ntfVrfFailed',
+                show ntfVrfInvalidTkn'
               ]
         liftIO $ threadDelay' interval
 
@@ -253,70 +254,42 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
 #endif
       let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber
           NtfPushServer {pushQ} = pushServer
-          SMPClientAgent {smpClients, smpSessions, smpSubWorkers} = a
+          SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
       srvSubscribers <- getSMPWorkerMetrics a smpSubscribers
       srvClients <- getSMPWorkerMetrics a smpClients
       srvSubWorkers <- getSMPWorkerMetrics a smpSubWorkers
-      ntfActiveServiceSubs <- getSMPServiceSubMetrics a activeServiceSubs $ snd . fst
-      ntfActiveQueueSubs <- getSMPSubMetrics a activeQueueSubs
-      ntfPendingServiceSubs <- getSMPServiceSubMetrics a pendingServiceSubs snd
-      ntfPendingQueueSubs <- getSMPSubMetrics a pendingQueueSubs
+      ntfActiveSubs <- getSMPSubMetrics a srvSubs
+      ntfPendingSubs <- getSMPSubMetrics a pendingSrvSubs
       smpSessionCount <- M.size <$> readTVarIO smpSessions
       apnsPushQLength <- atomically $ lengthTBQueue pushQ
-      pure
-        NtfRealTimeMetrics
-          { threadsCount,
-            srvSubscribers,
-            srvClients,
-            srvSubWorkers,
-            ntfActiveServiceSubs,
-            ntfActiveQueueSubs,
-            ntfPendingServiceSubs,
-            ntfPendingQueueSubs,
-            smpSessionCount,
-            apnsPushQLength
-          }
+      pure NtfRealTimeMetrics {threadsCount, srvSubscribers, srvClients, srvSubWorkers, ntfActiveSubs, ntfPendingSubs, smpSessionCount, apnsPushQLength}
       where
-        getSMPServiceSubMetrics :: forall sub. SMPClientAgent 'NotifierService -> (SMPClientAgent 'NotifierService -> TMap SMPServer (TVar (Maybe sub))) -> (sub -> Int64) -> IO NtfSMPSubMetrics
-        getSMPServiceSubMetrics a sel subQueueCount = getSubMetrics_ a sel countSubs
-          where
-            countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TVar (Maybe sub)) -> IO (NtfSMPSubMetrics, S.Set Text)
-            countSubs acc (srv, serviceSubs) = subMetricsResult a acc srv . fromIntegral . maybe 0 subQueueCount <$> readTVarIO serviceSubs
-
-        getSMPSubMetrics :: SMPClientAgent 'NotifierService -> (SMPClientAgent 'NotifierService -> TMap SMPServer (TMap NotifierId a)) -> IO NtfSMPSubMetrics
-        getSMPSubMetrics a sel = getSubMetrics_ a sel countSubs
-          where
-            countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TMap NotifierId a) -> IO (NtfSMPSubMetrics, S.Set Text)
-            countSubs acc (srv, queueSubs) = subMetricsResult a acc srv . M.size <$> readTVarIO queueSubs
-
-        getSubMetrics_ ::
-          SMPClientAgent 'NotifierService ->
-          (SMPClientAgent 'NotifierService -> TVar (M.Map SMPServer sub')) ->
-          ((NtfSMPSubMetrics, S.Set Text) -> (SMPServer, sub') -> IO (NtfSMPSubMetrics, S.Set Text)) ->
-          IO NtfSMPSubMetrics
-        getSubMetrics_ a sel countSubs = do
-          subs <- readTVarIO $ sel a
+        getSMPSubMetrics :: SMPClientAgent -> TMap SMPServer (TMap SMPSub a) -> IO NtfSMPSubMetrics
+        getSMPSubMetrics a v = do
+          subs <- readTVarIO v
           let metrics = NtfSMPSubMetrics {ownSrvSubs = M.empty, otherServers = 0, otherSrvSubCount = 0}
           (metrics', otherSrvs) <- foldM countSubs (metrics, S.empty) $ M.assocs subs
           pure (metrics' :: NtfSMPSubMetrics) {otherServers = S.size otherSrvs}
-
-        subMetricsResult :: SMPClientAgent 'NotifierService -> (NtfSMPSubMetrics, S.Set Text) -> SMPServer -> Int -> (NtfSMPSubMetrics, S.Set Text)
-        subMetricsResult a acc@(metrics, !otherSrvs) srv@(SMPServer (h :| _) _ _) cnt
-          | isOwnServer a srv =
-              let !ownSrvSubs' = M.alter (Just . maybe cnt (+ cnt)) host ownSrvSubs
-                  metrics' = metrics {ownSrvSubs = ownSrvSubs'} :: NtfSMPSubMetrics
-               in (metrics', otherSrvs)
-          | cnt == 0 = acc
-          | otherwise =
-              let metrics' = metrics {otherSrvSubCount = otherSrvSubCount + cnt} :: NtfSMPSubMetrics
-               in (metrics', S.insert host otherSrvs)
           where
-            NtfSMPSubMetrics {ownSrvSubs, otherSrvSubCount} = metrics
-            host = safeDecodeUtf8 $ strEncode h
+            countSubs :: (NtfSMPSubMetrics, S.Set Text) -> (SMPServer, TMap SMPSub a) -> IO (NtfSMPSubMetrics, S.Set Text)
+            countSubs acc@(metrics, !otherSrvs) (srv@(SMPServer (h :| _) _ _), srvSubs) =
+              result . M.size <$> readTVarIO srvSubs
+              where
+                result cnt
+                  | isOwnServer a srv =
+                      let !ownSrvSubs' = M.alter (Just . maybe cnt (+ cnt)) host ownSrvSubs
+                          metrics' = metrics {ownSrvSubs = ownSrvSubs'} :: NtfSMPSubMetrics
+                       in (metrics', otherSrvs)
+                  | cnt == 0 = acc
+                  | otherwise =
+                      let metrics' = metrics {otherSrvSubCount = otherSrvSubCount + cnt} :: NtfSMPSubMetrics
+                       in (metrics', S.insert host otherSrvs)
+                NtfSMPSubMetrics {ownSrvSubs, otherSrvSubCount} = metrics
+                host = safeDecodeUtf8 $ strEncode h
 
-        getSMPWorkerMetrics :: SMPClientAgent 'NotifierService -> TMap SMPServer a -> IO NtfSMPWorkerMetrics
+        getSMPWorkerMetrics :: SMPClientAgent -> TMap SMPServer a -> IO NtfSMPWorkerMetrics
         getSMPWorkerMetrics a v = workerMetrics a . M.keys <$> readTVarIO v
-        workerMetrics :: SMPClientAgent 'NotifierService -> [SMPServer] -> NtfSMPWorkerMetrics
+        workerMetrics :: SMPClientAgent -> [SMPServer] -> NtfSMPWorkerMetrics
         workerMetrics a srvs = NtfSMPWorkerMetrics {ownServers = reverse ownSrvs, otherServers}
           where
             (ownSrvs, otherServers) = foldl' countSrv ([], 0) srvs
@@ -364,9 +337,12 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> controlPortAuth h user admin role auth
+              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
                 where
-                  NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
+                  newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
+                    | Just auth == admin = CPRAdmin
+                    | Just auth == user = CPRUser
+                    | otherwise = CPRNone
               CPStats -> withUserRole $ do
                 ss <- unliftIO u $ asks serverStats
                 let getStat :: (NtfServerStats -> IORef a) -> IO a
@@ -397,21 +373,20 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
                   logError "Unauthorized control port command"
                   hPutStrLn h "AUTH"
                 r -> do
-                  rtm <- getNtfRealTimeMetrics =<< unliftIO u ask
+                  NtfRealTimeMetrics {threadsCount, srvSubscribers, srvClients, srvSubWorkers, ntfActiveSubs, ntfPendingSubs, smpSessionCount, apnsPushQLength} <-
+                    getNtfRealTimeMetrics =<< unliftIO u ask
 #if MIN_VERSION_base(4,18,0)
-                  hPutStrLn h $ "Threads: " <> show (threadsCount rtm)
+                  hPutStrLn h $ "Threads: " <> show threadsCount
 #else
                   hPutStrLn h "Threads: not available on GHC 8.10"
 #endif
-                  putSMPWorkers "SMP subcscribers" $ srvSubscribers rtm
-                  putSMPWorkers "SMP clients" $ srvClients rtm
-                  putSMPWorkers "SMP subscription workers" $ srvSubWorkers rtm
-                  hPutStrLn h $ "SMP sessions count: " <> show (smpSessionCount rtm)
-                  putSMPSubs "SMP service subscriptions" $ ntfActiveServiceSubs rtm
-                  putSMPSubs "SMP queue subscriptions" $ ntfActiveQueueSubs rtm
-                  putSMPSubs "Pending SMP service subscriptions" $ ntfPendingServiceSubs rtm
-                  putSMPSubs "Pending SMP queue subscriptions" $ ntfPendingQueueSubs rtm
-                  hPutStrLn h $ "Push notifications queue length: " <> show (apnsPushQLength rtm)
+                  putSMPWorkers "SMP subcscribers" srvSubscribers
+                  putSMPWorkers "SMP clients" srvClients
+                  putSMPWorkers "SMP subscription workers" srvSubWorkers
+                  hPutStrLn h $ "SMP sessions count: " <> show smpSessionCount
+                  putSMPSubs "SMP subscriptions" ntfActiveSubs
+                  putSMPSubs "Pending SMP subscriptions" ntfPendingSubs
+                  hPutStrLn h $ "Push notifications queue length: " <> show apnsPushQLength
                   where
                     putSMPSubs :: Text -> NtfSMPSubMetrics -> IO ()
                     putSMPSubs name NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} = do
@@ -449,39 +424,35 @@ resubscribe NtfSubscriber {smpAgent = ca} = do
   liftIO $ do
     srvs <- getUsedSMPServers st
     logNote $ "Starting SMP resubscriptions for " <> tshow (length srvs) <> " servers..."
-    counts <- mapConcurrently (subscribeSrvSubs ca st batchSize) srvs
+    counts <- mapConcurrently (subscribeSrvSubs st batchSize) srvs
     logNote $ "Completed all SMP resubscriptions for " <> tshow (length srvs) <> " servers (" <> tshow (sum counts) <> " subscriptions)"
-
-subscribeSrvSubs :: SMPClientAgent 'NotifierService -> NtfPostgresStore -> Int -> (SMPServer, Int64, Maybe (ServiceId, Int64)) -> IO Int
-subscribeSrvSubs ca st batchSize (srv, srvId, service_) = do
-  let srvStr = safeDecodeUtf8 (strEncode $ L.head $ host srv)
-  logNote $ "Starting SMP resubscriptions for " <> srvStr
-  forM_ service_ $ \(serviceId, n) -> do
-    logNote $ "Subscribing service to " <> srvStr <> " with " <> tshow n <> " associated queues"
-    subscribeServiceNtfs ca srv (serviceId, n)
-  n <- subscribeLoop 0 Nothing
-  logNote $ "Completed SMP resubscriptions for " <> srvStr <> " (" <> tshow n <> " subscriptions)"
-  pure n
   where
-    dbBatchSize = batchSize * 100
-    subscribeLoop n afterSubId_ =
-      getServerNtfSubscriptions st srvId afterSubId_ dbBatchSize >>= \case
-        Left _ -> exitFailure
-        Right [] -> pure n
-        Right subs -> do
-          mapM_ (subscribeQueuesNtfs ca srv . L.map snd) $ toChunks batchSize subs
-          let len = length subs
-              n' = n + len
-              afterSubId_' = Just $ fst $ last subs
-          if len < dbBatchSize then pure n' else subscribeLoop n' afterSubId_'
+    subscribeSrvSubs st batchSize srv = do
+      let srvStr = safeDecodeUtf8 (strEncode $ L.head $ host srv)
+      logNote $ "Starting SMP resubscriptions for " <> srvStr
+      n <- loop 0 Nothing
+      logNote $ "Completed SMP resubscriptions for " <> srvStr <> " (" <> tshow n <> " subscriptions)"
+      pure n
+      where
+        dbBatchSize = batchSize * 100
+        loop n afterSubId_ =
+          getServerNtfSubscriptions st srv afterSubId_ dbBatchSize >>= \case
+            Left _ -> exitFailure
+            Right [] -> pure n
+            Right subs -> do
+              mapM_ (subscribeQueuesNtfs ca srv . L.map snd) $ toChunks batchSize subs
+              let len = length subs
+                  n' = n + len
+                  afterSubId_' = Just $ fst $ last subs
+              if len < dbBatchSize then pure n' else loop n' afterSubId_'
 
 -- 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 -> Int64 -> ServerNtfSub -> IO ()
-subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer srvId ntfSub =
+subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> NonEmpty ServerNtfSub -> IO ()
+subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer ntfSubs =
   getSubscriberVar
     >>= either createSMPSubscriber waitForSMPSubscriber
-    >>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSub)
+    >>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSubs)
   where
     getSubscriberVar :: IO (Either SMPSubscriberVar SMPSubscriberVar)
     getSubscriberVar = atomically . getSessVar subscriberSeq smpServer smpSubscribers =<< getCurrentTime
@@ -490,8 +461,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 smpServer srvId q)
-        let sub = SMPSubscriber {smpServer, smpServerId = srvId, subscriberSubQ = q, subThreadId = tId}
+        tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber q)
+        let sub = SMPSubscriber {smpServer, subscriberSubQ = q, subThreadId = tId}
         atomically $ putTMVar (sessionVar v) sub -- this makes it available for other threads
         pure $ Just sub
 
@@ -507,13 +478,14 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
       atomically $ removeSessVar v smpServer smpSubscribers
       pure Nothing
 
-    runSMPSubscriber :: SMPServer -> Int64 -> TQueue ServerNtfSub -> IO ()
-    runSMPSubscriber smpServer' srvId' q = forever $ do
+    runSMPSubscriber :: TQueue (NonEmpty ServerNtfSub) -> IO ()
+    runSMPSubscriber 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 srvId' nId NSPending
-      subscribeQueuesNtfs ca smpServer' [sub]
+      subs <- atomically $ readTQueue q
+      updated <- batchUpdateSubStatus st subs NSPending
+      logSubStatus smpServer "subscribing" (L.length subs) updated
+      subscribeQueuesNtfs ca smpServer $ L.map snd subs
 
 ntfSubscriber :: NtfSubscriber -> M ()
 ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
@@ -524,7 +496,7 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
       NtfPushServer {pushQ} <- asks pushServer
       stats <- asks serverStats
       liftIO $ forever $ do
-        ((_, srv@(SMPServer (h :| _) _ _), _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
+        ((_, srv, _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
         forM ts $ \(ntfId, t) -> case t of
           STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen
           STResponse {} -> pure () -- it was already reported as timeout error
@@ -535,16 +507,9 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
                 ntfTs <- getSystemTime
                 updatePeriodStats (activeSubs stats) ntfId
                 let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
-                    srvHost_ = if isOwnServer ca srv then Just (safeDecodeUtf8 $ strEncode h) else Nothing
-                addTokenLastNtf st newNtf >>= \case
-                  Right (tkn, lastNtfs) -> do
-                    atomically $ writeTBQueue pushQ (srvHost_, tkn, PNMessage lastNtfs)
-                    incNtfStat_ stats ntfReceived
-                    mapM_ (`incServerStat` ntfReceivedOwn stats) srvHost_
-                  Left AUTH -> do
-                    incNtfStat_ stats ntfReceivedAuth
-                    mapM_ (`incServerStat` ntfReceivedAuthOwn stats) srvHost_
-                  Left _ -> pure ()
+                ntfs_ <- addTokenLastNtf st newNtf
+                forM_ ntfs_ $ \(tkn, lastNtfs) -> atomically $ writeTBQueue pushQ (tkn, PNMessage lastNtfs)
+                incNtfStat_ stats ntfReceived
               Right SMP.END ->
                 whenM (atomically $ activeClientSession' ca sessionId srv) $
                   void $ updateSrvSubStatus st smpQueue NSEnd
@@ -556,71 +521,44 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
 
     receiveAgent = do
       st <- asks store
-      batchSize <- asks $ subsBatchSize . config
       liftIO $ forever $
         atomically (readTBQueue agentQ) >>= \case
-          CAConnected srv serviceId -> do
-            let asService = if isJust serviceId then "as service " else ""
-            logInfo $ "SMP server reconnected " <> asService <> showServer' srv
-          CADisconnected srv nIds -> do
-            updated <- batchUpdateSrvSubStatus st srv Nothing nIds NSInactive
-            logSubStatus srv "disconnected" (L.length nIds) updated
-          CASubscribed srv serviceId nIds -> do
-            updated <- batchUpdateSrvSubStatus st srv serviceId nIds NSActive
-            let asService = if isJust serviceId then " as service" else ""
-            logSubStatus srv ("subscribed" <> asService) (L.length nIds) updated
-          CASubError srv errs -> do
-            forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> queueSubErrorStatus err) $ L.toList errs) $ \subStatuses -> do
-              updated <- batchUpdateSrvSubErrors st srv subStatuses
+          CAConnected srv ->
+            logInfo $ "SMP server reconnected " <> showServer' srv
+          CADisconnected srv subs -> do
+            forM_ (L.nonEmpty $ map snd $ S.toList subs) $ \nIds -> do
+              updated <- batchUpdateSrvSubStatus st srv nIds NSInactive
+              logSubStatus srv "disconnected" (L.length nIds) updated
+          CASubscribed srv _ nIds -> do
+            updated <- batchUpdateSrvSubStatus st srv nIds NSActive
+            logSubStatus srv "subscribed" (L.length nIds) updated
+          CASubError srv _ errs -> do
+            forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> subErrorStatus err) $ L.toList errs) $ \subStatuses -> do
+              updated <- batchUpdateSrvSubStatuses st srv subStatuses
               logSubErrors srv subStatuses updated
-              -- TODO [certs] resubscribe queues with statuses NSErr and NSService
-          CAServiceDisconnected srv serviceSub ->
-            logNote $ "SMP server service disconnected " <> showService srv serviceSub
-          CAServiceSubscribed srv serviceSub@(_, expected) n
-            | expected == n -> logNote msg
-            | otherwise -> logWarn $ msg <> ", confirmed subs: " <> tshow n
-            where
-              msg = "SMP server service subscribed " <> showService srv serviceSub
-          CAServiceSubError srv serviceSub e ->
-            -- Errors that require re-subscribing queues directly are reported as CAServiceUnavailable.
-            -- See smpSubscribeService in Simplex.Messaging.Client.Agent
-            logError $ "SMP server service subscription error " <> showService srv serviceSub <> ": " <> tshow e
-          CAServiceUnavailable srv serviceSub -> do
-            logError $ "SMP server service unavailable: " <> showService srv serviceSub
-            removeServiceAssociation st srv >>= \case
-              Right (srvId, updated) -> do
-                logSubStatus srv "removed service association" updated updated
-                void $ subscribeSrvSubs ca st batchSize (srv, srvId, Nothing)
-              Left e -> logError $ "SMP server update and resubscription error " <> tshow e
-      where
-        showService srv (serviceId, n) = showServer' srv  <> ", service ID " <> decodeLatin1 (strEncode serviceId) <> ", " <> tshow n <> " subs"
 
-    logSubErrors :: SMPServer -> NonEmpty (SMP.NotifierId, NtfSubStatus) -> Int -> IO ()
+    logSubErrors :: SMPServer -> NonEmpty (SMP.NotifierId, NtfSubStatus) -> Int64 -> IO ()
     logSubErrors srv subs updated = forM_ (L.group $ L.sort $ L.map snd subs) $ \ss -> do
       logError $ "SMP server subscription errors " <> showServer' srv <> ": " <> tshow (L.head ss) <> " (" <> tshow (length ss) <> " errors, " <> tshow updated <> " subs updated)"
 
-    queueSubErrorStatus :: SMPClientError -> Maybe NtfSubStatus
-    queueSubErrorStatus = \case
+    subErrorStatus :: SMPClientError -> Maybe NtfSubStatus
+    subErrorStatus = \case
       PCEProtocolError AUTH -> Just NSAuth
-      -- TODO [certs] we could allow making individual subscriptions within service session to handle SERVICE error.
-      -- This would require full stack changes in SMP server, SMP client and SMP service agent.
-      PCEProtocolError SERVICE -> Just NSService
       PCEProtocolError e -> updateErr "SMP error " e
       PCEResponseError e -> updateErr "ResponseError " e
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
       PCECryptoError e -> updateErr "CryptoError " e
       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
         updateErr :: Show e => ByteString -> e -> Maybe NtfSubStatus
         updateErr errType e = Just $ NSErr $ errType <> bshow e
 
-logSubStatus :: SMPServer -> T.Text -> Int -> Int -> IO ()
+logSubStatus :: SMPServer -> T.Text -> Int -> Int64 -> IO ()
 logSubStatus srv event n updated =
   logInfo $ "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subs, " <> tshow updated <> " subs updated)"
 
@@ -629,7 +567,7 @@ showServer' = decodeLatin1 . strEncode . host
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
   liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   st <- asks store
   case ntf of
@@ -648,14 +586,8 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
     PNMessage {} -> checkActiveTkn tknStatus $ do
       stats <- asks serverStats
       liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
-        Left _ -> do
-          incNtfStatT t ntfFailed
-          liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
-        Right () -> do
-          incNtfStatT t ntfDelivered
-          liftIO $ mapM_ (`incServerStat` ntfDeliveredOwn stats) srvHost_
-
+      liftIO (deliverNotification st pp tkn ntf)
+        >>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered)
   where
     checkActiveTkn :: NtfTknStatus -> M () -> M ()
     checkActiveTkn status action
@@ -696,7 +628,7 @@ periodicNtfsThread NtfPushServer {pushQ} = do
   liftIO $ forever $ do
     threadDelay interval
     now <- systemSeconds <$> getSystemTime
-    cnt <- withPeriodicNtfTokens st now $ \tkn -> atomically $ writeTBQueue pushQ (Nothing, tkn, PNCheckMessages)
+    cnt <- withPeriodicNtfTokens st now $ \tkn -> atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
     logNote $ "Scheduled periodic notifications: " <> tshow cnt
 
 runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
@@ -719,24 +651,25 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
 
 receive :: Transport c => NtfPostgresStore -> THandleNTF c 'TServer -> NtfServerClient -> IO ()
 receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
-  ts <- L.toList <$> tGetServer th
+  ts <- L.toList <$> tGet th
   atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
   (errs, cmds) <- partitionEithers <$> mapM cmdAction ts
   write sndQ errs
   write rcvQ cmds
   where
-    cmdAction = \case
-      Left (corrId, entId, e) -> do
-        logError $ "invalid client request: " <> tshow e
-        pure $ Left (corrId, entId, NRErr e)
-      Right t@(_, _, (corrId, entId, _)) ->
-        verified =<< verifyNtfTransmission st thAuth t
-        where
-          verified = \case
-            VRVerified req -> pure $ Right req
-            VRFailed e -> do
-              logError "unauthorized client request"
-              pure $ Left (corrId, entId, NRErr e)
+    cmdAction t@(_, _, (corrId, entId, cmdOrError)) =
+      case cmdOrError of
+        Left e -> do
+          logError $ "invalid client request: " <> tshow e
+          pure $ Left (corrId, entId, NRErr e)
+        Right cmd ->
+          verified =<< verifyNtfTransmission st ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd
+          where
+            verified = \case
+              VRVerified req -> pure $ Right req
+              VRFailed e -> do
+                logError "unauthorized client request"
+                pure $ Left (corrId, entId, NRErr e)
     write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
 send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
@@ -747,10 +680,10 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
 
 data VerificationResult = VRVerified NtfRequest | VRFailed ErrorType
 
-verifyNtfTransmission :: NtfPostgresStore -> Maybe (THandleAuth 'TServer) -> SignedTransmission NtfCmd -> IO VerificationResult
-verifyNtfTransmission st thAuth (tAuth, authorized, (corrId, entId, cmd)) = case cmd of
+verifyNtfTransmission :: NtfPostgresStore -> Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> IO VerificationResult
+verifyNtfTransmission st auth_ (tAuth, authorized, (corrId, entId, _)) = \case
   NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _))
-    | verifyCmdAuthorization thAuth tAuth authorized corrId k ->
+    | verifyCmdAuthorization auth_ tAuth authorized k ->
         result <$> findNtfTokenRegistration st tkn
     | otherwise -> pure $ VRFailed AUTH
     where
@@ -779,10 +712,10 @@ verifyNtfTransmission st thAuth (tAuth, authorized, (corrId, entId, cmd)) = case
     subCmd s c = NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)
     verifyToken :: NtfTknRec -> NtfRequest -> VerificationResult
     verifyToken NtfTknRec {tknVerifyKey} r
-      | verifyCmdAuthorization thAuth tAuth authorized corrId tknVerifyKey = VRVerified r
+      | verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey = VRVerified r
       | otherwise = VRFailed AUTH
     err = \case -- signature verification for AUTH errors mitigates timing attacks for existence checks
-      AUTH -> dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH
+      AUTH -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed AUTH
       e -> VRFailed e
 
 client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
@@ -803,7 +736,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
         ts <- liftIO $ getSystemDate
         let tkn = mkNtfTknRec tknId newTkn srvDhPrivKey dhSecret regCode ts
         withNtfStore (`addNtfToken` tkn) $ \_ -> do
-          atomically $ writeTBQueue pushQ (Nothing, tkn, PNVerification regCode)
+          atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
           incNtfStatT token ntfVrfQueued
           incNtfStatT token tknCreated
           pure $ NRTknId tknId srvDhPubKey
@@ -819,7 +752,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
               | otherwise -> withNtfStore (\st -> updateTknStatus st tkn NTRegistered) $ \_ -> sendVerification
             where
               sendVerification = do
-                atomically $ writeTBQueue pushQ (Nothing, tkn, PNVerification tknRegCode)
+                atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
                 incNtfStatT token ntfVrfQueued
                 pure $ NRTknId ntfTknId $ C.publicKey tknDhPrivKey
           TVFY code -- this allows repeated verification for cases when client connection dropped before server response
@@ -837,7 +770,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
             regCode <- getRegCode
             let tkn' = tkn {token = token', tknStatus = NTRegistered, tknRegCode = regCode}
             withNtfStore (`replaceNtfToken` tkn') $ \_ -> do
-              atomically $ writeTBQueue pushQ (Nothing, tkn', PNVerification regCode)
+              atomically $ writeTBQueue pushQ (tkn', PNVerification regCode)
               incNtfStatT token ntfVrfQueued
               incNtfStatT token tknReplaced
               pure NROk
@@ -845,8 +778,8 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
             logDebug "TDEL"
             withNtfStore (`deleteNtfToken` tknId) $ \ss -> do
               forM_ ss $ \(smpServer, nIds) -> do
-                atomically $ removeActiveSubs ca smpServer nIds
-                atomically $ removePendingSubs ca smpServer nIds
+                atomically $ removeSubscriptions ca smpServer SPNotifier nIds
+                atomically $ removePendingSubs ca smpServer SPNotifier nIds
               incNtfStatT token tknDeleted
               pure NROk
           TCRN 0 -> do
@@ -863,12 +796,12 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
         let sub = mkNtfSubRec subId newSub
         resp <-
           withNtfStore (`addNtfSubscription` sub) $ \case
-            (srvId, True) -> do
+            True -> do
               st <- asks store
-              liftIO $ subscribeNtfs ns st srv srvId (subId, (nId, nKey))
+              liftIO $ subscribeNtfs ns st srv [(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
@@ -884,8 +817,8 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
           SDEL -> do
             logDebug "SDEL"
             withNtfStore (`deleteNtfSubscription` subId) $ \_ -> do
-              atomically $ removeActiveSub ca smpServer notifierId
-              atomically $ removePendingSub ca smpServer notifierId
+              atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
+              atomically $ removePendingSub ca smpServer (SPNotifier, notifierId)
               incNtfStat subDeleted
               pure NROk
           PING -> pure NRPong

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

@@ -17,11 +17,10 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
-import qualified Data.X509.Validation as XV
+import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as TLS
 import Numeric.Natural
-import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
@@ -32,7 +31,7 @@ import Simplex.Messaging.Notifications.Server.Store.Postgres
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
 import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
-import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), Transmission)
+import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
@@ -40,15 +39,14 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog)
 import Simplex.Messaging.Session
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), ServiceCredentials (..), THandleParams, TransportPeer (..))
+import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
-import Simplex.Messaging.Notifications.Server.Push (PushNotification, PushProviderClient)
 
 data NtfServerConfig = NtfServerConfig
-  { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
+  { transports :: [(ServiceName, ATransport, AddHTTP)],
     controlPort :: Maybe ServiceName,
     controlPortUserAuth :: Maybe BasicAuth,
     controlPortAdminAuth :: Maybe BasicAuth,
@@ -62,8 +60,6 @@ data NtfServerConfig = NtfServerConfig
     inactiveClientExpiration :: Maybe ExpirationConfig,
     dbStoreConfig :: PostgresStoreCfg,
     ntfCredentials :: ServerCredentials,
-    -- send service credentials and use service subscriptions when SMP server supports them
-    useServiceCreds :: Bool,
     periodicNtfsInterval :: Int, -- seconds
     -- stats config - see SMP server config
     logStatsInterval :: Maybe Int64,
@@ -97,23 +93,14 @@ data NtfEnv = NtfEnv
   }
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
+newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, startOptions} = do
   when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
   random <- C.newRandom
   store <- newNtfDbStore dbStoreConfig
-  tlsServerCreds <- loadServerCredential ntfCredentials
-  serviceCertHash@(XV.Fingerprint fp) <- loadFingerprint ntfCredentials
-  smpAgentCfg' <-
-    if useServiceCreds
-      then do
-        serviceSignKey <- case C.x509ToPrivate' $ snd tlsServerCreds of
-          Right pk -> pure pk
-          Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
-        let service = ServiceCredentials {serviceRole = SRNotifier, serviceCreds = tlsServerCreds, serviceCertHash, serviceSignKey}
-        pure smpAgentCfg {smpCfg = (smpCfg smpAgentCfg) {serviceCredentials = Just service}}
-      else pure smpAgentCfg
-  subscriber <- newNtfSubscriber smpAgentCfg' random
+  subscriber <- newNtfSubscriber smpAgentCfg random
   pushServer <- newNtfPushServer pushQSize apnsConfig
+  tlsServerCreds <- loadServerCredential ntfCredentials
+  Fingerprint fp <- loadFingerprint ntfCredentials
   serverStats <- newNtfServerStats =<< getCurrentTime
   pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
   where
@@ -128,7 +115,7 @@ newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbSt
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriberVar,
     subscriberSeq :: TVar Int,
-    smpAgent :: SMPClientAgent 'NotifierService
+    smpAgent :: SMPClientAgent
   }
 
 type SMPSubscriberVar = SessionVar SMPSubscriber
@@ -137,18 +124,17 @@ newNtfSubscriber :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
 newNtfSubscriber smpAgentCfg random = do
   smpSubscribers <- TM.emptyIO
   subscriberSeq <- newTVarIO 0
-  smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg random
+  smpAgent <- newSMPClientAgent smpAgentCfg random
   pure NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent}
 
 data SMPSubscriber = SMPSubscriber
   { smpServer :: SMPServer,
-    smpServerId :: Int64,
-    subscriberSubQ :: TQueue ServerNtfSub,
+    subscriberSubQ :: TQueue (NonEmpty ServerNtfSub),
     subThreadId :: Weak ThreadId
   }
 
 data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
+  { pushQ :: TBQueue (NtfTknRec, PushNotification),
     pushClients :: TMap PushProvider PushProviderClient,
     apnsConfig :: APNSPushClientConfig
   }

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

@@ -27,7 +27,7 @@ import Options.Applicative
 import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
 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)
+import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
@@ -37,7 +37,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientCo
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
-import Simplex.Messaging.Notifications.Transport (alpnSupportedNTFHandshakes, supportedServerNTFVRange)
+import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
@@ -46,10 +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)
+import Simplex.Messaging.Transport (ATransport, simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Transport.HTTP2 (httpALPN)
-import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig)
+import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
 import System.Exit (exitFailure)
@@ -100,9 +99,9 @@ ntfServerCLI cfgPath logPath =
               restoreServerLastNtfs stmStore defaultLastNtfsFile
               let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
               ps <- newNtfDbStore storeCfg
-              (tCnt, sCnt, nCnt, serviceCnt) <- importNtfSTMStore ps stmStore skipTokens
+              (tCnt, sCnt, nCnt) <- importNtfSTMStore ps stmStore skipTokens
               renameFile storeLogFile $ storeLogFile <> ".bak"
-              putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show serviceCnt <> " service associations, " <> show nCnt <> " last token notifications."
+              putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications."
               putStrLn "Configure database options in INI file."
         SCExport
           | schemaExists && storeLogExists -> exitConfigureNtfStore connstr schema
@@ -137,7 +136,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" <> simplexmqVersionCommit
+    serverVersion = "SMP notifications server v" <> simplexMQVersion
     defaultServerPort = "443"
     executableName = "ntf-server"
     storeLogFilePath = combine logPath "ntf-server-store.log"
@@ -168,9 +167,6 @@ 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\
@@ -199,8 +195,6 @@ ntfServerCLI cfgPath logPath =
                \# socks_mode: onion\n\n\
                \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
                \# own_server_domains: \n\n\
-               \# User service subscriptions with server certificate\n\n\
-               \# use_service_credentials: off\n\n\
                \[INACTIVE_CLIENTS]\n\
                \# TTL and interval to check inactive clients\n\
                \disconnect: off\n"
@@ -250,7 +244,6 @@ ntfServerCLI cfgPath logPath =
                                 socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
                                 hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
                                 requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
-                                smpWebPortServers = SWPOff,
                                 smpPingInterval = 60_000_000 -- 1 minute
                               }
                         },
@@ -272,7 +265,6 @@ ntfServerCLI cfgPath logPath =
                     privateKeyFile = c serverKeyFile,
                     certificateFile = c serverCrtFile
                   },
-              useServiceCreds = fromMaybe False $ iniOnOff "SUBSCRIBER" "use_service_credentials" ini,
               periodicNtfsInterval = 5 * 60, -- 5 minutes
               logStatsInterval = logStats $> 86400, -- seconds
               logStatsStartTime = 0, -- seconds from 00:00 UTC
@@ -282,10 +274,9 @@ ntfServerCLI cfgPath logPath =
               prometheusMetricsFile = combine logPath "ntf-server-metrics.txt",
               ntfServerVRange = supportedServerNTFVRange,
               transportConfig =
-                mkTransportServerConfig
-                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just $ alpnSupportedNTFHandshakes <> httpALPN)
-                  False,
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  },
               startOptions
             }
     iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
@@ -295,7 +286,7 @@ ntfServerCLI cfgPath logPath =
       putStrLn "Configure notification server storage."
       exitFailure
 
-printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
+printNtfServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
 printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
   B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
   printServerConfig "NTF" transports dbStoreLogPath

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

@@ -17,7 +17,6 @@ import Numeric.Natural (Natural)
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
 import Simplex.Messaging.Transport (simplexMQVersion)
-import Simplex.Messaging.Util (tshow)
 
 data NtfServerMetrics = NtfServerMetrics
   { statsData :: NtfServerStatsData,
@@ -37,10 +36,8 @@ data NtfRealTimeMetrics = NtfRealTimeMetrics
     srvSubscribers :: NtfSMPWorkerMetrics,
     srvClients :: NtfSMPWorkerMetrics,
     srvSubWorkers :: NtfSMPWorkerMetrics,
-    ntfActiveServiceSubs :: NtfSMPSubMetrics,
-    ntfActiveQueueSubs :: NtfSMPSubMetrics,
-    ntfPendingServiceSubs :: NtfSMPSubMetrics,
-    ntfPendingQueueSubs :: NtfSMPSubMetrics,
+    ntfActiveSubs :: NtfSMPSubMetrics,
+    ntfPendingSubs :: NtfSMPSubMetrics,
     smpSessionCount :: Int,
     apnsPushQLength :: Natural
   }
@@ -60,10 +57,8 @@ ntfPrometheusMetrics sm rtm ts =
         srvSubscribers,
         srvClients,
         srvSubWorkers,
-        ntfActiveServiceSubs,
-        ntfActiveQueueSubs,
-        ntfPendingServiceSubs,
-        ntfPendingQueueSubs,
+        ntfActiveSubs,
+        ntfPendingSubs,
         smpSessionCount,
         apnsPushQLength
       } = rtm
@@ -76,13 +71,8 @@ ntfPrometheusMetrics sm rtm ts =
         _subCreated,
         _subDeleted,
         _ntfReceived,
-        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
-        _ntfReceivedOwn,
-        _ntfReceivedAuthOwn,
-        _ntfDeliveredOwn,
-        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -158,10 +148,8 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_subscriptions_approx_total gauge\n\
       \simplex_ntf_subscriptions_approx_total " <> mshow approxSubCount <> "\n# approxSubCount\n\
       \\n"
-      <> showSubMetric ntfActiveServiceSubs "simplex_ntf_smp_service_subscription_active_" "Active"
-      <> showSubMetric ntfActiveQueueSubs "simplex_ntf_smp_subscription_active_" "Active"
-      <> showSubMetric ntfPendingServiceSubs "simplex_ntf_smp_service_subscription_pending_" "Pending"
-      <> showSubMetric ntfPendingQueueSubs "simplex_ntf_smp_subscription_pending_" "Pending"
+      <> showSubMetric ntfActiveSubs "simplex_ntf_smp_subscription_active_" "Active"
+      <> showSubMetric ntfPendingSubs "simplex_ntf_smp_subscription_pending_" "Pending"
     notifications =
       "# Notifications\n\
       \# -------------\n\
@@ -170,10 +158,6 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_notifications_received counter\n\
       \simplex_ntf_notifications_received " <> mshow _ntfReceived <> "\n# ntfReceived\n\
       \\n\
-      \# HELP simplex_ntf_notifications_received_auth Received notifications without token or subscription (AUTH error)\n\
-      \# TYPE simplex_ntf_notifications_received_auth counter\n\
-      \simplex_ntf_notifications_received_auth " <> mshow _ntfReceivedAuth <> "\n# ntfReceivedAuth\n\
-      \\n\
       \# HELP simplex_ntf_notifications_delivered Delivered notifications\n\
       \# TYPE simplex_ntf_notifications_delivered counter\n\
       \simplex_ntf_notifications_delivered " <> mshow _ntfDelivered <> "\n# ntfDelivered\n\
@@ -210,10 +194,6 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_notifications_total gauge\n\
       \simplex_ntf_notifications_total " <> mshow lastNtfCount <> "\n# lastNtfCount\n\
       \\n"
-      <> showNtfsByServer _ntfReceivedOwn "simplex_ntf_notifications_received_own" "Received notifications" "ntfReceivedOwn"
-      <> showNtfsByServer _ntfReceivedAuthOwn "simplex_ntf_notifications_received_auth_own" "Received notifications without token or subscription (AUTH error)" "ntfReceivedAuthOwn"
-      <> showNtfsByServer _ntfDeliveredOwn "simplex_ntf_notifications_delivered_own" "Delivered notifications" "ntfDeliveredOwn"
-      <> showNtfsByServer _ntfFailedOwn "simplex_ntf_notifications_failed_own" "Failed notifications" "ntfFailedOwn"
     info =
       "# Info\n\
       \# ----\n\
@@ -241,45 +221,32 @@ ntfPrometheusMetrics sm rtm ts =
       showOwnSrvSubs <> showOtherSrvSubs
       where
         showOwnSrvSubs
-          | M.null ownSrvSubs = ""
-          | otherwise =
-              gaugeMetrics (mPfx <> "server_count_own") srvMetrics (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server"
-                <> gaugeMetrics (mPfx <> "sub_count_own") subMetrics (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count"
-          where
-            subs = M.assocs ownSrvSubs
-            srvMetrics = map (\(host, _) -> (metricHost host, 1)) subs
-            subMetrics = map (\(host, cnt) -> (metricHost host, cnt)) subs
+          | M.null ownSrvSubs = showOwn_ "" 0 0
+          | otherwise = T.concat $ map (\(host, cnt) -> showOwn_ (metricHost host) 1 cnt) $ M.assocs ownSrvSubs
+        showOwn_ param srvCnt subCnt =
+          gaugeMetric (mPfx <> "server_count_own") param srvCnt (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server"
+            <> gaugeMetric (mPfx <> "sub_count_own") param subCnt (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count"
         showOtherSrvSubs =
-          gaugeMetrics (mPfx <> "server_count_other") [("", otherServers)] (descrPfx <> " SMP subscriptions, other server count") "otherServers"
-            <> gaugeMetrics (mPfx <> "sub_count_other") [("", otherSrvSubCount)] (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount"
-    showNtfsByServer (StatsByServerData srvNtfs) mName descr varName
-      | null srvNtfs = ""
-      | otherwise =
-          "# HELP " <> mName <> " " <> descr <> "\n\
-          \# TYPE " <> mName <> " counter\n"
-          <> showNtfMetrics
-          <> "# " <> varName <> "\n\n"
-      where
-        showNtfMetrics = T.concat $ map (\(host, value) -> mName <> metricHost host <> " " <> mshow value <> "\n") srvNtfs
+          gaugeMetric (mPfx <> "server_count_other") "" otherServers (descrPfx <> " SMP subscriptions, other server count") "otherServers"
+            <> gaugeMetric (mPfx <> "sub_count_other") "" otherSrvSubCount (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount"
     showWorkerMetric NtfSMPWorkerMetrics {ownServers, otherServers} mPfx descrPfx =
       showOwnServers <> showOtherServers
       where
         showOwnServers
-          | null ownServers = ""
-          | otherwise = gaugeMetrics (mPfx <> "count_own") subMetrics (descrPfx <> " count for own servers") "ownServers"
-          where
-            subMetrics = map (\host -> (metricHost host, 1)) ownServers
-        showOtherServers = gaugeMetrics (mPfx <> "count_other") [("", otherServers)] (descrPfx <> " count for other servers") "otherServers"
-    gaugeMetrics :: Text -> [(Text, Int)] -> Text -> Text -> Text
-    gaugeMetrics name subMetrics descr codeRef =
+          | null ownServers = showOwn_ "" 0
+          | otherwise = T.concat $ map (\host -> showOwn_ (metricHost host) 1) ownServers
+        showOwn_ param cnt = gaugeMetric (mPfx <> "count_own") param cnt (descrPfx <> " count for own servers") "ownServers"
+        showOtherServers = gaugeMetric (mPfx <> "count_other") "" otherServers (descrPfx <> " count for other servers") "otherServers"
+    gaugeMetric :: Text -> Text -> Int -> Text -> Text -> Text
+    gaugeMetric name param value descr codeRef =
       "# HELP " <> name <> " " <> descr <> "\n\
-      \# TYPE " <> name <> " gauge\n"
-      <> T.concat (map (\(param, value) -> name <> param <> " " <> mshow value <> "\n") subMetrics)
-      <> "# " <> codeRef <> "\n\n"
+      \# TYPE " <> name <> " gauge\n\
+      \" <> name <> param <> " " <> mshow value <> "\n# " <> codeRef <> "\n\
+      \\n"
     metricHost host = "{server=\"" <> host <> "\"}"
-    mstr a = a <> " " <> tsEpoch
+    mstr a = T.pack a <> " " <> tsEpoch
     mshow :: Show a => a -> Text
-    mshow = mstr . tshow
-    tsEpoch = tshow @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    mshow = mstr . show
+    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
     epoch = UTCTime systemEpochDay 0
 {-# FOURMOLU_ENABLE\n#-}

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

@@ -1,98 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use newtype instead of data" #-}
-
-module Simplex.Messaging.Notifications.Server.Push where
-
-import Crypto.Hash.Algorithms (SHA256 (..))
-import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
-import Data.Aeson (ToJSON)
-import qualified Data.Aeson as J
-import qualified Data.Aeson.TH as JQ
-import qualified Data.ByteString.Base64.URL as U
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Int (Int64)
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.Text (Text)
-import Data.Time.Clock.System
-import qualified Data.X509 as X
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (defaultJSON)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError)
-import qualified Simplex.Messaging.Crypto as C
-import Network.HTTP.Types (Status)
-import Control.Exception (Exception)
-import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
-import Control.Monad.Except (ExceptT)
-
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show)
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show)
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-$(JQ.deriveToJSON defaultJSON ''JWTHeader)
-
-$(JQ.deriveToJSON defaultJSON ''JWTClaims)
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
-  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
-  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
-
-data PushNotification
-  = PNVerification NtfRegCode
-  | PNMessage (NonEmpty PNMessageData)
-  | -- | PNAlert Text
-    PNCheckMessages
-  deriving (Show)
-
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid NTInvalidReason
-  | PPRetryLater
-  | PPPermanentError
-  deriving (Show, Exception)
-
-type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()

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

@@ -10,13 +10,20 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
+import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
+import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
+import qualified Crypto.PubKey.ECC.Types as ECT
 import Crypto.Random (ChaChaDRG)
+import qualified Crypto.Store.PKCS8 as PK
+import Data.ASN1.BinaryEncoding (DER (..))
+import Data.ASN1.Encoding
+import Data.ASN1.Types
 import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -25,15 +32,18 @@ import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.Int (Int64)
 import Data.List (find)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.System
+import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Network.HPACK.Token as HT
 import Network.HTTP.Types (Status)
@@ -43,7 +53,6 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
@@ -53,6 +62,55 @@ import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
+data JWTHeader = JWTHeader
+  { alg :: Text, -- key algorithm, ES256 for APNS
+    kid :: Text -- key ID
+  }
+  deriving (Show)
+
+data JWTClaims = JWTClaims
+  { iss :: Text, -- issuer, team ID for APNS
+    iat :: Int64 -- issue time, seconds from epoch
+  }
+  deriving (Show)
+
+data JWTToken = JWTToken JWTHeader JWTClaims
+  deriving (Show)
+
+mkJWTToken :: JWTHeader -> Text -> IO JWTToken
+mkJWTToken hdr iss = do
+  iat <- systemSeconds <$> getSystemTime
+  pure $ JWTToken hdr JWTClaims {iss, iat}
+
+type SignedJWTToken = ByteString
+
+$(JQ.deriveToJSON defaultJSON ''JWTHeader)
+
+$(JQ.deriveToJSON defaultJSON ''JWTClaims)
+
+signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTToken pk (JWTToken hdr claims) = do
+  let hc = jwtEncode hdr <> "." <> jwtEncode claims
+  sig <- EC.sign pk SHA256 hc
+  pure $ hc <> "." <> serialize sig
+  where
+    jwtEncode :: ToJSON a => a -> ByteString
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+
+readECPrivateKey :: FilePath -> IO EC.PrivateKey
+readECPrivateKey f = do
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
+  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
+
+data PushNotification
+  = PNVerification NtfRegCode
+  | PNMessage (NonEmpty PNMessageData)
+  | -- | PNAlert Text
+    PNCheckMessages
+  deriving (Show)
+
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show)
 
@@ -250,6 +308,17 @@ apnsRequest c tkn ntf@APNSNotification {aps} = do
       APNSBackground {} -> "background"
       _ -> "alert"
 
+data PushProviderError
+  = PPConnection HTTP2ClientError
+  | PPCryptoError C.CryptoError
+  | PPResponseError (Maybe Status) Text
+  | PPTokenInvalid NTInvalidReason
+  | PPRetryLater
+  | PPPermanentError
+  deriving (Show, Exception)
+
+type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
+
 -- this is not a newtype on purpose to have a correct JSON encoding as a record
 data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 

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

@@ -5,17 +5,12 @@
 module Simplex.Messaging.Notifications.Server.Stats where
 
 import Control.Applicative (optional, (<|>))
-import Control.Concurrent.STM
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.IORef
-import qualified Data.Map.Strict as M
-import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 
 data NtfServerStats = NtfServerStats
   { fromTime :: IORef UTCTime,
@@ -26,13 +21,8 @@ data NtfServerStats = NtfServerStats
     subCreated :: IORef Int,
     subDeleted :: IORef Int,
     ntfReceived :: IORef Int,
-    ntfReceivedAuth :: IORef Int,
     ntfDelivered :: IORef Int,
     ntfFailed :: IORef Int,
-    ntfReceivedOwn :: StatsByServer,
-    ntfReceivedAuthOwn :: StatsByServer,
-    ntfDeliveredOwn :: StatsByServer,
-    ntfFailedOwn :: StatsByServer,
     ntfCronDelivered :: IORef Int,
     ntfCronFailed :: IORef Int,
     ntfVrfQueued :: IORef Int,
@@ -52,13 +42,8 @@ data NtfServerStatsData = NtfServerStatsData
     _subCreated :: Int,
     _subDeleted :: Int,
     _ntfReceived :: Int,
-    _ntfReceivedAuth :: Int,
     _ntfDelivered :: Int,
     _ntfFailed :: Int,
-    _ntfReceivedOwn :: StatsByServerData,
-    _ntfReceivedAuthOwn :: StatsByServerData,
-    _ntfDeliveredOwn :: StatsByServerData,
-    _ntfFailedOwn :: StatsByServerData,
     _ntfCronDelivered :: Int,
     _ntfCronFailed :: Int,
     _ntfVrfQueued :: Int,
@@ -79,13 +64,8 @@ newNtfServerStats ts = do
   subCreated <- newIORef 0
   subDeleted <- newIORef 0
   ntfReceived <- newIORef 0
-  ntfReceivedAuth <- newIORef 0
   ntfDelivered <- newIORef 0
   ntfFailed <- newIORef 0
-  ntfReceivedOwn <- TM.emptyIO
-  ntfReceivedAuthOwn <- TM.emptyIO
-  ntfDeliveredOwn <- TM.emptyIO
-  ntfFailedOwn <- TM.emptyIO
   ntfCronDelivered <- newIORef 0
   ntfCronFailed <- newIORef 0
   ntfVrfQueued <- newIORef 0
@@ -104,13 +84,8 @@ newNtfServerStats ts = do
         subCreated,
         subDeleted,
         ntfReceived,
-        ntfReceivedAuth,
         ntfDelivered,
         ntfFailed,
-        ntfReceivedOwn,
-        ntfReceivedAuthOwn,
-        ntfDeliveredOwn,
-        ntfFailedOwn,
         ntfCronDelivered,
         ntfCronFailed,
         ntfVrfQueued,
@@ -131,13 +106,8 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
   _subCreated <- readIORef $ subCreated s
   _subDeleted <- readIORef $ subDeleted s
   _ntfReceived <- readIORef $ ntfReceived s
-  _ntfReceivedAuth <- readIORef $ ntfReceivedAuth s
   _ntfDelivered <- readIORef $ ntfDelivered s
   _ntfFailed <- readIORef $ ntfFailed s
-  _ntfReceivedOwn <- getStatsByServer $ ntfReceivedOwn s
-  _ntfReceivedAuthOwn <- getStatsByServer $ ntfReceivedAuthOwn s
-  _ntfDeliveredOwn <- getStatsByServer $ ntfDeliveredOwn s
-  _ntfFailedOwn <- getStatsByServer $ ntfFailedOwn s
   _ntfCronDelivered <- readIORef $ ntfCronDelivered s
   _ntfCronFailed <- readIORef $ ntfCronFailed s
   _ntfVrfQueued <- readIORef $ ntfVrfQueued s
@@ -156,13 +126,8 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
         _subCreated,
         _subDeleted,
         _ntfReceived,
-        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
-        _ntfReceivedOwn,
-        _ntfReceivedAuthOwn,
-        _ntfDeliveredOwn,
-        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -184,13 +149,8 @@ setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} =
   writeIORef (subCreated s) $! _subCreated d
   writeIORef (subDeleted s) $! _subDeleted d
   writeIORef (ntfReceived s) $! _ntfReceived d
-  writeIORef (ntfReceivedAuth s) $! _ntfReceivedAuth d
   writeIORef (ntfDelivered s) $! _ntfDelivered d
   writeIORef (ntfFailed s) $! _ntfFailed d
-  setStatsByServer (ntfReceivedOwn s) $! _ntfReceivedOwn d
-  setStatsByServer (ntfReceivedAuthOwn s) $! _ntfReceivedAuthOwn d
-  setStatsByServer (ntfDeliveredOwn s) $! _ntfDeliveredOwn d
-  setStatsByServer (ntfFailedOwn s) $! _ntfFailedOwn d
   writeIORef (ntfCronDelivered s) $! _ntfCronDelivered d
   writeIORef (ntfCronFailed s) $! _ntfCronFailed d
   writeIORef (ntfVrfQueued s) $! _ntfVrfQueued d
@@ -211,13 +171,8 @@ instance StrEncoding NtfServerStatsData where
         _subCreated,
         _subDeleted,
         _ntfReceived,
-        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
-        _ntfReceivedOwn,
-        _ntfReceivedAuthOwn,
-        _ntfDeliveredOwn,
-        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -236,13 +191,8 @@ instance StrEncoding NtfServerStatsData where
         "subCreated=" <> strEncode _subCreated,
         "subDeleted=" <> strEncode _subDeleted,
         "ntfReceived=" <> strEncode _ntfReceived,
-        "ntfReceivedAuth=" <> strEncode _ntfReceivedAuth,
         "ntfDelivered=" <> strEncode _ntfDelivered,
         "ntfFailed=" <> strEncode _ntfFailed,
-        "ntfReceivedOwn=" <> strEncode _ntfReceivedOwn,
-        "ntfReceivedAuthOwn=" <> strEncode _ntfReceivedAuthOwn,
-        "ntfDeliveredOwn=" <> strEncode _ntfDeliveredOwn,
-        "ntfFailedOwn=" <> strEncode _ntfFailedOwn,
         "ntfCronDelivered=" <> strEncode _ntfCronDelivered,
         "ntfCronFailed=" <> strEncode _ntfCronFailed,
         "ntfVrfQueued=" <> strEncode _ntfVrfQueued,
@@ -263,13 +213,8 @@ instance StrEncoding NtfServerStatsData where
     _subCreated <- "subCreated=" *> strP <* A.endOfLine
     _subDeleted <- "subDeleted=" *> strP <* A.endOfLine
     _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
-    _ntfReceivedAuth <- opt "ntfReceivedAuth="
     _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
     _ntfFailed <- opt "ntfFailed="
-    _ntfReceivedOwn <- statByServerP "ntfReceivedOwn="
-    _ntfReceivedAuthOwn <- statByServerP "ntfReceivedAuthOwn="
-    _ntfDeliveredOwn <- statByServerP "ntfDeliveredOwn="
-    _ntfFailedOwn <- statByServerP "ntfFailedOwn="
     _ntfCronDelivered <- opt "ntfCronDelivered="
     _ntfCronFailed <- opt "ntfCronFailed="
     _ntfVrfQueued <- opt "ntfVrfQueued="
@@ -290,13 +235,8 @@ instance StrEncoding NtfServerStatsData where
           _subCreated,
           _subDeleted,
           _ntfReceived,
-          _ntfReceivedAuth,
           _ntfDelivered,
           _ntfFailed,
-          _ntfReceivedOwn,
-          _ntfReceivedAuthOwn,
-          _ntfDeliveredOwn,
-          _ntfFailedOwn,
           _ntfCronDelivered,
           _ntfCronFailed,
           _ntfVrfQueued,
@@ -308,26 +248,3 @@ instance StrEncoding NtfServerStatsData where
         }
     where
       opt s = A.string s *> strP <* A.endOfLine <|> pure 0
-      statByServerP s = A.string s *> strP <* A.endOfLine <|> pure (StatsByServerData [])
-
-type StatsByServer = TMap Text (TVar Int)
-
-newtype StatsByServerData = StatsByServerData [(Text, Int)]
-
-instance StrEncoding StatsByServerData where
-  strEncode (StatsByServerData d) = strEncodeList d
-  strP = StatsByServerData <$> serverP `A.sepBy'` A.char ','
-    where
-      serverP = (,) <$> strP_ <*> A.decimal
-
-getStatsByServer :: TMap Text (TVar Int) -> IO StatsByServerData
-getStatsByServer s = readTVarIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO
-
-setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO ()
-setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s
-
--- double lookup avoids STM transaction with a shared map in most cases
-incServerStat :: Text -> TMap Text (TVar Int) -> IO ()
-incServerStat h s = TM.lookupIO h s >>= atomically . maybe newServerStat (`modifyTVar'` (+ 1))
-  where
-    newServerStat = TM.lookup h s >>= maybe (TM.insertM h (newTVar 1) s) (`modifyTVar'` (+ 1))

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

@@ -24,8 +24,8 @@ import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId)
-import Simplex.Messaging.SystemTime
+import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
@@ -37,8 +37,7 @@ data NtfSTMStore = NtfSTMStore
     subscriptions :: TMap NtfSubscriptionId NtfSubData,
     tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
     subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
-    tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)),
-    ntfServices :: TMap SMPServer ServiceId
+    tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
   }
 
 newNtfSTMStore :: IO NtfSTMStore
@@ -49,22 +48,21 @@ newNtfSTMStore = do
   tokenSubscriptions <- TM.emptyIO
   subscriptionLookup <- TM.emptyIO
   tokenLastNtfs <- TM.emptyIO
-  ntfServices <- TM.emptyIO
-  pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs, ntfServices}
+  pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
 
 data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
     token :: DeviceToken,
     tknStatus :: TVar NtfTknStatus,
     tknVerifyKey :: NtfPublicAuthKey,
-    tknDhKeys :: C.KeyPairX25519,
+    tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
     tknCronInterval :: TVar Word16,
-    tknUpdatedAt :: TVar (Maybe SystemDate)
+    tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
   }
 
-mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> SystemDate -> IO NtfTknData
+mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
 mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
   tknStatus <- newTVarIO NTRegistered
   tknCronInterval <- newTVarIO 0
@@ -76,8 +74,7 @@ data NtfSubData = NtfSubData
     smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
-    subStatus :: TVar NtfSubStatus,
-    ntfServiceAssoc :: TVar Bool
+    subStatus :: TVar NtfSubStatus
   }
 
 ntfSubServer :: NtfSubData -> SMPServer
@@ -186,10 +183,6 @@ stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
       whenM (TM.member tknId tokens) $
         TM.insertM tknId (newTVar [ntf]) tokenLastNtfs
 
-stmSetNtfService :: NtfSTMStore -> SMPServer -> Maybe ServiceId -> STM ()
-stmSetNtfService (NtfSTMStore {ntfServices}) srv serviceId =
-  maybe (TM.delete srv) (TM.insert srv) serviceId ntfServices
-
 data TokenNtfMessageRecord = TNMRv1 NtfTokenId PNMessageData
 
 instance StrEncoding TokenNtfMessageRecord where

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

@@ -1,18 +1,17 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Notifications.Server.Store.Migrations where
 
 import Data.List (sortOn)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Simplex.Messaging.Agent.Store.Shared
 import Text.RawString.QQ (r)
 
 ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
 ntfServerSchemaMigrations =
-  [ ("20250417_initial", m20250417_initial, Nothing),
-    ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert)
+  [ ("20250417_initial", m20250417_initial, Nothing)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -23,7 +22,8 @@ ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations
 
 m20250417_initial :: Text
 m20250417_initial =
-  [r|
+  T.pack
+    [r|
 CREATE TABLE tokens(
   token_id BYTEA NOT NULL,
   push_provider TEXT NOT NULL,
@@ -79,25 +79,3 @@ CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscr
 
 CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
     |]
-
-m20250517_service_cert :: Text
-m20250517_service_cert =
-  [r|
-ALTER TABLE smp_servers ADD COLUMN ntf_service_id BYTEA;
-
-ALTER TABLE subscriptions ADD COLUMN ntf_service_assoc BOOLEAN NOT NULL DEFAULT FALSE;
-
-DROP INDEX idx_subscriptions_smp_server_id_status;
-CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON subscriptions(smp_server_id, ntf_service_assoc, status);
-    |]
-
-down_m20250517_service_cert :: Text
-down_m20250517_service_cert =
-  [r|
-DROP INDEX idx_subscriptions_smp_server_id_ntf_service_status;
-CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
-
-ALTER TABLE smp_servers DROP COLUMN ntf_service_id;
-
-ALTER TABLE subscriptions DROP COLUMN ntf_service_assoc;
-    |]

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

@@ -37,7 +37,7 @@ import Data.List (findIndex, foldl')
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, isJust, mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -54,21 +54,20 @@ 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 (fromTextField_)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
 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.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId, pattern SMPServer)
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, pattern SMPServer)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
 import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (anyM, firstRow, maybeFirstRow, toChunks, tshow)
 import System.Exit (exitFailure)
@@ -76,8 +75,7 @@ import System.IO (IOMode (..), hFlush, stdout, withFile)
 import Text.Hex (decodeHex)
 
 #if !defined(dbPostgres)
-import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
-import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Util (eitherToMaybe)
 #endif
 
@@ -87,7 +85,7 @@ data NtfPostgresStore = NtfPostgresStore
     deletedTTL :: Int64
   }
 
-mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> SystemDate -> NtfTknRec
+mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> NtfTknRec
 mkNtfTknRec ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhPrivKey tknDhSecret tknRegCode ts =
   NtfTknRec {ntfTknId, token, tknStatus = NTRegistered, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval = 0, tknUpdatedAt = Just ts}
 
@@ -100,7 +98,7 @@ data NtfEntityRec (e :: NtfEntity) where
 
 newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
 newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations (MigrationConfig confirmMigrations Nothing)
+  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
   dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
   pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
   where
@@ -170,7 +168,7 @@ updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
     void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId)
     withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts
 
-type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)
+type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe RoundedSystemTime)
 
 ntfTknQuery :: Query
 ntfTknQuery =
@@ -239,43 +237,32 @@ updateTknCronInterval st tknId cronInt =
 
 -- Reads servers that have subscriptions that need subscribing.
 -- It is executed on server start, and it is supposed to crash on database error
-getUsedSMPServers :: NtfPostgresStore -> IO [(SMPServer, Int64, Maybe (ServiceId, Int64))]
-getUsedSMPServers st =
+getUsedSMPServers :: NtfPostgresStore -> IO [SMPServer]
+getUsedSMPServers st = 
   withTransaction (dbStore st) $ \db ->
-    map rowToSrvSubs <$>
+    map rowToSrv <$>
       DB.query
         db
         [sql|
-          SELECT
-            p.smp_host, p.smp_port, p.smp_keyhash, p.smp_server_id, p.ntf_service_id,
-            SUM(CASE WHEN s.ntf_service_assoc THEN s.subs_count ELSE 0 END) :: BIGINT as service_subs_count
+          SELECT p.smp_host, p.smp_port, p.smp_keyhash
           FROM smp_servers p
-          JOIN (
-            SELECT
-              smp_server_id,
-              ntf_service_assoc,
-              COUNT(1) as subs_count
-            FROM subscriptions
-            WHERE status IN ?
-            GROUP BY smp_server_id, ntf_service_assoc
-          ) s ON s.smp_server_id = p.smp_server_id
-          GROUP BY p.smp_host, p.smp_port, p.smp_keyhash, p.smp_server_id, p.ntf_service_id
+          WHERE EXISTS (
+            SELECT 1 FROM subscriptions s
+            WHERE s.smp_server_id = p.smp_server_id
+              AND s.status IN ?
+          )
         |]
         (Only (In [NSNew, NSPending, NSActive, NSInactive]))
-  where
-    rowToSrvSubs :: SMPServerRow :. (Int64, Maybe ServiceId, Int64) -> (SMPServer, Int64, Maybe (ServiceId, Int64))
-    rowToSrvSubs ((host, port, kh) :. (srvId, serviceId_, subsCount)) =
-      (SMPServer host port kh, srvId, (,subsCount) <$> serviceId_)
 
-getServerNtfSubscriptions :: NtfPostgresStore -> Int64 -> Maybe NtfSubscriptionId -> Int -> IO (Either ErrorType [ServerNtfSub])
-getServerNtfSubscriptions st srvId afterSubId_ count =
+getServerNtfSubscriptions :: NtfPostgresStore -> SMPServer -> Maybe NtfSubscriptionId -> Int -> IO (Either ErrorType [ServerNtfSub])
+getServerNtfSubscriptions st srv afterSubId_ count =
   withDB' "getServerNtfSubscriptions" st $ \db -> do
     subs <-
       map toServerNtfSub <$> case afterSubId_ of
         Nothing ->
-          DB.query db (query <> orderLimit) (srvId, statusIn, count)
+          DB.query db (query <> orderLimit) (srvToRow srv :. (statusIn, count))
         Just afterSubId ->
-          DB.query db (query <> " AND subscription_id > ?" <> orderLimit) (srvId, statusIn, afterSubId, count)
+          DB.query db (query <> " AND s.subscription_id > ?" <> orderLimit) (srvToRow srv :. (statusIn, afterSubId, count))
     void $
       DB.executeMany
         db
@@ -291,11 +278,13 @@ getServerNtfSubscriptions st srvId afterSubId_ count =
   where
     query =
       [sql|
-        SELECT subscription_id, smp_notifier_id, smp_notifier_key
-        FROM subscriptions
-        WHERE smp_server_id = ? AND NOT ntf_service_assoc AND status IN ?
+        SELECT s.subscription_id, s.smp_notifier_id, s.smp_notifier_key
+        FROM subscriptions s
+        JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
+        WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ?
+          AND s.status IN ?
       |]
-    orderLimit = " ORDER BY subscription_id LIMIT ?"
+    orderLimit = " ORDER BY s.subscription_id LIMIT ?"
     statusIn = In [NSNew, NSPending, NSActive, NSInactive]
     toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey))
 
@@ -312,7 +301,7 @@ findNtfSubscription st tknId q =
         DB.query
           db
           [sql|
-            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc
+            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status
             FROM subscriptions s
             JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
             WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ?
@@ -331,33 +320,33 @@ getNtfSubscription st subId =
           db
           [sql|
             SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at,
-              s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc,
+              s.subscription_id, s.smp_notifier_key, s.status,
               p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id
             FROM subscriptions s
             JOIN tokens t ON t.token_id = s.token_id
             JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
             WHERE s.subscription_id = ?
-          |]
+          |]          
           (Only subId)
     liftIO $ updateTokenDate st db tkn
     unless (allowNtfSubCommands tknStatus) $ throwE AUTH
     pure r
 
-type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus, NtfAssociatedService)
+type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus)
 
 rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec)
-rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow)  =
+rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus) :. qRow)  =
   let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow
       smpQueue = rowToSMPQueue qRow
-   in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc})
+   in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus})
 
 rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec
-rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc)) =
-  NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
+rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus)) =
+  NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}
 
 mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec
 mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) =
-  NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey, ntfServiceAssoc = False}
+  NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey}
 
 updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ())
 updateTknStatus st tkn status =
@@ -403,13 +392,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 (Int64, Bool))
+addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType 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 (srvId, n > 0)
+    pure $ 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.
@@ -419,14 +408,14 @@ addNtfSubscription st sub =
         getServer =
           maybeFirstRow fromOnly $
             DB.query
-              db
+              db 
               [sql|
                 SELECT smp_server_id
                 FROM smp_servers
                 WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
               |]
               (srvToRow srv)
-        insertServer =
+        insertServer = 
           firstRow fromOnly (STORE "error inserting SMP server when adding subscription") $
             DB.query
               db
@@ -441,13 +430,13 @@ addNtfSubscription st sub =
 insertNtfSubQuery :: Query
 insertNtfSubQuery =
   [sql|
-    INSERT INTO subscriptions (token_id, smp_server_id, smp_notifier_id, subscription_id, smp_notifier_key, status, ntf_service_assoc)
-    VALUES (?,?,?,?,?,?,?)
+    INSERT INTO subscriptions (token_id, smp_server_id, smp_notifier_id, subscription_id, smp_notifier_key, status)
+    VALUES (?,?,?,?,?,?)
   |]
 
 ntfSubToRow :: Int64 -> NtfSubRec -> (NtfTokenId, Int64, NotifierId) :. NtfSubRow
-ntfSubToRow srvId NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf _ nId, notifierKey, subStatus, ntfServiceAssoc} =
-  (tokenId, srvId, nId) :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc)
+ntfSubToRow srvId NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf _ nId, notifierKey, subStatus} =
+  (tokenId, srvId, nId) :. (ntfSubId, notifierKey, subStatus)
 
 deleteNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType ())
 deleteNtfSubscription st subId =
@@ -456,27 +445,11 @@ deleteNtfSubscription st subId =
       DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId)
     withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId)
 
-updateSubStatus :: NtfPostgresStore -> Int64 -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
-updateSubStatus st srvId nId status =
-  withFastDB' "updateSubStatus" st $ \db -> do
-    sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
-      maybeFirstRow id $
-        DB.query
-          db
-          [sql|
-            UPDATE subscriptions SET status = ?
-            WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ?
-            RETURNING subscription_id, ntf_service_assoc
-          |]
-          (status, srvId, nId, status)
-    forM_ sub_ $ \(subId, serviceAssoc) ->
-      withLog "updateSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
-
 updateSrvSubStatus :: NtfPostgresStore -> SMPQueueNtf -> NtfSubStatus -> IO (Either ErrorType ())
 updateSrvSubStatus st q status =
   withFastDB' "updateSrvSubStatus" st $ \db -> do
-    sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
-      maybeFirstRow id $
+    subId_ :: Maybe NtfSubscriptionId <-
+      maybeFirstRow fromOnly $
         DB.query
           db
           [sql|
@@ -486,41 +459,57 @@ updateSrvSubStatus st q status =
             WHERE p.smp_server_id = s.smp_server_id
               AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ?
               AND s.status != ?
-            RETURNING s.subscription_id, s.ntf_service_assoc
+            RETURNING s.subscription_id
           |]
           (Only status :. smpQueueToRow q :. Only status)
-    forM_ sub_ $ \(subId, serviceAssoc) ->
-      withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
+    forM_ subId_ $ \subId -> 
+      withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl subId status
 
-batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> Maybe ServiceId -> NonEmpty NotifierId -> NtfSubStatus -> IO Int
-batchUpdateSrvSubStatus st srv newServiceId nIds status =
-  fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubStatus" st $ \db -> runExceptT $ do
-    (srvId :: Int64, currServiceId) <- ExceptT $ getSMPServerService db
-    unless (currServiceId == newServiceId) $ liftIO $ void $
-      DB.execute db "UPDATE smp_servers SET ntf_service_id = ? WHERE smp_server_id = ?" (newServiceId, srvId)
-    let params = L.toList $ L.map (srvId,isJust newServiceId,status,) nIds
-    liftIO $ fromIntegral <$> DB.executeMany db updateSubStatusQuery params
-  where
-    getSMPServerService db =
-      firstRow id AUTH $
-        DB.query
+batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> NonEmpty NotifierId -> NtfSubStatus -> IO Int64
+batchUpdateSrvSubStatus st srv nIds status =
+  batchUpdateStatus_ st srv $ \srvId ->
+    -- without executeMany
+    -- L.toList $ L.map (status,srvId,,status) nIds
+    L.toList $ L.map (status,srvId,) nIds
+
+batchUpdateSrvSubStatuses :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int64
+batchUpdateSrvSubStatuses st srv subs =
+  batchUpdateStatus_ st srv $ \srvId ->
+    -- without executeMany
+    -- L.toList $ L.map (\(nId, status) -> (status, srvId, nId, status)) subs
+    L.toList $ L.map (\(nId, status) -> (status, srvId, nId)) subs
+
+-- without executeMany
+-- batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId, NtfSubStatus)]) -> IO Int64
+batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId)]) -> IO Int64
+batchUpdateStatus_ st srv mkParams =
+  fmap (fromRight (-1)) $ withDB "batchUpdateStatus_" st $ \db -> runExceptT $ do
+    srvId <- ExceptT $ getSMPServerId db
+    let params = mkParams srvId
+    subs <-
+      liftIO $
+        DB.returning
           db
           [sql|
-            SELECT smp_server_id, ntf_service_id
-            FROM smp_servers
-            WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
-            FOR UPDATE
+            UPDATE subscriptions s
+            SET status = upd.status
+            FROM (VALUES(?, ?, ?)) AS upd(status, smp_server_id, smp_notifier_id)
+            WHERE s.smp_server_id = upd.smp_server_id
+              AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA)
+              AND s.status != upd.status
+            RETURNING s.subscription_id, s.status
           |]
-          (srvToRow srv)
-
-batchUpdateSrvSubErrors :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int
-batchUpdateSrvSubErrors st srv subs =
-  fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubErrors" st $ \db -> runExceptT $ do
-    srvId :: Int64 <- ExceptT $ getSMPServerId db
-    let params = map (\(nId, status) -> (srvId, False, status, nId)) $ L.toList subs
-    subs' <- liftIO $ DB.returning db (updateSubStatusQuery <> " RETURNING s.subscription_id, s.status, s.ntf_service_assoc") params
-    withLog "batchUpdateStatus_" st $ forM_ subs' . logSubscriptionStatus
-    pure $ length subs'
+          params
+    -- TODO [ntfdb] below is equivalent without using executeMany.
+    -- executeMany "works", and logs updates.
+    -- We do not have tests that validate correct subscription status,
+    -- and the potential problem is BYTEA conversation - VALUES are inserted as TEXT in this case for some reason.
+    -- subs <-
+    --   liftIO $ fmap catMaybes $ forM params $
+    --     maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ? RETURNING subscription_id, status"
+    -- logWarn $ "batchUpdateStatus_: " <> tshow (length subs)
+    withLog "batchUpdateStatus_" st $ forM_ subs . uncurry . logSubscriptionStatus
+    pure $ fromIntegral $ length subs
   where
     getSMPServerId db =
       firstRow fromOnly AUTH $
@@ -533,47 +522,31 @@ batchUpdateSrvSubErrors st srv subs =
           |]
           (srvToRow srv)
 
-updateSubStatusQuery :: Query
-updateSubStatusQuery =
-  [sql|
-    UPDATE subscriptions s
-    SET status = upd.status, ntf_service_assoc = upd.ntf_service_assoc
-    FROM (VALUES(?, ?, ?, ?)) AS upd(smp_server_id, ntf_service_assoc, status, smp_notifier_id)
-    WHERE s.smp_server_id = upd.smp_server_id
-      AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA)
-      AND (s.status != upd.status OR s.ntf_service_assoc != upd.ntf_service_assoc)
-  |]
-
-removeServiceAssociation :: NtfPostgresStore -> SMPServer -> IO (Either ErrorType (Int64, Int))
-removeServiceAssociation st srv = do
-  withDB "removeServiceAssociation" st $ \db -> runExceptT $ do
-    srvId <- ExceptT $ removeServerService db
-    subs <-
-      liftIO $
-        DB.query
-          db
-          [sql|
-            UPDATE subscriptions s
-            SET status = ?, ntf_service_assoc = FALSE
-            WHERE smp_server_id = ?
-              AND (s.status != ? OR s.ntf_service_assoc != FALSE)
-            RETURNING s.subscription_id, s.status, s.ntf_service_assoc
-          |]
-          (NSInactive, srvId, NSInactive)
-    withLog "removeServiceAssociation" st $ forM_ subs . logSubscriptionStatus
-    pure (srvId, length subs)
-  where
-    removeServerService db =
-      firstRow fromOnly AUTH $
-        DB.query
-          db
-          [sql|
-            UPDATE smp_servers
-            SET ntf_service_id = NULL
-            WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
-            RETURNING smp_server_id
-          |]
-          (srvToRow srv)
+batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty ServerNtfSub -> NtfSubStatus -> IO Int64
+batchUpdateSubStatus st subs status =
+  fmap (fromRight (-1)) $ withFastDB' "batchUpdateSubStatus" st $ \db -> do
+    let params = L.toList $ L.map (\(subId, _) -> (status, subId)) subs
+    subIds <-
+      DB.returning
+        db
+        [sql|
+          UPDATE subscriptions s
+          SET status = upd.status
+          FROM (VALUES(?, ?)) AS upd(status, subscription_id)
+          WHERE s.subscription_id = (upd.subscription_id :: BYTEA)
+            AND s.status != upd.status
+          RETURNING s.subscription_id
+        |]
+        params
+    -- TODO [ntfdb] below is equivalent without using executeMany - see comment above.
+    -- let params = L.toList $ L.map (\NtfSubRec {ntfSubId} -> (status, ntfSubId, status)) subs
+    -- subIds <-
+    --   fmap catMaybes $ forM params $
+    --     maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE subscription_id = ? AND status != ? RETURNING subscription_id"
+    -- logWarn $ "batchUpdateSubStatus: " <> tshow (length subIds)
+    withLog "batchUpdateSubStatus" st $ \sl ->
+      forM_ subIds $ \(Only subId) -> logSubscriptionStatus sl subId status
+    pure $ fromIntegral $ length subIds
 
 addTokenLastNtf :: NtfPostgresStore -> PNMessageData -> IO (Either ErrorType (NtfTknRec, NonEmpty PNMessageData))
 addTokenLastNtf st newNtf =
@@ -653,16 +626,15 @@ getEntityCounts st =
     pure (tCnt, sCnt, nCnt)
   where
     count (Only n : _) = n
-    count [] = 0
+    count [] = 0    
 
-importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, Int64, Int64, Int64)
+importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, Int64, Int64)
 importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
   (tIds, tCnt) <- importTokens
   subLookup <- readTVarIO $ subscriptionLookup stmStore
   sCnt <- importSubscriptions tIds subLookup
   nCnt <- importLastNtfs tIds subLookup
-  serviceCnt <- importNtfServiceIds
-  pure (tCnt, sCnt, nCnt, serviceCnt)
+  pure (tCnt, sCnt, nCnt)
   where
     importTokens = do
       allTokens <- M.elems <$> readTVarIO (tokens stmStore)
@@ -725,7 +697,7 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
         filterSubs allSubs = do
           let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs
               skipped = length allSubs - length subs
-          when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens"
+          when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens" 
           let (removedSubTokens, removeSubs, dupQueues) = foldl' addSubToken (S.empty, S.empty, S.empty) subs
           unless (null removeSubs) $ putStrLn $ "Skipped " <> show (S.size removeSubs) <> " duplicate subscriptions of " <> show (S.size removedSubTokens) <> " tokens for " <> show (S.size dupQueues) <> " queues"
           pure $ filter (\NtfSubData {ntfSubId} -> S.notMember ntfSubId removeSubs) subs
@@ -789,22 +761,10 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
               else (S.insert tId stIds, cnt', acc)
           where
             ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of
-              Just ntfSubId ->
+              Just ntfSubId -> 
                 let row = (tId, ntfSubId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta)
                  in (qs, row : rows)
               Nothing -> (S.insert smpQueue qs, rows)
-    importNtfServiceIds = do
-      ss <- M.assocs <$> readTVarIO (ntfServices stmStore)
-      withConnection s $ \db -> DB.executeMany db serviceQuery $ map serviceToRow ss
-      where
-        serviceQuery =
-          [sql|
-            INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash, ntf_service_id)
-            VALUES (?, ?, ?, ?)
-            ON CONFLICT (smp_host, smp_port, smp_keyhash)
-            DO UPDATE SET ntf_service_id = EXCLUDED.ntf_service_id
-          |]
-        serviceToRow (srv, serviceId) = srvToRow srv :. Only serviceId
     checkCount name expected inserted
       | fromIntegral expected == inserted = do
           putStrLn $ "Imported " <> show inserted <> " " <> name <> "s."
@@ -839,15 +799,15 @@ exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFi
       where
         ntfSubQuery =
           [sql|
-            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc,
+            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status,
               p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id
             FROM subscriptions s
             JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
           |]
         toNtfSub :: Only NtfTokenId :. NtfSubRow :. SMPQueueNtfRow -> NtfSubRec
-        toNtfSub (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow)  =
+        toNtfSub (Only tokenId :. (ntfSubId, notifierKey, subStatus) :. qRow)  =
           let smpQueue = rowToSMPQueue qRow
-           in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
+           in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}
     exportLastNtfs =
       withFile lastNtfsFile WriteMode $ \h ->
         withConnection s $ \db -> DB.fold_ db lastNtfsQuery 0 $ \ !i (Only tknId :. ntfRow) ->
@@ -865,32 +825,32 @@ exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFi
           |]
         encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n'
 
-withFastDB' :: Text -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
+withFastDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
 withFastDB' op st action = withFastDB op st $ fmap Right . action
 {-# INLINE withFastDB' #-}
 
-withDB' :: Text -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
+withDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
 withDB' op st action = withDB op st $ fmap Right . action
 {-# INLINE withDB' #-}
 
-withFastDB :: forall a. Text -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+withFastDB :: forall a. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
 withFastDB op st = withDB_ op st True
 {-# INLINE withFastDB #-}
 
-withDB :: forall a. Text -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+withDB :: forall a. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
 withDB op st = withDB_ op st False
 {-# INLINE withDB #-}
 
-withDB_ :: forall a. Text -> NtfPostgresStore -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+withDB_ :: forall a. String -> NtfPostgresStore -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
 withDB_ op st priority action =
   E.uninterruptibleMask_ $ E.try (withTransactionPriority (dbStore st) priority action) >>= either logErr pure
   where
     logErr :: E.SomeException -> IO (Either ErrorType a)
-    logErr e = logError ("STORE: " <> err) $> Left (STORE err)
+    logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err)
       where
-        err = op <> ", withDB, " <> tshow e
+        err = op <> ", withDB, " <> show e
 
-withLog :: MonadIO m => Text -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog :: MonadIO m => String -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
 withLog op NtfPostgresStore {dbStoreLog} = withLog_ op dbStoreLog
 {-# INLINE withLog #-}
 

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

@@ -9,14 +9,13 @@ module Simplex.Messaging.Notifications.Server.Store.Types where
 import Control.Applicative (optional)
 import Control.Concurrent.STM
 import qualified Data.ByteString.Char8 as B
-import Data.Maybe (fromMaybe)
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
 import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..))
 import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey)
-import Simplex.Messaging.SystemTime
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 
 data NtfTknRec = NtfTknRec
   { ntfTknId :: NtfTokenId,
@@ -27,7 +26,7 @@ data NtfTknRec = NtfTknRec
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
     tknCronInterval :: Word16,
-    tknUpdatedAt :: Maybe SystemDate
+    tknUpdatedAt :: Maybe RoundedSystemTime
   }
   deriving (Show)
 
@@ -78,36 +77,30 @@ data NtfSubRec = NtfSubRec
     smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus,
-    ntfServiceAssoc :: NtfAssociatedService -- Bool
+    subStatus :: NtfSubStatus
   }
   deriving (Show)
 
 type ServerNtfSub = (NtfSubscriptionId, (NotifierId, NtfPrivateAuthKey))
 
-type NtfAssociatedService = Bool
-
 mkSubData :: NtfSubRec -> IO NtfSubData
-mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
+mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
   subStatus <- newTVarIO status
-  ntfServiceAssoc <- newTVarIO serviceAssoc
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
+  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
 
 mkSubRec :: NtfSubData -> IO NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
+mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
   subStatus <- readTVarIO status
-  ntfServiceAssoc <- readTVarIO serviceAssoc
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
+  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
 
 instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc} =
+  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
     B.unwords
       [ "subId=" <> strEncode ntfSubId,
         "smpQueue=" <> strEncode smpQueue,
         "notifierKey=" <> strEncode notifierKey,
         "tknId=" <> strEncode tokenId,
-        "subStatus=" <> strEncode subStatus,
-        "serviceAssoc=" <> strEncode ntfServiceAssoc
+        "subStatus=" <> strEncode subStatus
       ]
   strP = do
     ntfSubId <- "subId=" *> strP_
@@ -115,5 +108,4 @@ instance StrEncoding NtfSubRec where
     notifierKey <- "notifierKey=" *> strP_
     tokenId <- "tknId=" *> strP_
     subStatus <- "subStatus=" *> strP
-    ntfServiceAssoc <- fromMaybe False <$> optional (" serviceAssoc=" *> strP)
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
+    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}

src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql

@@ -52,8 +52,7 @@ CREATE TABLE ntf_server.smp_servers (
     smp_server_id bigint NOT NULL,
     smp_host text NOT NULL,
     smp_port text NOT NULL,
-    smp_keyhash bytea NOT NULL,
-    ntf_service_id bytea
+    smp_keyhash bytea NOT NULL
 );
 
 
@@ -75,8 +74,7 @@ CREATE TABLE ntf_server.subscriptions (
     smp_server_id bigint,
     smp_notifier_id bytea NOT NULL,
     smp_notifier_key bytea NOT NULL,
-    status text NOT NULL,
-    ntf_service_assoc boolean DEFAULT false NOT NULL
+    status text NOT NULL
 );
 
 
@@ -142,7 +140,7 @@ CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON ntf_server.su
 
 
 
-CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON ntf_server.subscriptions USING btree (smp_server_id, ntf_service_assoc, status);
+CREATE INDEX idx_subscriptions_smp_server_id_status ON ntf_server.subscriptions USING btree (smp_server_id, status);
 
 
 

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

@@ -24,23 +24,19 @@ module Simplex.Messaging.Notifications.Server.StoreLog
   )
 where
 
-import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Base64.URL as B64
 import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
-import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe)
 import Data.Word (Word16)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.Store.Types
-import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
+import Simplex.Messaging.Protocol (EntityId (..))
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.SystemTime
 import System.IO
 
 data NtfStoreLogRecord
@@ -49,11 +45,10 @@ data NtfStoreLogRecord
   | UpdateToken NtfTokenId DeviceToken NtfRegCode
   | TokenCron NtfTokenId Word16
   | DeleteToken NtfTokenId
-  | UpdateTokenTime NtfTokenId SystemDate
+  | UpdateTokenTime NtfTokenId RoundedSystemTime
   | CreateSubscription NtfSubRec
-  | SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
+  | SubscriptionStatus NtfSubscriptionId NtfSubStatus
   | DeleteSubscription NtfSubscriptionId
-  | SetNtfService SMPServer (Maybe ServiceId)
   deriving (Show)
 
 instance StrEncoding NtfStoreLogRecord where
@@ -65,11 +60,8 @@ instance StrEncoding NtfStoreLogRecord where
     DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
     UpdateTokenTime tknId ts -> strEncode (Str "TTIME", tknId, ts)
     CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
-    SubscriptionStatus subId subStatus serviceAssoc -> strEncode (Str "SSTATUS", subId, subStatus) <> serviceStr
-      where
-        serviceStr = if serviceAssoc then " service=" <> strEncode True else ""
+    SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
     DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
-    SetNtfService srv serviceId -> strEncode (Str "SERVICE", srv) <> " service=" <> maybe "off" strEncode serviceId
   strP =
     A.choice
       [ "TCREATE " *> (CreateToken <$> strP),
@@ -79,9 +71,8 @@ instance StrEncoding NtfStoreLogRecord where
         "TDELETE " *> (DeleteToken <$> strP),
         "TTIME " *> (UpdateTokenTime <$> strP_ <*> strP),
         "SCREATE " *> (CreateSubscription <$> strP),
-        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP <*> (fromMaybe False <$> optional (" service=" *> strP))),
-        "SDELETE " *> (DeleteSubscription <$> strP),
-        "SERVICE " *> (SetNtfService <$> strP <* " service=" <*> ("off" $> Nothing <|> strP))
+        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
+        "SDELETE " *> (DeleteSubscription <$> strP)
       ]
 
 logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
@@ -103,21 +94,18 @@ logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
 logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
 logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
 
-logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> SystemDate -> IO ()
+logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
 logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
 
 logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()
 logCreateSubscription s = logNtfStoreRecord s . CreateSubscription
 
-logSubscriptionStatus :: StoreLog 'WriteMode -> (NtfSubscriptionId, NtfSubStatus, NtfAssociatedService) -> IO ()
-logSubscriptionStatus s (subId, subStatus, serviceAssoc) = logNtfStoreRecord s $ SubscriptionStatus subId subStatus serviceAssoc
+logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
+logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
 
 logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
 logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
 
-logSetNtfService :: StoreLog 'WriteMode -> SMPServer -> Maybe ServiceId -> IO ()
-logSetNtfService s srv serviceId = logNtfStoreRecord s $ SetNtfService srv serviceId
-
 readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
 readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore
 
@@ -159,19 +147,13 @@ readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
               Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId
             where
               enc = B64.encode . unEntityId
-          SubscriptionStatus subId status serviceAssoc -> do
-            stmGetNtfSubscriptionIO st subId >>= mapM_ update
-            where
-              update NtfSubData {subStatus, ntfServiceAssoc} = atomically $ do
-                writeTVar subStatus status
-                writeTVar ntfServiceAssoc serviceAssoc
+          SubscriptionStatus subId status -> do
+            stmGetNtfSubscriptionIO st subId
+              >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
           DeleteSubscription subId ->
             atomically $ stmDeleteNtfSubscription st subId
-          SetNtfService srv serviceId ->
-            atomically $ stmSetNtfService st srv serviceId
 
 writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO ()
-writeNtfStore s NtfSTMStore {tokens, subscriptions, ntfServices} = do
+writeNtfStore s NtfSTMStore {tokens, subscriptions} = do
   mapM_ (logCreateToken s <=< mkTknRec) =<< readTVarIO tokens
   mapM_ (logCreateSubscription s <=< mkSubRec) =<< readTVarIO subscriptions
-  mapM_ (\(srv, serviceId) -> logSetNtfService s srv $ Just serviceId) . M.assocs =<< readTVarIO ntfServices

src/Simplex/Messaging/Notifications/Transport.hs

@@ -62,8 +62,8 @@ legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion
 supportedServerNTFVRange :: VersionRangeNTF
 supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
 
-alpnSupportedNTFHandshakes :: [ALPN]
-alpnSupportedNTFHandshakes = ["ntf/1"]
+supportedNTFHandshakes :: [ALPN]
+supportedNTFHandshakes = ["ntf/1"]
 
 type THandleNTF c p = THandle NTFVersion c p
 
@@ -110,7 +110,7 @@ instance Encoding NtfClientHandshake where
     pure NtfClientHandshake {ntfVersion, keyHash}
 
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
+ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
 ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   let sk = C.signX509 serverSignKey $ C.publicToX509 k
@@ -126,8 +126,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
             Nothing -> throwE TEVersion
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleNTF c 'TClient)
-ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
+ntfClientHandshake c keyHash ntfVRange _proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
   if sessionId /= sessId
@@ -137,7 +137,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
         ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
           serverKey <- getServerVerifyKey c
           pubKey <- C.verifyX509 serverKey signedKey
-          (,CertChainPubKey (getPeerCertChain c) signedKey) <$> C.x509ToPublic' pubKey
+          (,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
         let v = maxVersion vr
         sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
         pure $ ntfThHandleClient th v vr ck_
@@ -145,13 +145,12 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
 
 ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
 ntfThHandleServer th v vr pk =
-  let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
+  let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
    in ntfThHandle_ th v vr (Just thAuth)
 
-ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient
+ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
 ntfThHandleClient th v vr ck_ =
-  let thAuth = clientTHParams <$> ck_
-      clientTHParams (k, ck) = THAuthClient {peerServerPubKey = k, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
+  let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
    in ntfThHandle_ th v vr thAuth
 
 ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> VersionRangeNTF -> Maybe (THandleAuth p) -> THandleNTF c p
@@ -161,7 +160,7 @@ ntfThHandle_ th@THandle {params} v vr thAuth =
       params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
    in (th :: THandleNTF c p) {params = params'}
 
-ntfTHandle :: Transport c => c p -> THandleNTF c p
+ntfTHandle :: Transport c => c -> THandleNTF c p
 ntfTHandle c = THandle {connection = c, params}
   where
     v = VersionNTF 0
@@ -174,6 +173,5 @@ ntfTHandle c = THandle {connection = c, params}
           thAuth = Nothing,
           implySessId = False,
           encryptBlock = Nothing,
-          batch = False,
-          serviceAuth = False
+          batch = False
         }

src/Simplex/Messaging/Notifications/Types.hs

@@ -52,7 +52,7 @@ data NtfToken = NtfToken
     -- | key used by the ntf client to sign transmissions
     ntfPrivKey :: C.APrivateAuthKey,
     -- | client's DH keys (to repeat registration if necessary)
-    ntfDhKeys :: C.KeyPairX25519,
+    ntfDhKeys :: C.KeyPair 'C.X25519,
     -- | shared DH secret used to encrypt/decrypt notifications e2e
     ntfDhSecret :: Maybe C.DhSecretX25519,
     -- | token status
@@ -63,7 +63,7 @@ data NtfToken = NtfToken
   }
   deriving (Show)
 
-newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
+newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
 newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
   NtfToken
     { deviceToken,

src/Simplex/Messaging/Protocol/Types.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Simplex.Messaging.Protocol.Types where
-
-import qualified Data.Aeson.TH as J
-import Data.Int (Int64)
-import Simplex.Messaging.Parsers
-
-data ClientNotice = ClientNotice
-  { ttl :: Maybe Int64 -- seconds, Nothing - indefinite
-  }
-  deriving (Eq, Show)
-
-$(J.deriveJSON defaultJSON ''ClientNotice)

src/Simplex/Messaging/Server/CLI.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -33,10 +32,9 @@ 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 (..), dbStoreCfg, storeLogFile')
-import Simplex.Messaging.Server.Main.GitCommit
+import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..))
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
-import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
+import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -99,12 +97,6 @@ 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
 
@@ -371,7 +363,7 @@ checkSavedFingerprint cfgPath x509cfg = do
   where
     c = combine cfgPath . ($ x509cfg)
 
-iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
+iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
 iniTransports ini =
   let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
       ws = strictIni "TRANSPORT" "websockets" ini
@@ -381,7 +373,7 @@ iniTransports ini =
         | otherwise = ports ws \\ smpPorts
    in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
   where
-    ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
+    ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
     ts t = map (\port -> (port, t, webPort == Just port))
     webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
     ports = map T.unpack . T.splitOn ","
@@ -395,14 +387,14 @@ iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
       createSchema = False
     }
 
-printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
+printServerConfig :: String -> [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
 printServerConfig protocol transports logFile = do
   putStrLn $ case logFile of
     Just f -> "Store log: " <> f
     _ -> "Store log disabled."
   printServerTransports protocol transports
 
-printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
+printServerTransports :: String -> [(ServiceName, ATransport, AddHTTP)] -> IO ()
 printServerTransports protocol ts = do
   forM_ ts $ \(p, ATransport t, addHTTP) -> do
     let descr = p <> " (" <> transportName t <> ")..."
@@ -413,14 +405,13 @@ printServerTransports protocol ts = do
       "\nWARNING: the clients will use port 443 by default soon.\n\
       \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
 
-printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
-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
+printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
+printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
+  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
 
 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, Show)
+  deriving (Eq)
 
 data ControlProtocol
   = CPAuth BasicAuth

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

@@ -21,8 +21,7 @@
 module Simplex.Messaging.Server.Env.STM
   ( ServerConfig (..),
     ServerStoreCfg (..),
-    -- AServerStoreCfg (..),
-    SupportedStore,
+    AServerStoreCfg (..),
     StorePaths (..),
     StartOptions (..),
     Env (..),
@@ -31,20 +30,17 @@ module Simplex.Messaging.Server.Env.STM
     SubscribedClients,
     ProxyAgent (..),
     Client (..),
+    AClient (..),
     ClientId,
-    ClientSub (..),
+    Subscribed,
     Sub (..),
     ServerSub (..),
     SubscriptionThread (..),
-    MsgStoreType,
-    MsgStore (..),
+    MsgStore,
+    AMsgStore (..),
     AStoreType (..),
-    VerifiedTransmission,
-    ResponseAndMessage,
     newEnv,
     mkJournalStoreConfig,
-    msgStore,
-    fromMsgStore,
     newClient,
     getServerClients,
     getServerClient,
@@ -53,11 +49,11 @@ module Simplex.Messaging.Server.Env.STM
     getSubscribedClients,
     getSubscribedClient,
     upsertSubscribedClient,
-    lookupSubscribedClient,
     lookupDeleteSubscribedClient,
     deleteSubcribedClient,
     sameClientId,
     sameClient,
+    clientId',
     newSubscription,
     newProhibitedSub,
     defaultMsgQueueQuota,
@@ -72,10 +68,7 @@ module Simplex.Messaging.Server.Env.STM
     defaultIdleQueueInterval,
     journalMsgStoreDepth,
     readWriteQueueStore,
-    noPostgresExitStr,
     noPostgresExit,
-    dbStoreCfg,
-    storeLogFile',
   )
 where
 
@@ -84,6 +77,7 @@ import Control.Logger.Simple
 import Control.Monad
 import qualified Crypto.PubKey.RSA as RSA
 import Crypto.Random
+import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
@@ -123,10 +117,9 @@ import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Server.StoreLog.ReadWrite
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP)
+import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util (ifM, whenM, ($>>=))
 import System.Directory (doesFileExist)
@@ -135,12 +128,8 @@ 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)],
+data ServerConfig = ServerConfig
+  { transports :: [(ServiceName, ATransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     msgQueueQuota :: Int,
@@ -148,7 +137,7 @@ data ServerConfig s = ServerConfig
     maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    serverStoreCfg :: ServerStoreCfg s,
+    serverStoreCfg :: AServerStoreCfg,
     storeNtfsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
@@ -157,11 +146,9 @@ 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)
@@ -258,13 +245,13 @@ defaultMsgQueueQuota = 128
 defaultStateTailSize :: Int
 defaultStateTailSize = 512
 
-data Env s = Env
-  { config :: ServerConfig s,
+data Env = Env
+  { config :: ServerConfig,
     serverActive :: TVar Bool,
     serverInfo :: ServerInformation,
-    server :: Server s,
+    server :: Server,
     serverIdentity :: KeyHash,
-    msgStore_ :: MsgStore s,
+    msgStore :: AMsgStore,
     ntfStore :: NtfStore,
     random :: TVar ChaChaDRG,
     tlsServerCreds :: T.Credential,
@@ -275,96 +262,48 @@ data Env s = Env
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
-msgStore :: Env s -> s
-msgStore = fromMsgStore . msgStore_
-{-# INLINE msgStore #-}
-
-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 '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 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
+  SupportedStore 'QSPostgres 'MSMemory =
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported"))
 
-data AStoreType =
-  forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
-  ASType (SQSType qs) (SMSType ms)
+data AStoreType = forall qs ms. SupportedStore qs ms => ASType (SQSType qs) (SMSType ms)
 
-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 ServerStoreCfg qs ms where
+  SSCMemory :: Maybe StorePaths -> ServerStoreCfg 'QSMemory 'MSMemory
+  SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg 'QSMemory 'MSJournal
+  SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal
 
 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 AServerStoreCfg = forall qs ms. SupportedStore qs ms => ASSCfg (SQSType qs) (SMSType ms) (ServerStoreCfg qs ms)
 
-data MsgStore s where
-  StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
-  StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
-#if defined(dbServerPostgres)
-  StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore
-#endif
+type family MsgStore (qs :: QSType) (ms :: MSType) where
+  MsgStore 'QSMemory 'MSMemory = STMMsgStore
+  MsgStore qs 'MSJournal = JournalMsgStore qs
 
-data Server s = Server
-  { clients :: ServerClients s,
-    subscribers :: ServerSubscribers s,
-    ntfSubscribers :: ServerSubscribers s,
+data AMsgStore =
+  forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStore qs ms)) =>
+  AMS (SQSType qs) (SMSType ms) (MsgStore qs ms)
+
+type Subscribed = Bool
+
+data Server = Server
+  { clients :: ServerClients,
+    subscribers :: ServerSubscribers,
+    ntfSubscribers :: ServerSubscribers,
     savingLock :: Lock
   }
 
 -- not exported, to prevent concurrent IntMap lookups inside STM transactions.
-newtype ServerClients s = ServerClients {serverClients :: TVar (IntMap (Client s))}
+newtype ServerClients = ServerClients {serverClients :: TVar (IntMap AClient)}
 
-data ServerSubscribers s = ServerSubscribers
-  { subQ :: TQueue (ClientSub, ClientId),
-    queueSubscribers :: SubscribedClients s,
-    serviceSubscribers :: SubscribedClients s, -- service clients with long-term certificates that have subscriptions
-    totalServiceSubs :: TVar Int64,
-    subClients :: TVar IntSet, -- clients with individual or service subscriptions
+data ServerSubscribers = ServerSubscribers
+  { subQ :: TQueue (QueueId, ClientId, Subscribed),
+    queueSubscribers :: SubscribedClients,
+    subClients :: TVar IntSet,
     pendingEvents :: TVar (IntMap (NonEmpty (EntityId, BrokerMsg)))
   }
 
@@ -375,36 +314,31 @@ data ServerSubscribers s = ServerSubscribers
 -- any STM transaction that reads subscribed client will re-evaluate in this case.
 -- The subscriptions that were made at any point are not removed -
 -- this is a better trade-off with intermittently connected mobile clients.
-data SubscribedClients s = SubscribedClients (TMap EntityId (TVar (Maybe (Client s))))
+data SubscribedClients = SubscribedClients (TMap EntityId (TVar (Maybe AClient)))
 
-getSubscribedClients :: SubscribedClients s -> IO (Map EntityId (TVar (Maybe (Client s))))
+getSubscribedClients :: SubscribedClients -> IO (Map EntityId (TVar (Maybe AClient)))
 getSubscribedClients (SubscribedClients cs) = readTVarIO cs
 
-getSubscribedClient :: EntityId -> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
+getSubscribedClient :: EntityId -> SubscribedClients -> IO (Maybe (TVar (Maybe AClient)))
 getSubscribedClient entId (SubscribedClients cs) = TM.lookupIO entId cs
 {-# INLINE getSubscribedClient #-}
 
 -- insert subscribed and current client, return previously subscribed client if it is different
-upsertSubscribedClient :: EntityId -> Client s -> SubscribedClients s -> STM (Maybe (Client s))
-upsertSubscribedClient entId c (SubscribedClients cs) =
+upsertSubscribedClient :: EntityId -> AClient -> SubscribedClients -> STM (Maybe AClient)
+upsertSubscribedClient entId ac@(AClient _ _ c) (SubscribedClients cs) =
   TM.lookup entId cs >>= \case
-    Nothing -> Nothing <$ TM.insertM entId (newTVar (Just c)) cs
+    Nothing -> Nothing <$ TM.insertM entId (newTVar (Just ac)) cs
     Just cv ->
       readTVar cv >>= \case
         Just c' | sameClientId c c' -> pure Nothing
-        c_ -> c_ <$ writeTVar cv (Just c)
-
-lookupSubscribedClient :: EntityId -> SubscribedClients s -> STM (Maybe (Client s))
-lookupSubscribedClient entId (SubscribedClients cs) = TM.lookup entId cs $>>= readTVar
-{-# INLINE lookupSubscribedClient #-}
+        c_ -> c_ <$ writeTVar cv (Just ac)
 
 -- lookup and delete currently subscribed client
-lookupDeleteSubscribedClient :: EntityId -> SubscribedClients s -> STM (Maybe (Client s))
+lookupDeleteSubscribedClient :: EntityId -> SubscribedClients -> STM (Maybe AClient)
 lookupDeleteSubscribedClient entId (SubscribedClients cs) =
   TM.lookupDelete entId cs $>>= (`swapTVar` Nothing)
-{-# INLINE lookupDeleteSubscribedClient #-}
 
-deleteSubcribedClient :: EntityId -> Client s -> SubscribedClients s -> IO ()
+deleteSubcribedClient :: EntityId -> Client s -> SubscribedClients -> IO ()
 deleteSubcribedClient entId c (SubscribedClients cs) =
   -- lookup of the subscribed client TVar can be in separate transaction,
   -- as long as the client is read in the same transaction -
@@ -415,60 +349,54 @@ deleteSubcribedClient entId c (SubscribedClients cs) =
       writeTVar cv Nothing
       TM.delete entId cs
 
-sameClientId :: Client s -> (Client s) -> Bool
-sameClientId c c' = clientId c == clientId c'
+sameClientId :: Client s -> AClient -> Bool
+sameClientId Client {clientId} ac = clientId == clientId' ac
 {-# INLINE sameClientId #-}
 
-sameClient :: Client s -> TVar (Maybe (Client s)) -> STM Bool
+sameClient :: Client s -> TVar (Maybe AClient) -> STM Bool
 sameClient c cv = maybe False (sameClientId c) <$> readTVar cv
 {-# INLINE sameClient #-}
 
-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 Int64 -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB
-
 newtype ProxyAgent = ProxyAgent
-  { smpAgent :: SMPClientAgent 'Sender
+  { smpAgent :: SMPClientAgent
   }
 
 type ClientId = Int
 
+data AClient = forall qs ms. MsgStoreClass (MsgStore qs ms) => AClient (SQSType qs) (SMSType ms) (Client (MsgStore qs ms))
+
+clientId' :: AClient -> ClientId
+clientId' (AClient _ _ Client {clientId}) = clientId
+{-# INLINE clientId' #-}
+
 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), [Transmission BrokerMsg]),
+    rcvQ :: TBQueue (NonEmpty (Maybe (StoreQueue s, QueueRec), Transmission Cmd)),
+    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
     endThreads :: TVar (IntMap (Weak ThreadId)),
     endThreadSeq :: TVar Int,
-    clientTHParams :: THandleParams SMPVersion 'TServer,
+    thVersion :: VersionSMP,
+    sessionId :: ByteString,
     connected :: TVar Bool,
     createdAt :: SystemTime,
     rcvActiveAt :: TVar SystemTime,
     sndActiveAt :: TVar SystemTime
   }
 
-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 :: TVar (Maybe (MsgId, SystemSeconds))
+    delivered :: TMVar MsgId
   }
 
-newServer :: IO (Server s)
+newServer :: IO Server
 newServer = do
   clients <- ServerClients <$> newTVarIO mempty
   subscribers <- newServerSubscribers
@@ -476,45 +404,39 @@ newServer = do
   savingLock <- createLockIO
   return Server {clients, subscribers, ntfSubscribers, savingLock}
 
-getServerClients :: Server s -> IO (IntMap (Client s))
+getServerClients :: Server -> IO (IntMap AClient)
 getServerClients = readTVarIO . serverClients . clients
 {-# INLINE getServerClients #-}
 
-getServerClient :: ClientId -> Server s -> IO (Maybe (Client s))
+getServerClient :: ClientId -> Server -> IO (Maybe AClient)
 getServerClient cId s = IM.lookup cId <$> getServerClients s
 {-# INLINE getServerClient #-}
 
-insertServerClient :: Client s -> Server s -> IO Bool
-insertServerClient c@Client {clientId, connected} Server {clients} =
+insertServerClient :: AClient -> Server -> IO Bool
+insertServerClient ac@(AClient _ _ Client {clientId, connected}) Server {clients} =
   atomically $
     ifM
       (readTVar connected)
-      (True <$ modifyTVar' (serverClients clients) (IM.insert clientId c))
+      (True <$ modifyTVar' (serverClients clients) (IM.insert clientId ac))
       (pure False)
 {-# INLINE insertServerClient #-}
 
-deleteServerClient :: ClientId -> Server s -> IO ()
+deleteServerClient :: ClientId -> Server -> IO ()
 deleteServerClient cId Server {clients} = atomically $ modifyTVar' (serverClients clients) $ IM.delete cId
 {-# INLINE deleteServerClient #-}
 
-newServerSubscribers :: IO (ServerSubscribers s)
+newServerSubscribers :: IO ServerSubscribers
 newServerSubscribers = do
   subQ <- newTQueueIO
   queueSubscribers <- SubscribedClients <$> TM.emptyIO
-  serviceSubscribers <- SubscribedClients <$> TM.emptyIO
-  totalServiceSubs <- newTVarIO 0
   subClients <- newTVarIO IS.empty
   pendingEvents <- newTVarIO IM.empty
-  pure ServerSubscribers {subQ, queueSubscribers, serviceSubscribers, totalServiceSubs, subClients, pendingEvents}
+  pure ServerSubscribers {subQ, queueSubscribers, subClients, pendingEvents}
 
-newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s)
-newClient clientId qSize clientTHParams createdAt = do
+newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms))
+newClient _ _ clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
-  serviceSubscribed <- newTVarIO False
-  ntfServiceSubscribed <- newTVarIO False
-  serviceSubsCount <- newTVarIO 0
-  ntfServiceSubsCount <- newTVarIO 0
   rcvQ <- newTBQueueIO qSize
   sndQ <- newTBQueueIO qSize
   msgQ <- newTBQueueIO qSize
@@ -529,17 +451,14 @@ newClient clientId qSize clientTHParams createdAt = do
       { clientId,
         subscriptions,
         ntfSubscriptions,
-        serviceSubscribed,
-        ntfServiceSubscribed,
-        serviceSubsCount,
-        ntfServiceSubsCount,
         rcvQ,
         sndQ,
         msgQ,
         procThreads,
         endThreads,
         endThreadSeq,
-        clientTHParams,
+        thVersion,
+        sessionId,
         connected,
         createdAt,
         rcvActiveAt,
@@ -548,49 +467,41 @@ newClient clientId qSize clientTHParams createdAt = do
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
-  delivered <- newTVar Nothing
+  delivered <- newEmptyTMVar
   subThread <- ServerSub <$> newTVar st
   return Sub {subThread, delivered}
 
 newProhibitedSub :: STM Sub
 newProhibitedSub = do
-  delivered <- newTVar Nothing
+  delivered <- newEmptyTMVar
   return Sub {subThread = ProhibitSub, delivered}
 
-newEnv :: ServerConfig s -> IO (Env s)
+newEnv :: ServerConfig -> IO Env
 newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
   serverActive <- newTVarIO True
   server <- newServer
-  msgStore_ <- case serverStoreCfg of
-    SSCMemory storePaths_ -> do
+  msgStore <- case serverStoreCfg of
+    ASSCfg qt mt (SSCMemory storePaths_) -> do
       let storePath = storeMsgsFile =<< storePaths_
       ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota}
       forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms
-      pure $ StoreMemory ms
-    SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
-      logWarn $
-        "Journal message store is deprecated and will be removed soon.\n"
-          <> "Please migrate to in-memory storage using `journal export` command.\n"
-          <> "After that you can migrate to PostgreSQL using `database import` command."
+      pure $ AMS qt mt ms
+    ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
       let qsCfg = MQStoreCfg
           cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
       ms <- newMsgStore cfg
       loadStoreLog (mkQueue ms True) storeLogFile $ stmQueueStore ms
-      pure $ StoreJournal ms
+      pure $ AMS qt mt ms
 #if defined(dbServerPostgres)
-    SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
+    ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
       let StartOptions {compactLog, confirmMigrations} = startOptions config
           qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
           cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
       when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
-      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
+      ms <- newMsgStore cfg
+      pure $ AMS qt mt ms
 #else
-    SSCDatabaseJournal {} -> noPostgresExit
+    ASSCfg _ _ SSCDatabaseJournal {} -> noPostgresExit
 #endif
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
@@ -610,7 +521,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
         serverInfo,
         server,
         serverIdentity,
-        msgStore_,
+        msgStore,
         ntfStore,
         random,
         tlsServerCreds,
@@ -675,19 +586,17 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
         }
       where
         persistence = case serverStoreCfg of
-          SSCMemory sp_ -> case sp_ of
+          ASSCfg _ _ (SSCMemory sp_) -> case sp_ of
             Nothing -> SPMMemoryOnly
             Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
             _ -> SPMQueues
           _ -> SPMMessages
 
 noPostgresExit :: IO a
-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`."
+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
 
 mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
 mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
@@ -706,8 +615,8 @@ mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount ma
 
 newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
-  smpAgent <- newSMPClientAgent SSender smpAgentCfg random
+  smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}
 
-readWriteQueueStore :: forall q. StoreQueueClass q => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO (StoreLog 'WriteMode)
+readWriteQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO (StoreLog 'WriteMode)
 readWriteQueueStore tty mkQ = readWriteStoreLog (readQueueStore tty mkQ) (writeQueueStore @q)

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 (ConnectionLink, ConnectionMode (..))
+import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri)
 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 (ConnectionLink 'CMContact),
+  { simplex :: Maybe (ConnectionRequestUri '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

@@ -2,7 +2,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -18,10 +17,9 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
-import Control.Exception (SomeException, finally, try)
+import Control.Exception (finally)
 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)
@@ -31,17 +29,16 @@ import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.Int (Int64)
 import Data.List (find, isPrefixOf)
 import qualified Data.List.NonEmpty as L
-import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 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 (ConnectionLink (..), connReqUriP')
+import Simplex.Messaging.Agent.Protocol (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)
+import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -57,15 +54,14 @@ 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 (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, 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, unlessM)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
+import Simplex.Messaging.Util (eitherToMaybe, ifM)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
-import System.IO (BufferMode (..), IOMode (..), hSetBuffering, stderr, stdout, withFile)
+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 #if defined(dbServerPostgres)
@@ -74,11 +70,9 @@ 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.Postgres (batchInsertQueues, foldQueueRecs)
 import Simplex.Messaging.Server.QueueStore.Types
-import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
+import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue, openWriteStoreLog)
 import System.Directory (renameFile)
 #endif
 
@@ -131,7 +125,6 @@ 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
@@ -143,31 +136,19 @@ 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 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"
+                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) -> 
 #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
-                Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
+                  noPostgresExit
 #endif
                 Left e -> putStrLn $ e <> ", configure storage correctly"
         SCDelete
@@ -180,33 +161,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 "Messages NOT deleted"
               deleteDirIfExists storeMsgsJournalDir
               putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
-#if defined(dbServerPostgres)
-    Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+#if defined(dbServerPostgres)              
+    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
       schemaExists <- checkSchemaExists connstr schema
       storeLogExists <- doesFileExist storeLogFilePath
-      msgsFileExists <- doesFileExist storeMsgsFilePath
-      case (cmd, tables) of
-        (SCImport, DTAll)
-          | not schemaExists && storeLogExists && msgsFileExists -> do
-              storeLogFile <- getRequiredStoreLogFile ini
-              confirmOrExit
-                ("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
-                "Store logs not imported"
-              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
-              putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
-              putStrLn "Importing messages..."
-              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 to `database` in INI file"
-                Left e -> e <> ", configure storage correctly"
-          | otherwise -> do
-              when schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
-              unless storeLogExists $ putStrLn $ storeLogFilePath <> " file does not exist."
-              unless msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file does not exist."
-              exitFailure
-        (SCImport, DTQueues)
+      case cmd of
+        SCImport
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
@@ -219,53 +179,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               confirmOrExit
                 ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
                 "Queue records not imported"
-              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
-              putStrLn $ "Import completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
+              qCnt <- importStoreLogToDatabase logPath storeLogFile dbOpts
+              putStrLn $ "Import completed: " <> show qCnt <> " queues"
               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 _) -> "store_queues set to `database`, start the server."
+                Right (ASType SQSPostgres SMSJournal) -> "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"
-        (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 to `database` in INI file"
-                Left e -> e <> ", configure storage correctly"
-        (SCExport, DTAll)
-          | schemaExists && not storeLogExists && not msgsFileExists -> do
-              confirmOrExit
-                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
-                "Database store not exported"
-              (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
-              putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
-              putStrLn "Exporting messages..."
-              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 -> putStrLn $ "Export completed: " <> show mCnt <> " messages"
-                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
-              closeMsgStore ms
-          | otherwise -> do
-              unless schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
-              when storeLogExists $ putStrLn $ storeLogFilePath <> " file already exists."
-              when msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file already exists."
-              exitFailure
-        (SCExport, DTQueues)
+        SCExport
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
@@ -275,34 +199,15 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               exitFailure
           | otherwise -> do
               confirmOrExit
-                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                ("WARNING: PostrgreSQL database 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"
+              qCnt <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
+              putStrLn $ "Export completed: " <> show qCnt <> " queues"
               putStrLn $ case readStoreType ini of
-                Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
+                Right (ASType SQSPostgres SMSJournal) -> "store_queues 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"
-        (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
-              closeMsgStore ms
-        (SCDelete, _)
+        SCDelete
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
               exitFailure
@@ -326,7 +231,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" <> simplexmqVersionCommit
+    serverVersion = "SMP server v" <> simplexMQVersion
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
     storeMsgsFilePath = combine logPath "smp-server-messages.log"
@@ -336,14 +241,8 @@ 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
-#if defined(dbServerPostgres)
-      ("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
-#else
-      ("database", "database") -> Left noPostgresExitStr
-#endif
+      ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
       (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
       where
         iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
@@ -424,58 +323,54 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       setLogLevel $ logLevel startOptions
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
-      run iniStoreType
+      fp <- checkSavedFingerprint cfgPath defaultX509Config
+      let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
+          port = T.unpack $ strictIni "TRANSPORT" "port" ini
+          cfg@ServerConfig {information, serverStoreCfg, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
+          sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
+          srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
+      printServiceInfo serverVersion srv
+      printSourceCode sourceCode'
+      printSMPServerConfig transports serverStoreCfg
+      checkMsgStoreMode ini iniStoreType
+      putStrLn $ case messageExpiration of
+        Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
+        _ -> "not expiring messages"
+      putStrLn $ case inactiveClientExpiration of
+        Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
+        _ -> "not expiring inactive clients"
+      putStrLn $
+        "creating new queues "
+          <> if allowNewQueues cfg
+            then maybe "allowed" (const "requires password") newQueueBasicAuth
+            else "NOT allowed"
+      -- print information
+      let persistence = case serverStoreCfg of
+            ASSCfg _ _ (SSCMemory Nothing) -> SPMMemoryOnly
+            ASSCfg _ _ (SSCMemory (Just StorePaths {storeMsgsFile})) | isNothing storeMsgsFile -> SPMQueues
+            _ -> SPMMessages
+      let config =
+            ServerPublicConfig
+              { persistence,
+                messageExpiration = ttl <$> messageExpiration,
+                statsEnabled = isJust logStats,
+                newQueuesAllowed = allowNewQueues cfg,
+                basicAuthEnabled = isJust newQueueBasicAuth
+              }
+      case webStaticPath' of
+        Just path | sharedHTTP -> do
+          runWebServer path Nothing ServerInformation {config, information}
+          attachStaticFiles path $ \attachHTTP -> do
+            logDebug "Allocated web server resources"
+            runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
+        Just path -> do
+          runWebServer path webHttpsParams' ServerInformation {config, information}
+          runSMPServer cfg Nothing
+        Nothing -> do
+          logWarn "No server static path set"
+          runSMPServer cfg Nothing
+      logDebug "Bye"
       where
-        run :: AStoreType -> IO ()
-        run (ASType qs ms) = do
-          fp <- checkSavedFingerprint cfgPath defaultX509Config
-          let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
-              port = T.unpack $ strictIni "TRANSPORT" "port" ini
-              serverStoreCfg = iniStoreCfg qs ms
-              cfg@ServerConfig {information, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig serverStoreCfg
-              sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
-              srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
-          printServiceInfo serverVersion srv
-          printSourceCode sourceCode'
-          printSMPServerConfig transports serverStoreCfg
-          checkMsgStoreMode ini iniStoreType
-          putStrLn $ case messageExpiration of
-            Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
-            _ -> "not expiring messages"
-          putStrLn $ case inactiveClientExpiration of
-            Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
-            _ -> "not expiring inactive clients"
-          putStrLn $
-            "creating new queues "
-              <> if allowNewQueues cfg
-                then maybe "allowed" (const "requires password") newQueueBasicAuth
-                else "NOT allowed"
-          -- print information
-          let persistence = case serverStoreCfg of
-                SSCMemory Nothing -> SPMMemoryOnly
-                SSCMemory (Just StorePaths {storeMsgsFile}) | isNothing storeMsgsFile -> SPMQueues
-                _ -> SPMMessages
-          let config =
-                ServerPublicConfig
-                  { persistence,
-                    messageExpiration = ttl <$> messageExpiration,
-                    statsEnabled = isJust logStats,
-                    newQueuesAllowed = allowNewQueues cfg,
-                    basicAuthEnabled = isJust newQueueBasicAuth
-                  }
-          case webStaticPath' of
-            Just path | sharedHTTP -> do
-              runWebServer path Nothing ServerInformation {config, information}
-              attachStaticFiles path $ \attachHTTP -> do
-                logDebug "Allocated web server resources"
-                runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
-            Just path -> do
-              runWebServer path webHttpsParams' ServerInformation {config, information}
-              runSMPServer cfg Nothing
-            Nothing -> do
-              logWarn "No server static path set"
-              runSMPServer cfg Nothing
-          logDebug "Bye"
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
         restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of
@@ -486,21 +381,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
         iniStoreType = either error id $! readStoreType ini
-        iniStoreCfg :: SupportedStore qs ms => SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
-        iniStoreCfg SQSMemory SMSMemory = SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
-        iniStoreCfg SQSMemory SMSJournal = SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
-        iniStoreCfg SQSPostgres SMSJournal =
-          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 =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
@@ -517,21 +398,27 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     certificateFile = c serverCrtFile
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
-              serverStoreCfg,
+              serverStoreCfg = case iniStoreType of
+                ASType SQSMemory SMSMemory ->
+                  ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
+                ASType SQSMemory SMSJournal ->
+                  ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
+                ASType SQSPostgres SMSJournal ->
+                  let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+                      storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+                   in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir},
               storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
               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
@@ -550,13 +437,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
               prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
               pendingENDInterval = 15000000, -- 15 seconds
-              ntfDeliveryInterval = 1500000, -- 1.5 second
+              ntfDeliveryInterval = 3000000, -- 3 seconds
               smpServerVRange = supportedServerSMPRelayVRange,
               transportConfig =
-                mkTransportServerConfig
-                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just $ alpnSupportedSMPHandshakes <> httpALPN)
-                  (fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
+                defaultTransportServerConfig
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+                  },
               controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
@@ -570,8 +456,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                               { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
                                 socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
                                 hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
-                                requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini,
-                                smpWebPortServers = SWPOff
+                                requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
                               }
                         },
                     ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
@@ -608,14 +493,6 @@ 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
@@ -628,7 +505,28 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               SQSMemory ->
                 unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
 #if defined(dbServerPostgres)
-              SQSPostgres -> checkDbStorage ini storeLogExists
+              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
 #else
               SQSPostgres -> noPostgresExit
 #endif
@@ -646,73 +544,31 @@ 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."
       exitFailure
 
-importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
+importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO Int64
 importStoreLogToDatabase logPath storeLogFile dbOpts = do
   ms <- newJournalMsgStore logPath MQStoreCfg
-  let st = stmQueueStore ms
-  sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
+  sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile (queueStore ms)
   closeStoreLog sl
-  queues <- readTVarIO $ loadedQueues st
-  services' <- M.elems <$> readTVarIO (services st)
+  queues <- readTVarIO $ loadedQueues $ stmQueueStore ms
   let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
   ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
-  sCnt <- batchInsertServices services' $ postgresQueueStore ps
   qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
   renameFile storeLogFile $ storeLogFile <> ".bak"
-  pure (sCnt, qCnt)
+  pure 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 :: FilePath -> DBOpts -> FilePath -> IO 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) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
+  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
   closeStoreLog sl
-  pure (sCnt, qCnt)
+  pure qCnt
 #endif
 
 newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
@@ -768,8 +624,7 @@ 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 linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
-          linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
+      let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
           email = infoValue emailField
           pkURI_ = infoValue pgpKeyUriField
           pkFingerprint_ = infoValue pgpKeyFingerprintField
@@ -796,24 +651,10 @@ data CliCommand
   | Start StartOptions
   | Delete
   | Journal StoreCmd
-  | Database StoreCmd DatabaseTable DBOpts
+  | Database StoreCmd DBOpts 
 
 data StoreCmd = SCImport | SCExport | SCDelete
 
-data DatabaseTable = DTQueues | DTMessages | DTAll
-
-instance StrEncoding DatabaseTable where
-  strEncode = \case
-    DTQueues -> "queues"
-    DTMessages -> "messages"
-    DTAll -> "all"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "queues" -> pure DTQueues
-      "messages" -> pure DTMessages
-      "all" -> pure DTAll
-      _ -> fail "DatabaseTable"
-
 cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
@@ -822,7 +663,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 <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -952,7 +793,7 @@ cliCommandP cfgPath logPath iniFile =
             sourceCode = T.pack <$> sourceCode,
             serverInfo =
               ServerPublicInfo
-                { sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode,
+                { sourceCode = T.pack simplexmqSource,
                   usageConditions = Nothing,
                   operator = fst operator_,
                   website,
@@ -976,14 +817,6 @@ 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"
-            <> value DTAll
-        )
     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

@@ -1,17 +0,0 @@
-{-# 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,13 +87,12 @@ 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_send: off\n"
+    <> "expire_messages_on_start: on\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: 60\n\n\
+        \# prometheus_interval: 300\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\
@@ -108,11 +107,8 @@ 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")
-    <> "# 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\
+    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\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 (msgQueue'), -- msgQueue' is used in tests
+    JournalQueue,
     JournalMsgQueue (queue, state),
     JMQueue (queueDirectory, statePath),
     JournalStoreConfig (..),
@@ -38,7 +38,6 @@ module Simplex.Messaging.Server.MsgStore.Journal
     msgQueueStatePath,
     readQueueState,
     newMsgQueueState,
-    getJournalQueueMessages,
     newJournalId,
     appendState,
     queueLogFileName,
@@ -59,15 +58,14 @@ 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, partitionEithers)
+import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (sort)
+import Data.List (intercalate, sort)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
@@ -84,7 +82,6 @@ import Simplex.Messaging.Server.QueueStore.Postgres
 #endif
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.QueueStore.Types
-import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>))
@@ -292,11 +289,14 @@ 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 #-}
-  withQueueLock :: JournalQueue s -> Text -> IO a -> IO a
+  msgQueue = msgQueue'
+  {-# INLINE msgQueue #-}
+  withQueueLock :: JournalQueue s -> String -> IO a -> IO a
   withQueueLock JournalQueue {recipientId', queueLock, sharedLock} =
     withLockWaitShared recipientId' queueLock sharedLock
   {-# INLINE withQueueLock #-}
@@ -308,7 +308,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, True)
+    PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg
 #endif
 
   closeQueueStore = withQS (closeQueueStore @(JournalQueue s))
@@ -317,14 +317,12 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
   {-# INLINE loadedQueues #-}
   compactQueues = withQS (compactQueues @(JournalQueue s))
   {-# INLINE compactQueues #-}
-  getEntityCounts = withQS (getEntityCounts @(JournalQueue s))
-  {-# INLINE getEntityCounts #-}
+  queueCounts = withQS (queueCounts @(JournalQueue s))
+  {-# INLINE queueCounts #-}
   addQueue_ = withQS addQueue_
   {-# INLINE addQueue_ #-}
   getQueue_ = withQS getQueue_
   {-# INLINE getQueue_ #-}
-  getQueues_ = withQS getQueues_
-  {-# INLINE getQueues_ #-}
   addQueueLinkData = withQS addQueueLinkData
   {-# INLINE addQueueLinkData #-}
   getQueueLinkData = withQS getQueueLinkData
@@ -349,14 +347,6 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
   {-# INLINE updateQueueTime #-}
   deleteStoreQueue = withQS deleteStoreQueue
   {-# INLINE deleteStoreQueue #-}
-  getCreateService = withQS (getCreateService @(JournalQueue s))
-  {-# INLINE getCreateService #-}
-  setQueueService = withQS setQueueService
-  {-# INLINE setQueueService #-}
-  getQueueNtfServices = withQS (getQueueNtfServices @(JournalQueue s))
-  {-# INLINE getQueueNtfServices #-}
-  getServiceQueueCount = withQS (getServiceQueueCount @(JournalQueue s))
-  {-# INLINE getServiceQueueCount #-}
 
 makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s)
 makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do
@@ -377,7 +367,6 @@ 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
@@ -388,7 +377,7 @@ instance MsgStoreClass (JournalMsgStore s) where
     queueLocks <- TM.emptyIO
     sharedLock <- newEmptyTMVarIO
     queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg
-    openedQueueCount <- newTVarIO 0
+    openedQueueCount <- newTVarIO 0 
     expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime
     pure JournalMsgStore {config, random, queueLocks, sharedLock, queueStore_, openedQueueCount, expireBackupsBefore}
 
@@ -405,11 +394,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 -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
-  unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of
-    MQStore st -> withLoadedQueues st run
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
+  unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of
+    MQStore st -> withLoadedQueues st run 
 #if defined(dbServerPostgres)
-    PQStore st -> foldQueueRecs False tty st $ uncurry (mkQueue ms False) >=> run
+    PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkQueue ms False) >=> run
 #endif
     where
       run q = do
@@ -421,7 +410,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 ms q "deleteExpiredMsgs" $ do
+      withLoadedQueues st $ \q -> run $ isolateQueue q "deleteExpiredMsgs" $ do
         StoreIO (readTVarIO $ queueRec q) >>= \case
           Just QueueRec {updatedAt = Just (RoundedSystemTime t)} | t > veryOld ->
             expireQueueMsgs ms now old q
@@ -429,7 +418,7 @@ instance MsgStoreClass (JournalMsgStore s) where
 #if defined(dbServerPostgres)
     PQStore st -> do
       let JournalMsgStore {queueLocks, sharedLock} = ms
-      foldRecentQueueRecs veryOld tty st $ \(rId, qr) -> do
+      foldQueueRecs tty False st (Just veryOld) $ \(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 +474,7 @@ instance MsgStoreClass (JournalMsgStore s) where
     where
       newQ = do
         let dir = msgQueueDirectory ms rId
-            statePath = msgQueueStatePath dir rId
+            statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
             queue = JMQueue {queueDirectory = dir, statePath}
         q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue)
         atomically $ writeTVar msgQueue' $ Just q
@@ -563,9 +552,8 @@ 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 $ if drainMsgs then run [] else readTVarIO (state q) >>= runFast
+  getQueueMessages_ drainMsgs q' q = StoreIO (run [])
     where
       run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
       getMsg msgs hs = chooseReadJournal q' q drainMsgs hs >>= maybe (pure msgs) readMsg
@@ -574,19 +562,9 @@ 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 ms q' "writeMsg" $ do
+  writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do
     q <- getMsgQueue ms q' True
     StoreIO $ (`E.finally` updateActiveAt q') $ do
       st@MsgQueueState {canWrite, size} <- readTVarIO (state q)
@@ -660,28 +638,28 @@ instance MsgStoreClass (JournalMsgStore s) where
         $>>= \len -> readTVarIO handles
         $>>= \hs -> updateReadPos q mq logState len hs $> Just ()
 
-  isolateQueue :: JournalMsgStore s -> JournalQueue s -> Text -> StoreIO s a -> ExceptT ErrorType IO a
-  isolateQueue _ sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO
+  isolateQueue :: JournalQueue s -> String -> 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 :: JournalQueue s -> String -> StoreIO s a -> IO a
   unsafeRunStore sq op a =
     unStoreIO a `E.catch` \e -> storeError op (recipientId' sq) e >> E.throwIO e
 
 updateActiveAt :: JournalQueue s -> IO ()
 updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime
 
-tryStore' :: Text -> RecipientId -> IO a -> ExceptT ErrorType IO a
+tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
 tryStore' op rId = tryStore op rId . fmap Right
 
-tryStore :: forall a. Text -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
 tryStore op rId a = ExceptT $ E.mask_ $ a `E.catch` storeError op rId
 
-storeError :: Text -> RecipientId -> E.SomeException -> IO (Either ErrorType a)
+storeError :: String -> RecipientId -> E.SomeException -> IO (Either ErrorType a)
 storeError op rId e =
-  let e' = T.intercalate ", " [op, decodeLatin1 $ strEncode rId, tshow e]
-    in logError ("STORE: " <> e') $> Left (STORE e')
+  let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
+    in logError ("STORE: " <> T.pack e') $> Left (STORE e')
 
-isolateQueueId :: Text -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
 isolateQueueId op JournalMsgStore {queueLocks, sharedLock} rId =
   tryStore op rId . withLockMapWaitShared rId queueLocks sharedLock op
 
@@ -806,8 +784,8 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP
       let (seg, s') = B.splitAt 2 s
        in seg : splitSegments (n - 1) s'
 
-msgQueueStatePath :: FilePath -> RecipientId -> FilePath
-msgQueueStatePath dir rId = dir </> (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt)
+msgQueueStatePath :: FilePath -> String -> FilePath
+msgQueueStatePath dir queueId = dir </> (queueLogFileName <> "." <> queueId <> logFileExt)
 
 createNewJournal :: FilePath -> ByteString -> IO Handle
 createNewJournal dir journalId = do
@@ -976,11 +954,10 @@ deleteQueue_ ms q =
     pure r
   where
     rId = recipientId q
-    remove qr = do
-      mq_ <- atomically $ swapTVar (msgQueue' q) Nothing
+    remove r@(_, mq_) = do
       mapM_ (closeMsgQueueHandles ms) mq_
       removeQueueDirectory ms rId
-      pure (qr, mq_)
+      pure r
 
 closeMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO ()
 closeMsgQueue ms JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ (closeMsgQueueHandles ms)
@@ -1031,33 +1008,3 @@ 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/Journal/SharedLock.hs

@@ -8,7 +8,6 @@ where
 import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Control.Monad
-import Data.Text (Text)
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Client (getMapLock)
 import Simplex.Messaging.Protocol (RecipientId)
@@ -17,14 +16,14 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (($>>), ($>>=))
 
 -- wait until shared lock with passed ID is released and take lock
-withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> Text -> IO a -> IO a
+withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> String -> IO a -> IO a
 withLockWaitShared rId lock shared name =
   E.bracket_
     (atomically $ waitShared rId shared >> putTMVar lock name)
     (void $ atomically $ takeTMVar lock)
 
 -- wait until shared lock with passed ID is released and take lock from Map for this ID
-withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> Text -> IO a -> IO a
+withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> String -> IO a -> IO a
 withLockMapWaitShared rId locks shared name a =
   E.bracket
     (atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name)

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

@@ -1,386 +0,0 @@
-{-# 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

@@ -24,7 +24,6 @@ import Control.Monad.Trans.Except
 import Data.Functor (($>))
 import Data.Int (Int64)
 import qualified Data.Map.Strict as M
-import Data.Text (Text)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
@@ -57,16 +56,18 @@ 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
@@ -80,7 +81,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
@@ -127,10 +128,10 @@ instance MsgStoreClass STMMsgStore where
     Nothing -> pure (Nothing, 0)
 
   deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
-  deleteQueue ms q = fst <$$> deleteQueue_ ms q
+  deleteQueue ms q = fst <$$> deleteStoreQueue (queueStore_ ms) q
 
   deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
-  deleteQueueSize ms q = deleteQueue_ ms q >>= mapM (traverse getSize)
+  deleteQueueSize ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM (traverse getSize)
     -- traverse operates on the second tuple element
     where
       getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
@@ -177,15 +178,10 @@ instance MsgStoreClass STMMsgStore where
       Just _ -> modifyTVar' size (subtract 1)
       _ -> pure ()
 
-  isolateQueue :: STMMsgStore -> STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
-  isolateQueue _ _ _ = liftIO . atomically
+  isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a
+  isolateQueue _ _ = liftIO . atomically
   {-# INLINE isolateQueue #-}
 
-  unsafeRunStore :: STMQueue -> Text -> STM a -> IO a
+  unsafeRunStore :: STMQueue -> String -> 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

@@ -6,7 +6,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -18,13 +17,11 @@
 module Simplex.Messaging.Server.MsgStore.Types where
 
 import Control.Concurrent.STM
-import Control.Monad
 import Control.Monad.Trans.Except
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
 import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
@@ -34,15 +31,14 @@ 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, store
-  unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
+  -- tty, withData, store
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> s -> (StoreQueue s -> IO a) -> IO a
   -- tty, store, now, ttl
   expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
   logQueueStates :: s -> IO ()
@@ -52,62 +48,29 @@ 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 s)
-  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
+  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s))
+  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue 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 s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
+  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue (StoreQueue 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 s -> StoreMonad s [Message]
+  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue (StoreQueue 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 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
+  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 -> String -> StoreMonad s a -> ExceptT ErrorType IO a
+  unsafeRunStore :: StoreQueue s -> String -> StoreMonad s a -> IO a
 
-  -- 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 MSType = MSMemory | MSJournal
 
 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
@@ -118,7 +81,6 @@ data MessageStats = MessageStats
     expiredMsgsCount :: Int,
     storedQueues :: Int
   }
-  deriving (Show)
 
 instance Monoid MessageStats where
   mempty = MessageStats 0 0 0
@@ -143,37 +105,57 @@ addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorT
 addQueue st = addQueue_ (queueStore st) (mkQueue st True)
 {-# INLINE addQueue #-}
 
-getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
+getQueue :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
 getQueue st = getQueue_ (queueStore st) (mkQueue st)
 {-# INLINE getQueue #-}
 
-getQueueRec :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
-getQueueRec st party qId = getQueue st party qId $>>= readQueueRec
+getQueueRec :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
+getQueueRec st party qId =
+  getQueue st party qId
+    $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q))
 
-getQueues :: (MsgStoreClass s, BatchParty p) => s -> SParty p -> [QueueId] -> IO [Either ErrorType (StoreQueue s)]
-getQueues st = getQueues_ (queueStore st) (mkQueue st)
-{-# INLINE getQueues #-}
+getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int
+getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
+{-# INLINE getQueueSize #-}
 
-getQueueRecs :: (MsgStoreClass s, BatchParty p) => s -> SParty p -> [QueueId] -> IO [Either ErrorType (StoreQueue s, QueueRec)]
-getQueueRecs st party qIds = getQueues st party qIds >>= mapM (fmap join . mapM readQueueRec)
+tryPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
+tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
+{-# INLINE tryPeekMsg #-}
 
-readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec))
-readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)
-{-# INLINE readQueueRec #-}
+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 s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
-withPeekMsgQueue st q op a = isolateQueue st q op $ getPeekMsgQueue st q >>= a
+withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
+withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a
 {-# INLINE withPeekMsgQueue #-}
 
--- not used with PostgreSQL message store
+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
+
 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}
 
--- not used with PostgreSQL message store
-deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
+deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int
 deleteExpireMsgs_ old q mq = do
   n <- loop 0
   logQueueState q

src/Simplex/Messaging/Server/Prometheus.hs

@@ -6,8 +6,6 @@
 module Simplex.Messaging.Server.Prometheus where
 
 import Data.Int (Int64)
-import qualified Data.IntMap.Strict as IM
-import Data.List (mapAccumL)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffUTCTime)
@@ -15,17 +13,16 @@ import Data.Time.Clock.System (systemEpochDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
 import Simplex.Messaging.Server.MsgStore.Types (LoadedQueueCounts (..))
-import Simplex.Messaging.Server.QueueStore.Types (EntityCounts (..))
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Server (SocketStats (..))
-import Simplex.Messaging.Util (tshow)
 
 data ServerMetrics = ServerMetrics
   { statsData :: ServerStatsData,
     activeQueueCounts :: PeriodStatCounts,
     activeNtfCounts :: PeriodStatCounts,
-    entityCounts :: EntityCounts,
+    queueCount :: Int,
+    notifierCount :: Int,
     rtsOptions :: Text
   }
 
@@ -36,8 +33,6 @@ data RealTimeMetrics = RealTimeMetrics
   { socketStats :: [(ServiceName, SocketStats)],
     threadsCount :: Int,
     clientsCount :: Int,
-    deliveredSubs :: RTSubscriberMetrics,
-    deliveredTimes :: TimeBuckets,
     smpSubs :: RTSubscriberMetrics,
     ntfSubs :: RTSubscriberMetrics,
     loadedCounts :: LoadedQueueCounts
@@ -45,22 +40,19 @@ data RealTimeMetrics = RealTimeMetrics
 
 data RTSubscriberMetrics = RTSubscriberMetrics
   { subsCount :: Int,
-    subClientsCount :: Int,
-    subServicesCount :: Int
+    subClientsCount :: Int
   }
 
 {-# FOURMOLU_DISABLE\n#-}
 prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
 prometheusMetrics sm rtm ts =
-  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> info
+  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info
   where
-    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions} = sm
+    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount, rtsOptions} = sm
     RealTimeMetrics
       { socketStats,
         threadsCount,
         clientsCount,
-        deliveredSubs,
-        deliveredTimes,
         smpSubs,
         ntfSubs,
         loadedCounts
@@ -82,7 +74,6 @@ prometheusMetrics sm rtm ts =
         _qSubEnd,
         _qSubEndB,
         _ntfCreated,
-        _ntfNewCreated,
         _ntfDeleted,
         _ntfDeletedB,
         _ntfSub,
@@ -95,7 +86,6 @@ prometheusMetrics sm rtm ts =
         _msgSentLarge,
         _msgSentBlock,
         _msgRecv,
-        _msgRecvAckTimes,
         _msgRecvGet,
         _msgGet,
         _msgGetNoMsg,
@@ -115,8 +105,6 @@ prometheusMetrics sm rtm ts =
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
-        _rcvServices,
-        _ntfServices,
         _qCount,
         _msgCount,
         _ntfCount
@@ -157,7 +145,7 @@ prometheusMetrics sm rtm ts =
       \\n\
       \# HELP simplex_smp_queues_total2 Total number of stored queues (second type of count).\n\
       \# TYPE simplex_smp_queues_total2 gauge\n\
-      \simplex_smp_queues_total2 " <> mshow (queueCount entityCounts) <> "\n# qCount2\n\
+      \simplex_smp_queues_total2 " <> mshow queueCount <> "\n# qCount2\n\
       \\n\
       \# HELP simplex_smp_queues_daily Daily active queues.\n\
       \# TYPE simplex_smp_queues_daily gauge\n\
@@ -263,19 +251,15 @@ 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 queue notification credentials.\n\
+      \# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\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_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\
+      \# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\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 queue notification credentials.\n\
+      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\
       \# TYPE simplex_smp_queues_notify_deleted_batch counter\n\
       \simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\
       \\n\
@@ -285,7 +269,7 @@ prometheusMetrics sm rtm ts =
       \\n\
       \# HELP simplex_smp_queues_notify_total2 Total number of stored queues with notification flag (second type of count).\n\
       \# TYPE simplex_smp_queues_notify_total2 gauge\n\
-      \simplex_smp_queues_notify_total2 " <> mshow (notifierCount entityCounts) <> "\n# ntfCount2\n\
+      \simplex_smp_queues_notify_total2 " <> mshow notifierCount <> "\n# ntfCount2\n\
       \\n"
     ntfs =
       "# Notifications (server)\n\
@@ -364,60 +348,6 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_relay_messages_received counter\n\
       \simplex_smp_relay_messages_received " <> mshow _pMsgFwdsRecv <> "\n# pMsgFwdsRecv\n\
       \\n"
-    services =
-      "# Services\n\
-      \# --------\n\
-      \# HELP simplex_smp_rcv_services_count The count of receiving services.\n\
-      \# TYPE simplex_smp_rcv_services_count gauge\n\
-      \simplex_smp_rcv_services_count " <> mshow (rcvServiceCount entityCounts) <> "\n# rcvServiceCount\n\
-      \\n\
-      \# HELP simplex_smp_rcv_services_queues_count The count of queues associated with receiving services.\n\
-      \# TYPE simplex_smp_rcv_services_queues_count gauge\n\
-      \simplex_smp_rcv_services_queues_count " <> mshow (rcvServiceQueuesCount entityCounts) <> "\n# rcv.rcvServiceQueuesCount\n\
-      \\n\
-      \# HELP simplex_smp_ntf_services_count The count of notification services.\n\
-      \# TYPE simplex_smp_ntf_services_count gauge\n\
-      \simplex_smp_ntf_services_count " <> mshow (ntfServiceCount entityCounts) <> "\n# ntfServiceCount\n\
-      \\n\
-      \# HELP simplex_smp_ntf_services_queues_count The count of queues associated with notification services.\n\
-      \# TYPE simplex_smp_ntf_services_queues_count gauge\n\
-      \simplex_smp_ntf_services_queues_count " <> mshow (ntfServiceQueuesCount entityCounts) <> "\n# ntfServiceQueuesCount\n\
-      \\n"
-        <> showServices _rcvServices "rcv" "receiving"
-        <> showServices _ntfServices "ntf" "notification"
-    showServices ss pfx name =
-      "# HELP simplex_smp_" <> pfx <> "_services_assoc_new New queue associations with " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_assoc_new counter\n\
-      \simplex_smp_" <> pfx <> "_services_assoc_new " <> mshow (_srvAssocNew ss) <> "\n# " <> pfx <> ".srvAssocNew\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_assoc_duplicate Duplicate queue associations with " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_assoc_duplicate counter\n\
-      \simplex_smp_" <> pfx <> "_services_assoc_duplicate " <> mshow (_srvAssocDuplicate ss) <> "\n# " <> pfx <> ".srvAssocDuplicate\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_assoc_updated Updated queue associations with " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_assoc_updated counter\n\
-      \simplex_smp_" <> pfx <> "_services_assoc_updated " <> mshow (_srvAssocUpdated ss) <> "\n# " <> pfx <> ".srvAssocUpdated\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_assoc_removed Removed queue associations with " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_assoc_removed counter\n\
-      \simplex_smp_" <> pfx <> "_services_assoc_removed " <> mshow (_srvAssocRemoved ss) <> "\n# " <> pfx <> ".srvAssocRemoved\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_sub_count Service subscriptions by " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_sub_count counter\n\
-      \simplex_smp_" <> pfx <> "_services_sub_count " <> mshow (_srvSubCount ss) <> "\n# " <> pfx <> ".srvSubCount\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_sub_duplicate Duplicate service subscriptions by " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_sub_duplicate counter\n\
-      \simplex_smp_" <> pfx <> "_services_sub_duplicate " <> mshow (_srvSubDuplicate ss) <> "\n# " <> pfx <> ".srvSubDuplicate\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_sub_queues Queues subscribed by " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_sub_queues gauge\n\
-      \simplex_smp_" <> pfx <> "_services_sub_queues " <> mshow (_srvSubQueues ss) <> "\n# " <> pfx <> ".srvSubQueues\n\
-      \\n\
-      \# HELP simplex_smp_" <> pfx <> "_services_sub_end Ended subscriptions with " <> name <> " services.\n\
-      \# TYPE simplex_smp_" <> pfx <> "_services_sub_end gauge\n\
-      \simplex_smp_" <> pfx <> "_services_sub_end " <> mshow (_srvSubEnd ss) <> "\n# " <> pfx <> ".srvSubEnd\n\
-      \\n"
     info =
       "# Info\n\
       \# ----\n\
@@ -438,33 +368,6 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_clients_total gauge\n\
       \simplex_smp_clients_total " <> mshow clientsCount <> "\n\
       \\n\
-      \# HELP simplex_smp_delivered_total Total SMP subscriptions with delivered messages\n\
-      \# TYPE simplex_smp_delivered_total gauge\n\
-      \simplex_smp_delivered_total " <> mshow (subsCount deliveredSubs) <> "\n# delivered.subsCount\n\
-      \\n\
-      \# HELP simplex_smp_delivered_clients_total Subscribed clients\n\
-      \# TYPE simplex_smp_delivered_clients_total gauge\n\
-      \simplex_smp_delivered_clients_total " <> mshow (subClientsCount deliveredSubs) <> "\n# delivered.subClientsCount\n\
-      \\n\
-      \# HELP simplex_smp_delivery_ack_confirmed_time Times to confirm message delivery, only confirmed deliveries\n\
-      \# TYPE simplex_smp_delivery_ack_confirmed_time histogram\n\
-      \simplex_smp_delivery_ack_confirmed_time_sum " <> mshow (sumTime _msgRecvAckTimes) <> "\n\
-      \simplex_smp_delivery_ack_confirmed_time_count " <> mshow (_msgRecv + _msgRecvGet) <> "\n"
-      <> showTimeBuckets "simplex_smp_delivery_ack_confirmed_time" (timeBuckets _msgRecvAckTimes)
-      <> showTimeBucket "simplex_smp_delivery_ack_confirmed_time" "+Inf" (_msgRecv + _msgRecvGet)
-      <> "\n\
-      \# HELP simplex_smp_delivery_ack_confirmed_count Counts for confirmed deliveries\n\
-      \# TYPE simplex_smp_delivery_ack_confirmed_count counter\n"
-      <> showBucketSums "simplex_smp_delivery_ack_confirmed_count" (timeBuckets _msgRecvAckTimes)
-      <> "\n\
-      \# HELP simplex_smp_delivery_ack_pending_count Counts for pending delivery\n\
-      \# TYPE simplex_smp_delivery_ack_pending_count gauge\n"
-      <> showBucketSums "simplex_smp_delivery_ack_pending_count" (timeBuckets deliveredTimes)
-      <> "\n\
-      \# HELP simplex_smp_delivery_ack_time_max Max time to confirm message delivery\n\
-      \# TYPE simplex_smp_delivery_ack_time_max gauge\n\
-      \simplex_smp_delivery_ack_time_max " <> mshow (maxTime deliveredTimes) <> "\n# delivered.maxTime\n\
-      \\n\
       \# HELP simplex_smp_subscribtion_total Total SMP subscriptions\n\
       \# TYPE simplex_smp_subscribtion_total gauge\n\
       \simplex_smp_subscribtion_total " <> mshow (subsCount smpSubs) <> "\n# smp.subsCount\n\
@@ -473,10 +376,6 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_subscribtion_clients_total gauge\n\
       \simplex_smp_subscribtion_clients_total " <> mshow (subClientsCount smpSubs) <> "\n# smp.subClientsCount\n\
       \\n\
-      \# HELP simplex_smp_subscribtion_services_total Subscribed services, first counting method\n\
-      \# TYPE simplex_smp_subscribtion_services_total gauge\n\
-      \simplex_smp_subscribtion_services_total " <> mshow (subServicesCount smpSubs) <> "\n# smp.subServicesCount\n\
-      \\n\
       \# HELP simplex_smp_subscription_ntf_total Total notification subscripbtions (from ntf server)\n\
       \# TYPE simplex_smp_subscription_ntf_total gauge\n\
       \simplex_smp_subscription_ntf_total " <> mshow (subsCount ntfSubs) <> "\n# ntf.subsCount\n\
@@ -485,10 +384,6 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_subscription_ntf_clients_total gauge\n\
       \simplex_smp_subscription_ntf_clients_total " <> mshow (subClientsCount ntfSubs) <> "\n# ntf.subClientsCount\n\
       \\n\
-      \# HELP simplex_smp_subscribtion_nts_services_total Subscribed NTF services, first counting method\n\
-      \# TYPE simplex_smp_subscribtion_nts_services_total gauge\n\
-      \simplex_smp_subscribtion_nts_services_total " <> mshow (subServicesCount ntfSubs) <> "\n# ntf.subServicesCount\n\
-      \\n\
       \# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory/journal storage)\n\
       \# TYPE simplex_smp_loaded_queues_queue_count gauge\n\
       \simplex_smp_loaded_queues_queue_count " <> mshow (loadedQueueCount loadedCounts) <> "\n# loadedCounts.loadedQueueCount\n\
@@ -509,32 +404,15 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\
       \simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n"
 
-    showTimeBuckets :: Text -> IM.IntMap Int -> Text
-    showTimeBuckets metric = T.concat . snd . mapAccumL accumBucket (0, 0) . IM.assocs
-      where
-        accumBucket (prevSec, total) (sec, cnt) =
-          let t
-                | sec - 60 > prevSec = showTimeBucket metric (tshow (sec - 60)) total
-                | otherwise = ""
-           in ((sec, total + cnt), t <> showTimeBucket metric (tshow sec) (total + cnt))
-    showTimeBucket :: Text -> Text -> Int -> Text
-    showTimeBucket metric sec count = metric <> "_bucket{le=\"" <> sec <> "\"} " <> mshow count <> "\n"
-    showBucketSums :: Text -> IM.IntMap Int -> Text
-    showBucketSums metric buckets = T.concat $ map showBucketSum [(0, 60), (60, 300), (300, 1200), (1200, 3600), (3600, maxBound)]
-      where
-        showBucketSum (minTime, maxTime) =
-          metric <> "{period=\"" <> tshow minTime <> (if maxTime <= 3600 then "-" <> tshow maxTime else "+") <> "\"} " <> mshow bucketsSum <> "\n"
-          where
-            bucketsSum = IM.foldl' (+) 0 $ IM.filter (\sec -> minTime <= sec && sec < maxTime) buckets
     socketsMetric :: (SocketStats -> Int) -> Text -> Text -> Text
     socketsMetric sel metric descr =
       "# HELP " <> metric <> " " <> descr <> "\n"
         <> "# TYPE " <> metric <> " gauge\n"
         <> T.concat (map (\(port, ss) -> metric <> "{port=\"" <> T.pack port <> "\"} " <> mshow (sel ss) <> "\n") socketStats)
         <> "\n"
-    mstr a = a <> " " <> tsEpoch ts
+    mstr a = T.pack a <> " " <> tsEpoch
     mshow :: Show a => a -> Text
-    mshow = mstr . tshow
-    tsEpoch t = tshow @Int64 $ floor @Double $ realToFrac (t `diffUTCTime` epoch) * 1000
+    mshow = mstr . show
+    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
     epoch = UTCTime systemEpochDay 0
 {-# FOURMOLU_ENABLE\n#-}

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,17 +10,13 @@
 
 module Simplex.Messaging.Server.QueueStore where
 
-import Control.Applicative (optional, (<|>))
-import qualified Data.ByteString.Char8 as B
+import Control.Applicative ((<|>))
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.X509 as X
-import qualified Data.X509.Validation as XV
-import Simplex.Messaging.Encoding
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.SystemTime
-import Simplex.Messaging.Transport (SMPServiceRole)
 #if defined(dbServerPostgres)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Database.PostgreSQL.Simple.FromField (FromField (..))
@@ -37,55 +34,22 @@ data QueueRec = QueueRec
     queueData :: Maybe (LinkId, QueueLinkData),
     notifier :: Maybe NtfCreds,
     status :: ServerEntityStatus,
-    updatedAt :: Maybe SystemDate,
-    rcvServiceId :: Maybe ServiceId
+    updatedAt :: Maybe RoundedSystemTime
   }
   deriving (Show)
 
 data NtfCreds = NtfCreds
-  { notifierId :: NotifierId,
-    notifierKey :: NtfPublicAuthKey,
-    rcvNtfDhSecret :: RcvNtfDhSecret,
-    ntfServiceId :: Maybe ServiceId
+  { notifierId :: !NotifierId,
+    notifierKey :: !NtfPublicAuthKey,
+    rcvNtfDhSecret :: !RcvNtfDhSecret
   }
   deriving (Show)
 
 instance StrEncoding NtfCreds where
-  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId} =
-    strEncode (notifierId, notifierKey, rcvNtfDhSecret)
-      <> maybe "" ((" nsrv=" <>) . strEncode) ntfServiceId
+  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
   strP = do
     (notifierId, notifierKey, rcvNtfDhSecret) <- strP
-    ntfServiceId <- optional $ " nsrv=" *> strP
-    pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId}
-
-data ServiceRec = ServiceRec
-  { serviceId :: ServiceId,
-    serviceRole :: SMPServiceRole,
-    serviceCert :: X.CertificateChain,
-    serviceCertHash :: XV.Fingerprint, -- SHA512 hash of long-term service client certificate. See comment for ClientHandshake.
-    serviceCreatedAt :: SystemDate
-  }
-  deriving (Show)
-
-type CertFingerprint = B.ByteString
-
-instance StrEncoding ServiceRec where
-  strEncode ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash, serviceCreatedAt} =
-    B.unwords
-      [ "service_id=" <> strEncode serviceId,
-        "role=" <> smpEncode serviceRole,
-        "cert=" <> strEncode serviceCert,
-        "cert_hash=" <> strEncode serviceCertHash,
-        "created_at=" <> strEncode serviceCreatedAt
-      ]
-  strP = do
-    serviceId <- "service_id=" *> strP
-    serviceRole <- " role=" *> smpP
-    serviceCert <- " cert=" *> strP
-    serviceCertHash <- " cert_hash=" *> strP
-    serviceCreatedAt <- " created_at=" *> strP
-    pure ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash, serviceCreatedAt}
+    pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
 data ServerEntityStatus
   = EntityActive
@@ -108,3 +72,19 @@ instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherT
 
 instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
 #endif
+
+newtype RoundedSystemTime = RoundedSystemTime Int64
+  deriving (Eq, Ord, Show)
+#if defined(dbServerPostgres)
+  deriving newtype (FromField, ToField)
+#endif
+
+instance StrEncoding RoundedSystemTime where
+  strEncode (RoundedSystemTime t) = strEncode t
+  strP = RoundedSystemTime <$> strP
+
+getRoundedSystemTime :: Int64 -> IO RoundedSystemTime
+getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
+
+getSystemDate :: IO RoundedSystemTime
+getSystemDate = getRoundedSystemTime 86400

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

@@ -21,17 +21,10 @@
 module Simplex.Messaging.Server.QueueStore.Postgres
   ( PostgresQueueStore (..),
     PostgresStoreCfg (..),
-    batchInsertServices,
     batchInsertQueues,
-    foldServiceRecs,
     foldQueueRecs,
-    foldRecentQueueRecs,
     handleDuplicate,
     withLog_,
-    withDB,
-    withDB',
-    assertUpdated,
-    renderField,
   )
 where
 
@@ -41,26 +34,21 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
-import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder)
 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)
+import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (foldl', intersperse, partition)
+import Data.List (intersperse)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Set as S
-import Data.Text (Text)
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import qualified Data.Text as T
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-import qualified Data.X509 as X
-import qualified Data.X509.Validation as XV
-import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, SqlError, (:.) (..))
+import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..))
 import qualified Database.PostgreSQL.Simple as DB
 import qualified Database.PostgreSQL.Simple.Copy as DB
 import Database.PostgreSQL.Simple.FromField (FromField (..))
@@ -73,28 +61,26 @@ 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, fromTextField_)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.Postgres.Config
 import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
-import Simplex.Messaging.Server.QueueStore.STM (STMService (..), readQueueRecIO)
+import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO)
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.SystemTime
 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, maybeFirstRow', tshow, (<$$>))
+import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, 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
 
@@ -109,27 +95,22 @@ data PostgresQueueStore q = PostgresQueueStore
     -- this map only cashes the queues that were attempted to be subscribed to,
     notifiers :: TMap NotifierId RecipientId,
     notifierLocks :: TMap NotifierId Lock,
-    serviceLocks :: TMap CertFingerprint Lock,
-    deletedTTL :: Int64,
-    useCache :: Bool
+    deletedTTL :: Int64
   }
 
-type UseQueueCache = Bool
-
 instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
-  type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache)
+  type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
 
-  newQueueStore :: (PostgresStoreCfg, UseQueueCache)  -> IO (PostgresQueueStore q)
-  newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do
-    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
+  newQueueStore :: PostgresStoreCfg  -> IO (PostgresQueueStore q)
+  newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
     dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
     queues <- TM.emptyIO
     senders <- TM.emptyIO
     links <- TM.emptyIO
     notifiers <- TM.emptyIO
     notifierLocks <- TM.emptyIO
-    serviceLocks <- TM.emptyIO
-    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache}
+    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, deletedTTL}
     where
       err e = do
         logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -149,23 +130,18 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     fmap (fromRight 0) $ runExceptT $ withDB' "removeDeletedQueues" st $ \db ->
       DB.execute db "DELETE FROM msg_queues WHERE deleted_at < ?" (Only old)
 
-  getEntityCounts :: PostgresQueueStore q -> IO EntityCounts
-  getEntityCounts st =
-    withTransaction (dbStore st) $ \db -> do
-      (queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount) : _ <-
-        DB.query
+  queueCounts :: PostgresQueueStore q -> IO QueueCounts
+  queueCounts st =
+    withConnection (dbStore st) $ \db -> do
+      (queueCount, notifierCount) : _ <-
+        DB.query_
           db
           [sql|
             SELECT
-              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count,
-              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count,
-              (SELECT COUNT(1) FROM services WHERE service_role = ?) AS rcv_service_count,
-              (SELECT COUNT(1) FROM services WHERE service_role = ?) AS ntf_service_count,
-              (SELECT COUNT(1) FROM msg_queues WHERE rcv_service_id IS NOT NULL AND deleted_at IS NULL) AS rcv_service_queues_count,
-              (SELECT COUNT(1) FROM msg_queues WHERE ntf_service_id IS NOT NULL AND deleted_at IS NULL) AS ntf_service_queues_count
+              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count, 
+              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count
           |]
-          (SRMessaging, SRNotifier)
-      pure EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount}
+      pure QueueCounts {queueCount, notifierCount}
 
   -- this implementation assumes that the lock is already taken by addQueue
   -- and relies on unique constraints in the database to prevent duplicate IDs.
@@ -176,35 +152,28 @@ 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
-      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
+      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, useCache} = st
+      PostgresQueueStore {queues, senders, links, notifiers} = 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
-    | 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 = ?"
+  getQueue_ :: DirectParty 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) $>))
     where
-      PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
+      PostgresQueueStore {queues, senders, links, notifiers} = st
       getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
       loadRcvQueue = do
         (rId, qRec) <- loadQueue " WHERE recipient_id = ?"
@@ -221,7 +190,6 @@ 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 =
@@ -243,61 +211,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
               TM.insert rId sq queues
               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
-    | 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, 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]
-      loadQueues qs' cond mkCacheQueue = do
-        let qIds' = lefts qs'
-        if null qIds'
-          then pure $ map (first (const INTERNAL)) qs'
-          else do
-            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 $
-          -- checking the cache again for concurrent reads, use previously loaded queue if exists.
-          TM.lookup rId queues >>= \case
-            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
     qr <- ExceptT $ readQueueRecIO $ queueRec sq
@@ -308,7 +221,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       _ -> throwE AUTH
 
   addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
-  addQueueLinkData st sq lnkId d =
+  addQueueLinkData st sq lnkId d = 
     withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
       Nothing ->
         addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId))
@@ -359,58 +272,51 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     where
       rId = recipientId sq
 
-  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
+  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
   addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
     withQueueRec sq "addQueueNotifier" $ \q ->
-      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
+      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
+          nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId
+          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
           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 nId_
     where
-      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
+      PostgresQueueStore {notifiers} = st
       rId = recipientId sq
       update db =
         DB.execute
           db
           [sql|
             UPDATE msg_queues
-            SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ?, ntf_service_id = NULL
+            SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ?
             WHERE recipient_id = ? AND deleted_at IS NULL
           |]
           (nId, notifierKey, rcvNtfDhSecret, rId)
 
-  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
+  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
   deleteQueueNotifier st sq =
     withQueueRec sq "deleteQueueNotifier" $ \q ->
-      ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
-        withNotifierLock nId $ runExceptT $ do
+      ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} ->
+        withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do
           assertUpdated $ withDB' "deleteQueueNotifier" st update
-          when (useCache st) $ atomically $ TM.delete nId $ notifiers st
+          atomically $ TM.delete nId $ notifiers st
           atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
           withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
-          pure nc
+          pure nId
     where
-      withNotifierLock nId
-        | useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier"
-        | otherwise = id
       rId = recipientId sq
       update db =
         DB.execute
           db
           [sql|
             UPDATE msg_queues
-            SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL, ntf_service_id = NULL
+            SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL
             WHERE recipient_id = ? AND deleted_at IS NULL
           |]
           (Only rId)
@@ -429,8 +335,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   unblockQueue st sq =
     setStatusDB "unblockQueue" st sq EntityActive $
       withLog "unblockQueue" st (`logUnblockQueue` recipientId sq)
-
-  updateQueueTime :: PostgresQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
+  
+  updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
   updateQueueTime st sq t =
     withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
       if updatedAt == Just t
@@ -446,113 +352,40 @@ 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)
+  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
   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
-    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
+    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
     withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
-    pure q
+    pure (q, mq_)
     where
       rId = recipientId sq
       qr = queueRec sq
 
-  getCreateService :: PostgresQueueStore q -> ServiceRec -> IO (Either ErrorType ServiceId)
-  getCreateService st sr@ServiceRec {serviceId = newSrvId, serviceRole, serviceCertHash = XV.Fingerprint fp} =
-    withLockMap (serviceLocks st) fp "getCreateService" $ E.uninterruptibleMask_ $ runExceptT $ do
-      (serviceId, new) <-
-        withDB "getCreateService" st $ \db ->
-          maybeFirstRow id (DB.query db "SELECT service_id, service_role FROM services WHERE service_cert_hash = ?" (Only (Binary fp))) >>= \case
-            Just (serviceId, role)
-              | role == serviceRole -> pure $ Right (serviceId, False)
-              | otherwise -> pure $ Left SERVICE
-            Nothing ->
-              E.try (DB.execute db insertServiceQuery (serviceRecToRow sr))
-                >>= bimapM handleDuplicate (\_ -> pure (newSrvId, True))
-      when new $ withLog "getCreateService" st (`logNewService` sr)
-      pure serviceId
-
-  setQueueService :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
-  setQueueService st sq party serviceId = withQueueRec sq "setQueueService" $ \q -> case party of
-    SRecipientService
-      | rcvServiceId q == serviceId -> pure ()
-      | otherwise -> do
-          assertUpdated $ withDB' "setQueueService" st $ \db ->
-            DB.execute db "UPDATE msg_queues SET rcv_service_id = ? WHERE recipient_id = ? AND deleted_at IS NULL" (serviceId, rId)
-          updateQueueRec q {rcvServiceId = serviceId}
-    SNotifierService -> case notifier q of
-      Nothing -> throwE AUTH
-      Just nc@NtfCreds {ntfServiceId = prevSrvId}
-        | prevSrvId == serviceId -> pure ()
-        | otherwise -> do
-            assertUpdated $ withDB' "setQueueService" st $ \db ->
-              DB.execute db "UPDATE msg_queues SET ntf_service_id = ? WHERE recipient_id = ? AND notifier_id IS NOT NULL AND deleted_at IS NULL" (serviceId, rId)
-            updateQueueRec q {notifier = Just nc {ntfServiceId = serviceId}}
-    where
-      rId = recipientId sq
-      updateQueueRec :: QueueRec -> ExceptT ErrorType IO ()
-      updateQueueRec q' = do
-        atomically $ writeTVar (queueRec sq) $ Just q'
-        withLog "setQueueService" st $ \sl -> logQueueService sl rId party serviceId
-
-  getQueueNtfServices :: PostgresQueueStore q -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
-  getQueueNtfServices st ntfs = E.uninterruptibleMask_ $ runExceptT $ do
-    snIds <-
-      withDB' "getQueueNtfServices" st $ \db ->
-        DB.query db "SELECT ntf_service_id, notifier_id FROM msg_queues WHERE notifier_id IN ? AND deleted_at IS NULL" (Only (In (map fst ntfs)))
-    pure $
-      if null snIds
-        then ([], ntfs)
-        else
-          let snIds' = foldl' (\m (sId, nId) -> M.alter (Just . maybe (S.singleton nId) (S.insert nId)) sId m) M.empty snIds
-           in foldr addService ([], ntfs) (M.assocs snIds')
-    where
-      addService ::
-        (Maybe ServiceId, S.Set NotifierId) ->
-        ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]) ->
-        ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)])
-      addService (serviceId, snIds) (ssNtfs, ntfs') =
-        let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
-         in ((serviceId, sNtfs) : ssNtfs, restNtfs)
-
-  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 =
-  withTransaction (dbStore toStore) $ \db ->
-    DB.executeMany db insertServiceQuery $ map (serviceRecToRow . serviceRec) services'
-
 batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO Int64
 batchInsertQueues tty queues toStore = do
   qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues)
   putStrLn $ "Importing " <> show (length qs) <> " queues..."
   let st = dbStore toStore
   count <-
-    withTransaction st $ \db -> do
+    withConnection st $ \db -> do
       DB.copy_
         db
         [sql|
-          COPY msg_queues (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id, status, updated_at, link_id, rcv_service_id, fixed_data, user_data)
+          COPY msg_queues (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data)
           FROM STDIN WITH (FORMAT CSV)
         |]
       mapM_ (putQueue db) (zip [1..] qs)
       DB.putCopyEnd db
-  Only qCnt : _ <- withTransaction st (`DB.query_` "SELECT count(*) FROM msg_queues")
+  Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues")
   putStrLn $ progress count
   pure qCnt
   where
@@ -565,47 +398,13 @@ insertQueueQuery :: Query
 insertQueueQuery =
   [sql|
     INSERT INTO msg_queues
-      (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id, status, updated_at, link_id, rcv_service_id, fixed_data, user_data)
-    VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+      (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data)
+    VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
   |]
 
-insertServiceQuery :: Query
-insertServiceQuery =
-  [sql|
-    INSERT INTO services
-      (service_id, service_role, service_cert, service_cert_hash, created_at)
-    VALUES (?,?,?,?,?)
-  |]
-
-foldServiceRecs :: forall a q. Monoid a => PostgresQueueStore q -> (ServiceRec -> IO a) -> IO a
-foldServiceRecs st f =
-  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 :: 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 ->
+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 ->
     foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
       r <- f qr
       let !i' = i + 1
@@ -615,6 +414,14 @@ foldQueueRecs_ foldRecs tty st f = do
   when tty $ putStrLn $ progress n
   pure r
   where
+    foldRecs db acc f' = case skipOld_ of
+      Nothing
+        | withData -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
+        | otherwise -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
+      Just old
+        | withData -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
+        | otherwise -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
+    query = if withData then queueRecQueryWithData else queueRecQuery
     progress i = "Processed: " <> show i <> " records"
 
 queueRecQuery :: Query
@@ -622,8 +429,9 @@ queueRecQuery =
   [sql|
     SELECT recipient_id, recipient_keys, rcv_dh_secret,
       sender_id, sender_key, queue_mode,
-      notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id,
-      status, updated_at, link_id, rcv_service_id
+      notifier_id, notifier_key, rcv_ntf_dh_secret,
+      status, updated_at,
+      link_id
     FROM msg_queues
   |]
 
@@ -632,28 +440,23 @@ queueRecQueryWithData =
   [sql|
     SELECT recipient_id, recipient_keys, rcv_dh_secret,
       sender_id, sender_key, queue_mode,
-      notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id,
-      status, updated_at, link_id, rcv_service_id,
-      fixed_data, user_data
+      notifier_id, notifier_key, rcv_ntf_dh_secret,
+      status, updated_at,
+      link_id, fixed_data, user_data
     FROM msg_queues
   |]
 
-type QueueRecRow =
-  ( RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret,
-    SenderId, Maybe SndPublicAuthKey, Maybe QueueMode,
-    Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, Maybe ServiceId,
-    ServerEntityStatus, Maybe SystemDate, Maybe LinkId, Maybe ServiceId
-  )
+type QueueRecRow = (RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId)
 
 queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes)
-queueRecToRow (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt, rcvServiceId}) =
-  (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, ntfServiceId =<< n, status, updatedAt, linkId_, rcvServiceId)
+queueRecToRow (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
+  (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_)
     :. (fst <$> queueData_, snd <$> queueData_)
   where
     (linkId_, queueData_) = queueDataColumns queueData
 
 queueRecToText :: (RecipientId, QueueRec) -> ByteString
-queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt, rcvServiceId}) =
+queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
   LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
   where
     tabFields = BB.char7 ',' `intersperse` fields
@@ -667,25 +470,22 @@ queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey,
         nullable (notifierId <$> n),
         nullable (notifierKey <$> n),
         nullable (rcvNtfDhSecret <$> n),
-        nullable (ntfServiceId =<< n),
         BB.char7 '"' <> renderField (toField status) <> BB.char7 '"',
         nullable updatedAt,
         nullable linkId_,
-        nullable rcvServiceId,
         nullable (fst <$> queueData_),
         nullable (snd <$> queueData_)
       ]
     (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
@@ -693,32 +493,19 @@ queueDataColumns = \case
   Nothing -> (Nothing, Nothing)
 
 rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec)
-rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, ntfServiceId, status, updatedAt, linkId_, rcvServiceId) =
-  let notifier = mkNotifier (notifierId_, notifierKey_, rcvNtfDhSecret_) ntfServiceId
+rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) =
+  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
       queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_
-   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId})
+   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
 
 rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec)
-rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, ntfServiceId, status, updatedAt, linkId_, rcvServiceId) :. (immutableData_, userData_)) =
-  let notifier = mkNotifier (notifierId_, notifierKey_, rcvNtfDhSecret_) ntfServiceId
+rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) =
+  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
       encData =  fromMaybe (EncDataBytes "")
       queueData = (,(encData immutableData_, encData userData_)) <$> linkId_
-   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId})
+   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
 
-mkNotifier :: (Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret) -> Maybe ServiceId -> Maybe NtfCreds
-mkNotifier (Just notifierId, Just notifierKey, Just rcvNtfDhSecret) ntfServiceId =
-  Just NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId}
-mkNotifier _ _ = Nothing
-
-serviceRecToRow :: ServiceRec -> (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, SystemDate)
-serviceRecToRow ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash = XV.Fingerprint fp, serviceCreatedAt} =
-  (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedAt)
-
-rowToServiceRec :: (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, SystemDate) -> ServiceRec
-rowToServiceRec (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedAt) =
-  ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash = XV.Fingerprint fp, serviceCreatedAt}
-
-setStatusDB :: StoreQueueClass q => Text -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
+setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
 setStatusDB op st sq status writeLog =
   withQueueRec sq op $ \q -> do
     assertUpdated $ withDB' op st $ \db ->
@@ -726,33 +513,33 @@ setStatusDB op st sq status writeLog =
     atomically $ writeTVar (queueRec sq) $ Just q {status}
     writeLog
 
-withQueueRec :: StoreQueueClass q => q -> Text -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
+withQueueRec :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
 withQueueRec sq op action =
   withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
 
 assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO ()
 assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH))
 
-withDB' :: Text -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
+withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
 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 :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
 withDB op st action =
-  ExceptT $ E.try (withTransaction (dbStore st) action) >>= either logErr pure
+  ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure
   where
     logErr :: E.SomeException -> IO (Either ErrorType a)
-    logErr e = logError ("STORE: " <> err) $> Left (STORE err)
+    logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err)
       where
-        err = op <> ", withDB, " <> tshow e
+        err = op <> ", withDB, " <> show e
 
-withLog :: MonadIO m => Text -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
 withLog op PostgresQueueStore {dbStoreLog} = withLog_ op dbStoreLog
 {-# INLINE withLog #-}
 
-withLog_ :: MonadIO m => Text -> Maybe (StoreLog 'WriteMode) -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog_ :: MonadIO m => String -> Maybe (StoreLog 'WriteMode) -> (StoreLog 'WriteMode -> IO ()) -> m ()
 withLog_ op sl_ action =
   forM_ sl_ $ \sl -> liftIO $ action sl `catchAny` \e ->
-    logWarn $ "STORE: " <> op <> ", withLog, " <> tshow e
+    logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e)
 
 handleDuplicate :: SqlError -> IO ErrorType
 handleDuplicate e = case constraintViolation e of
@@ -765,14 +552,6 @@ instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary .
 
 instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode
 
-instance ToField SMPServiceRole where toField = toField . decodeLatin1 . smpEncode
-
-instance FromField SMPServiceRole where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
-
-instance ToField X.CertificateChain where toField = toField . Binary . smpEncode . C.encodeCertChain
-
-instance FromField X.CertificateChain where fromField = blobFieldDecoder (parseAll C.certChainP)
-
 #if !defined(dbPostgres)
 instance ToField EntityId where toField (EntityId s) = toField $ Binary s
 
@@ -793,8 +572,4 @@ instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodeP
 instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s)
 
 deriving newtype instance FromField EncDataBytes
-
-deriving newtype instance ToField (RoundedSystemTime t)
-
-deriving newtype instance FromField (RoundedSystemTime t)
 #endif