6.4.5.1

* servers: better socket leak prevention during TLS handshake

* log tcp connection errors

* more detailed network error

* log full address

* rename error

* add encodings for NetworkError

* refactor

* comment

* bind

* style

* remove parameters of NETWORK error from encoding

.github/workflows/reproduce-schedule.yml

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

CHANGELOG.md

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

README.md

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

apps/ntf-server/Main.hs

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

apps/smp-server/Main.hs

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

apps/smp-server/static/link.html

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

apps/smp-server/web/Static.hs

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

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

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

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

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

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

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.4.0.1
+version:        6.4.5.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -135,6 +135,7 @@ library
       Simplex.Messaging.Server.QueueStore.QueueInfo
       Simplex.Messaging.ServiceScheme
       Simplex.Messaging.Session
+      Simplex.Messaging.Agent.Store.Entity
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
@@ -146,6 +147,7 @@ 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
@@ -160,6 +162,7 @@ library
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -206,6 +209,14 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
+  if flag(client_postgres) || flag(server_postgres)
+      exposed-modules:
+          Simplex.Messaging.Agent.Store.Postgres
+          Simplex.Messaging.Agent.Store.Postgres.Common
+          Simplex.Messaging.Agent.Store.Postgres.DB
+          Simplex.Messaging.Agent.Store.Postgres.Migrations
+          Simplex.Messaging.Agent.Store.Postgres.Util
   if !flag(client_library)
       exposed-modules:
           Simplex.FileTransfer.Client.Main
@@ -213,24 +224,17 @@ 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
-          Simplex.Messaging.Notifications.Server
-          Simplex.Messaging.Notifications.Server.Control
-          Simplex.Messaging.Notifications.Server.Env
-          Simplex.Messaging.Notifications.Server.Main
-          Simplex.Messaging.Notifications.Server.Push.APNS
-          Simplex.Messaging.Notifications.Server.Push.APNS.Internal
-          Simplex.Messaging.Notifications.Server.Stats
-          Simplex.Messaging.Notifications.Server.Store
-          Simplex.Messaging.Notifications.Server.StoreLog
           Simplex.Messaging.Server
           Simplex.Messaging.Server.CLI
           Simplex.Messaging.Server.Control
           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
@@ -247,16 +251,21 @@ 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
+              Simplex.Messaging.Notifications.Server.Control
+              Simplex.Messaging.Notifications.Server.Env
+              Simplex.Messaging.Notifications.Server.Main
+              Simplex.Messaging.Notifications.Server.Prometheus
+              Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push.APNS.Internal
+              Simplex.Messaging.Notifications.Server.Stats
+              Simplex.Messaging.Notifications.Server.Store
+              Simplex.Messaging.Notifications.Server.Store.Migrations
+              Simplex.Messaging.Notifications.Server.Store.Postgres
+              Simplex.Messaging.Notifications.Server.Store.Types
+              Simplex.Messaging.Notifications.Server.StoreLog
               Simplex.Messaging.Server.QueueStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres.Migrations
   other-modules:
@@ -304,6 +313,7 @@ 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.*
@@ -340,18 +350,26 @@ library
       , sqlcipher-simple ==0.4.*
   if flag(server_postgres)
     cpp-options: -DdbServerPostgres
+    build-depends:
+        hex-text ==0.1.*
   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
   if flag(client_library)
       buildable: False
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres
+  else
+    buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
@@ -444,7 +462,6 @@ test-suite simplexmq-test
       AgentTests.EqInstances
       AgentTests.FunctionalAPITests
       AgentTests.MigrationTests
-      AgentTests.NotificationTests
       AgentTests.ServerChoice
       AgentTests.ShortLinkTests
       CLITests
@@ -460,8 +477,6 @@ test-suite simplexmq-test
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
-      NtfClient
-      NtfServerTests
       RemoteControl
       ServerTests
       SMPAgentClient
@@ -484,7 +499,10 @@ test-suite simplexmq-test
           AgentTests.SQLiteTests
   if flag(server_postgres)
       other-modules:
-          ServerTests.SchemaDump  
+          AgentTests.NotificationTests
+          NtfClient
+          NtfServerTests
+          PostgresSchemaDump
   hs-source-dirs:
       tests
       apps/smp-server/web
@@ -509,6 +527,7 @@ test-suite simplexmq-test
     , generic-random ==1.5.*
     , hashable
     , hspec ==2.11.*
+    , hspec-core ==2.11.*
     , http-client
     , http-types
     , http2
@@ -537,18 +556,18 @@ test-suite simplexmq-test
     , warp-tls
     , yaml
   default-language: Haskell2010
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres
   if flag(client_postgres)
     cpp-options: -DdbPostgres
   else
     build-depends:
         memory
       , sqlcipher-simple
-  if !flag(client_postgres) || flag(server_postgres)
+  if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres)
     build-depends:
         deepseq ==1.4.*
       , process
   if flag(client_postgres) || flag(server_postgres)
     build-depends:
         postgresql-simple ==0.7.*
-  if flag(server_postgres)
-    cpp-options: -DdbServerPostgres

src/Simplex/FileTransfer/Agent.hs

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

src/Simplex/FileTransfer/Client.hs

@@ -31,18 +31,22 @@ import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
+import Network.Socket (HostName)
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
+    NetworkRequestMode (..),
     ProtocolClientError (..),
     TransportSession,
+    netTimeoutInt,
     chooseTransportHost,
     defaultNetworkConfig,
     transportClientConfig,
     clientSocksCredentials,
     unexpectedResponse,
+    useWebPort,
   )
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -55,9 +59,11 @@ import Simplex.Messaging.Protocol
     RecipientId,
     SenderId,
     pattern NoEntity,
+    NetworkError (..),
+    toNetworkError,
   )
-import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
-import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
+import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.File
@@ -99,15 +105,16 @@ defaultXFTPClientConfig =
   XFTPClientConfig
     { xftpNetworkConfig = defaultNetworkConfig,
       serverVRange = supportedFileServerVRange,
-      clientALPN = Just supportedXFTPhandshakes
+      clientALPN = Just alpnSupportedXFTPhandshakes
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
+      useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
+  let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False useALPN
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -116,10 +123,11 @@ 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}
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
-    Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
+    Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
+      xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
     _ -> pure thParams0
   logDebug $ "Client negotiated protocol: " <> tshow thVersion
   let c = XFTPClient {http2Client, thParams, transportSession, config}
@@ -132,7 +140,8 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
   (vr, sk) <- processServerHandshake shs
   let v = maxVersion vr
   sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
-  pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v, thServerVRange = vr}
+  let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
+  pure thParams0 {thAuth, thVersion = v, thServerVRange = vr}
   where
     getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
     getServerHandshake = do
@@ -147,12 +156,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 (X.CertificateChain cert, exact) = serverAuth
+            let CertChainPubKey (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.pubKey
+            C.x509ToPublic' pubKey
     sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
     sendClientHandshake chs = do
       chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
@@ -177,14 +186,14 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = defaultSupportedParams,
-      connTimeout = tcpConnectTimeout,
+      connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
       transportConfig
     }
 
 xftpClientError :: HTTP2ClientError -> XFTPClientError
 xftpClientError = \case
   HCResponseTimeout -> PCEResponseTimeout
-  HCNetworkError -> PCENetworkError
+  HCNetworkError e -> PCENetworkError e
   HCIOError e -> PCEIOError e
 
 sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
@@ -203,7 +212,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 $ xftpDecodeTransmission thParams bodyHead
+  (_, _fId, respOrErr) <-liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
   case respOrErr of
     Right r -> case protocolError r of
       Just e -> throwE $ PCEProtocolError e
@@ -254,9 +263,9 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
         ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwE PCEResponseTimeout) pure
         where
           errors =
-            [ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError,
-              Handler $ \(e :: IOException) -> pure $ Left (PCEIOError e),
-              Handler $ \(_e :: SomeException) -> pure $ Left PCENetworkError
+            [ Handler $ \(e :: H.HTTP2Error) -> pure $ Left $ PCENetworkError $ NEConnectError $ displayException e,
+              Handler $ \(e :: IOException) -> pure $ Left $ PCEIOError e,
+              Handler $ \(e :: SomeException) -> pure $ Left $ PCENetworkError $ toNetworkError e
             ]
           download cbState =
             runExceptT . withExceptT PCEResponseError $
@@ -267,11 +276,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
 
 xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
 xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
-  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
+  maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
 
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
 chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
-  tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
+  netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
 
 deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse

src/Simplex/FileTransfer/Client/Agent.hs

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

src/Simplex/FileTransfer/Client/Main.hs

@@ -280,7 +280,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
           fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
           fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
-      logInfo $ "encrypted file to " <> tshow encPath
+      logDebug $ "encrypted file to " <> tshow encPath
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
     uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
     uploadFile g chunks uploadedChunks encSize = do
@@ -293,14 +293,14 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       -- TODO shuffle/unshuffle chunks
       -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
       -- upload doesn't allow other requests within the same client until complete (but download does allow).
-      logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
+      logDebug $ "uploading " <> tshow (length chunks) <> " chunks..."
       (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a)
       mapM_ throwE errs
       pure $ map snd (sortOn fst rs)
       where
         uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
-          logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
+          logDebug $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
           (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
           rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
           digest <- liftIO $ getChunkDigest chunkSpec
@@ -308,7 +308,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
           (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
           withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
-          logInfo $ "uploaded chunk " <> tshow chunkNo
+          logDebug $ "uploaded chunk " <> tshow chunkNo
           uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
             let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
           liftIO $ do
@@ -418,11 +418,11 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
     downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
     downloadFileChunk g a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
-      logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
+      logDebug $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
       chunkPath <- uniqueCombine encPath $ show chunkNo
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
       withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
-      logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
+      logDebug $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
       downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
         let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
       liftIO $ do
@@ -467,7 +467,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
     deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
       withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
-      logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
+      logDebug $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
     deleteFileChunk _ _ = throwE $ CLIError "chunk has no replicas"
 
 cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()

src/Simplex/FileTransfer/Protocol.hs

@@ -44,8 +44,9 @@ import Simplex.Messaging.Protocol
     EntityId (..),
     RecipientId,
     SenderId,
+    RawTransmission,
     SentRawTransmission,
-    SignedTransmission,
+    SignedTransmissionOrError,
     SndPublicAuthKey,
     Transmission,
     TransmissionForAuth (..),
@@ -53,7 +54,8 @@ import Simplex.Messaging.Protocol
     encodeTransmission,
     encodeTransmissionForAuth,
     messageTagP,
-    tDecodeParseValidate,
+    tDecodeServer,
+    tDecodeClient,
     tEncodeBatch1,
     tParse,
   )
@@ -144,10 +146,15 @@ 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
@@ -192,7 +199,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
@@ -226,7 +233,8 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
   fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
+  checkCredentials tAuth entId (FileCmd p c) = FileCmd p <$> checkCredentials tAuth entId c
+  {-# INLINE checkCredentials #-}
 
 instance Encoding FileInfo where
   smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest)
@@ -304,7 +312,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
@@ -329,25 +337,35 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
 
-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
+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
 
-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)
+xftpEncodeTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission thParams t = xftpEncodeBatch1 (Nothing, encodeTransmission thParams 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 t) xftpBlockSize
+xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 False t) xftpBlockSize
 
-xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
-xftpDecodeTransmission thParams t = do
+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
   t' <- first (const BLOCK) $ C.unPad t
   case tParse thParams t' of
-    t'' :| [] -> Right $ tDecodeParseValidate thParams t''
+    t'' :| [] -> Right $ tDecode 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,6 +45,7 @@ import Network.Socket
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Server.Control
 import Simplex.FileTransfer.Server.Env
+import Simplex.FileTransfer.Server.Prometheus
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
@@ -53,15 +54,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 (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
-import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
+import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
+import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
@@ -69,6 +70,7 @@ import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.Server (runLocalTCPServer)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import System.Environment (lookupEnv)
 import System.Exit (exitFailure)
 import System.FilePath ((</>))
 import System.IO (hPrint, hPutStrLn, universalNewlineMode)
@@ -92,39 +94,46 @@ data XFTPTransportRequest = XFTPTransportRequest
 runXFTPServer :: XFTPServerConfig -> IO ()
 runXFTPServer cfg = do
   started <- newEmptyTMVarIO
-  runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes
+  runXFTPServerBlocking started cfg
 
-runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO ()
-runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_)
+runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
+runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
 data Handshake
   = HandshakeSent C.PrivateKeyX25519
   | HandshakeAccepted (THandleParams XFTPVersion 'TServer)
 
-xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do
+xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
   mapM_ (expireServerFiles Nothing) fileExpiration
   restoreServerStats
-  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
+  raceAny_
+    ( runServer
+        : expireFilesThread_ cfg
+          <> serverStatsThread_ cfg
+          <> prometheusMetricsThread_ cfg
+          <> controlPortThread_ cfg
+    )
+    `finally` stopServer
   where
     runServer :: M ()
     runServer = do
       srvCreds@(chain, pk) <- asks tlsServerCreds
-      signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
+      signKey <- liftIO $ case C.x509ToPrivate' pk of
         Right pk' -> pure pk'
-        Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
+        Left e -> putStrLn ("Server 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 alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
+      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds 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}
+            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
             req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
         flip runReaderT env $ case sessionALPN of
           Nothing -> processRequest req0
-          Just "xftp/1" ->
+          Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
             xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
               Nothing -> pure () -- handshake response sent
               Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
@@ -142,7 +151,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 = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
+          let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
           let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
           shs <- encodeXftp hs
 #ifdef slow_servers
@@ -158,7 +167,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, sessSecret' = Nothing}
+              let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
                   thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
               atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
 #ifdef slow_servers
@@ -181,7 +190,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     stopServer = do
       withFileLog closeStoreLog
       saveServerStats
-      logInfo "Server stopped"
+      logNote "Server stopped"
 
     expireFilesThread_ :: XFTPServerConfig -> [M ()]
     expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
@@ -221,25 +230,49 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0
           filesCount' <- readIORef filesCount
           filesSize' <- readIORef filesSize
-          hPutStrLn h $
-            intercalate
+          T.hPutStrLn h $
+            T.intercalate
               ","
-              [ iso8601Show $ utctDay fromTime',
-                show filesCreated',
-                show fileRecipients',
-                show filesUploaded',
-                show filesDeleted',
+              [ T.pack $ iso8601Show $ utctDay fromTime',
+                tshow filesCreated',
+                tshow fileRecipients',
+                tshow filesUploaded',
+                tshow filesDeleted',
                 dayCount files,
                 weekCount files,
                 monthCount files,
-                show fileDownloads',
-                show fileDownloadAcks',
-                show filesCount',
-                show filesSize',
-                show filesExpired'
+                tshow fileDownloads',
+                tshow fileDownloadAcks',
+                tshow filesCount',
+                tshow filesSize',
+                tshow 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_ _ = []
@@ -277,12 +310,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
                   CPSkip -> False
                   _ -> True
             processCP h role = \case
-              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+              CPAuth auth -> controlPortAuth h user admin role auth
                 where
-                  newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
-                    | Just auth == admin = CPRAdmin
-                    | Just auth == user = CPRUser
-                    | otherwise = CPRNone
+                  XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
               CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
               CPDelete fileId -> withUserRole $ unliftIO u $ do
                 fs <- asks store
@@ -317,22 +347,20 @@ data ServerFile = ServerFile
 processRequest :: XFTPTransportRequest -> M ()
 processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) 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
+  | 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
           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 (corrId, fId, resp) serverFile_ = do
-      let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
+    sendXFTPResponse t' serverFile_ = do
+      let t_ = xftpEncodeTransmission thParams t'
 #ifdef slow_servers
       randomDelay
 #endif
@@ -361,8 +389,8 @@ randomDelay = do
 
 data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
 
-verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
-verifyXFTPTransmission auth_ tAuth authorized fId cmd =
+verifyXFTPTransmission :: Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M VerificationResult
+verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, 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
@@ -381,9 +409,9 @@ verifyXFTPTransmission auth_ tAuth authorized fId cmd =
                 EntityBlocked info -> VRFailed $ BLOCKED info
                 EntityOff -> noFileAuth
           Left _ -> pure noFileAuth
-        noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH
+        noFileAuth = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH
     -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH
+    req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -560,13 +588,13 @@ expireServerFiles itemDelay expCfg = do
   usedStart <- readTVarIO $ usedStorage st
   old <- liftIO $ expireBeforeEpoch expCfg
   files' <- readTVarIO (files st)
-  logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
+  logNote $ "Expiration check: " <> tshow (M.size files') <> " files"
   forM_ (M.keys files') $ \sId -> do
     mapM_ threadDelay itemDelay
     atomically (expiredFilePath st sId old)
       >>= mapM_ (maybeRemove $ delete st sId)
   usedEnd <- readTVarIO $ usedStorage st
-  logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
+  logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
   where
     mbs bs = tshow (bs `div` 1048576) <> "mb"
     maybeRemove del = maybe del (remove del)
@@ -600,15 +628,15 @@ saveServerStats =
     >>= mapM_ (\f -> asks serverStats >>= liftIO . getFileServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
+      logNote $ "saving server stats to file " <> T.pack f
       B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
+      logNote "server stats saved"
 
 restoreServerStats :: M ()
 restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
+      logNote $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d@FileServerStatsData {_filesCount = statsFilesCount, _filesSize = statsFilesSize} -> do
           s <- asks serverStats
@@ -617,10 +645,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
           _filesSize <- readTVarIO usedStorage
           liftIO $ setFileServerStats s d {_filesCount, _filesSize}
           renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
+          logNote "server stats restored"
           when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount
           when (statsFilesSize /= _filesSize) $ logWarn $ "Files size differs: stats: " <> tshow statsFilesSize <> ", store: " <> tshow _filesSize
-          logInfo $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
+          logNote $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
         Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
+          logNote $ "error restoring server stats: " <> T.pack e
           liftIO exitFailure

src/Simplex/FileTransfer/Server/Env.hs

@@ -64,6 +64,8 @@ data XFTPServerConfig = XFTPServerConfig
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
+    prometheusInterval :: Maybe Int,
+    prometheusMetricsFile :: FilePath,
     transportConfig :: TransportServerConfig,
     responseDelay :: Int
   }
@@ -103,8 +105,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede
   used <- countUsedStorage <$> readTVarIO (files store)
   atomically $ writeTVar (usedStorage store) used
   forM_ fileSizeQuota $ \quota -> do
-    logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
-    when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
+    logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
+    when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!"
   tlsServerCreds <- loadServerCredential xftpCredentials
   Fingerprint fp <- loadFingerprint xftpCredentials
   serverStats <- newFileServerStats =<< getCurrentTime

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)
+import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes)
 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.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
-import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -60,7 +60,7 @@ xftpServerCLI cfgPath logPath = do
       putStrLn "Deleted configuration and log files"
   where
     iniFile = combine cfgPath "file-server.ini"
-    serverVersion = "SimpleX XFTP server v" <> simplexMQVersion
+    serverVersion = "SimpleX XFTP server v" <> simplexmqVersionCommit
     defaultServerPort = "443"
     executableName = "file-server"
     storeLogFilePath = combine logPath "file-server-store.log"
@@ -89,6 +89,9 @@ xftpServerCLI cfgPath logPath = do
             <> "# Expire files after the specified number of hours.\n"
             <> ("expire_files_hours: " <> tshow defFileExpirationHours <> "\n\n")
             <> "log_stats: off\n\
+               \\n\
+               \# Log interval for real-time Prometheus metrics\n\
+               \# prometheus_interval: 60\n\
                \\n\
                \[AUTH]\n\
                \# Set new_files option to off to completely prohibit uploading new files.\n\
@@ -188,10 +191,13 @@ 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 =
-                defaultTransportServerConfig
-                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  },
+                mkTransportServerConfig
+                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
+                  (Just $ alpnSupportedXFTPhandshakes <> httpALPN)
+                  False,
               responseDelay = 0
             }
 

src/Simplex/FileTransfer/Server/Prometheus.hs

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

src/Simplex/FileTransfer/Transport.hs

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

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

@@ -27,11 +27,6 @@ module Simplex.Messaging.Agent.Env.SQLite
     serverHosts,
     defaultAgentConfig,
     defaultReconnectInterval,
-    tryAgentError,
-    tryAgentError',
-    catchAgentError,
-    catchAgentError',
-    agentFinally,
     Env (..),
     newSMPAgentEnv,
     createAgentStore,
@@ -45,7 +40,6 @@ module Simplex.Messaging.Agent.Env.SQLite
 where
 
 import Control.Concurrent (ThreadId)
-import Control.Exception (BlockedIndefinitelyOnSTM (..), SomeException, fromException)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -83,7 +77,6 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
@@ -96,7 +89,8 @@ data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
     ntf :: [NtfServer],
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
-    netCfg :: NetworkConfig
+    netCfg :: NetworkConfig,
+    presetDomains :: [HostName]
   }
 
 data ServerCfg p = ServerCfg
@@ -311,33 +305,6 @@ newXFTPAgent = do
   xftpDelWorkers <- TM.emptyIO
   pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
 
-tryAgentError :: AM a -> AM (Either AgentErrorType a)
-tryAgentError = tryAllErrors mkInternal
-{-# INLINE tryAgentError #-}
-
--- unlike runExceptT, this ensures we catch IO exceptions as well
-tryAgentError' :: AM a -> AM' (Either AgentErrorType a)
-tryAgentError' = tryAllErrors' mkInternal
-{-# INLINE tryAgentError' #-}
-
-catchAgentError :: AM a -> (AgentErrorType -> AM a) -> AM a
-catchAgentError = catchAllErrors mkInternal
-{-# INLINE catchAgentError #-}
-
-catchAgentError' :: AM a -> (AgentErrorType -> AM' a) -> AM' a
-catchAgentError' = catchAllErrors' mkInternal
-{-# INLINE catchAgentError' #-}
-
-agentFinally :: AM a -> AM b -> AM a
-agentFinally = allFinally mkInternal
-{-# INLINE agentFinally #-}
-
-mkInternal :: SomeException -> AgentErrorType
-mkInternal e = case fromException e of
-  Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
-  _ -> INTERNAL $ show e
-{-# INLINE mkInternal #-}
-
 data Worker = Worker
   { workerId :: Int,
     doWork :: TMVar (),

src/Simplex/Messaging/Agent/Lock.hs

@@ -16,11 +16,12 @@ 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 String
+type Lock = TMVar Text
 
 createLock :: STM Lock
 createLock = newEmptyTMVar
@@ -30,24 +31,24 @@ createLockIO :: IO Lock
 createLockIO = newEmptyTMVarIO
 {-# INLINE createLockIO #-}
 
-withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
+withLock :: MonadUnliftIO m => Lock -> Text -> ExceptT e m a -> ExceptT e m a
 withLock lock name = ExceptT . withLock' lock name . runExceptT
 {-# INLINE withLock #-}
 
-withLock' :: MonadUnliftIO m => Lock -> String -> m a -> m a
+withLock' :: MonadUnliftIO m => Lock -> Text -> m a -> m a
 withLock' lock name =
   E.bracket_
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
 
-withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> String -> m a -> m a
+withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> Text -> 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 -> String -> m a -> m a
+withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> Text -> 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
@@ -55,5 +56,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 -> String -> STM Lock
+getPutLock :: (k -> STM Lock) -> k -> Text -> STM Lock
 getPutLock getLock key name = getLock key >>= \l -> putTMVar l name $> l

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

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

src/Simplex/Messaging/Agent/Protocol.hs

@@ -111,6 +111,7 @@ module Simplex.Messaging.Agent.Protocol
     ServiceScheme,
     FixedLinkData (..),
     ConnLinkData (..),
+    UserLinkData (..),
     OwnerAuth (..),
     OwnerId,
     ConnectionLink (..),
@@ -122,6 +123,9 @@ module Simplex.Messaging.Agent.Protocol
     ContactConnType (..),
     ShortLinkScheme (..),
     LinkKey (..),
+    StoredClientService (..),
+    ClientService,
+    ClientServiceId,
     sameConnReqContact,
     sameShortLinkContact,
     simplexChat,
@@ -147,6 +151,7 @@ module Simplex.Messaging.Agent.Protocol
     AgentMsgId,
     NotificationsMode (..),
     NotificationInfo (..),
+    ConnMsgReq (..),
 
     -- * Encode/decode
     serializeCommand,
@@ -163,11 +168,15 @@ module Simplex.Messaging.Agent.Protocol
     shortenShortLink,
     restoreShortLink,
     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)
@@ -186,18 +195,20 @@ 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
@@ -366,7 +377,7 @@ type SndQueueSecured = Bool
 
 -- | Parameterized type for SMP agent events
 data AEvent (e :: AEntity) where
-  INV :: AConnectionRequestUri -> AEvent AEConn
+  INV :: AConnectionRequestUri -> Maybe ClientServiceId -> 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
@@ -392,7 +403,7 @@ data AEvent (e :: AEntity) where
   DEL_USER :: Int64 -> AEvent AENone
   STAT :: ConnectionStats -> AEvent AEConn
   OK :: AEvent AEConn
-  JOINED :: SndQueueSecured -> AEvent AEConn
+  JOINED :: SndQueueSecured -> Maybe ClientServiceId -> AEvent AEConn
   ERR :: AgentErrorType -> AEvent AEConn
   ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
   SUSPENDED :: AEvent AENone
@@ -492,7 +503,7 @@ aCommandTag = \case
 
 aEventTag :: AEvent e -> AEventTag e
 aEventTag = \case
-  INV _ -> INV_
+  INV {} -> INV_
   CONF {} -> CONF_
   REQ {} -> REQ_
   INFO {} -> INFO_
@@ -518,7 +529,7 @@ aEventTag = \case
   DEL_USER _ -> DEL_USER_
   STAT _ -> STAT_
   OK -> OK_
-  JOINED _ -> JOINED_
+  JOINED {} -> JOINED_
   ERR _ -> ERR_
   ERRS _ -> ERRS_
   SUSPENDED -> SUSPENDED_
@@ -678,11 +689,21 @@ instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseA
 
 data NotificationInfo = NotificationInfo
   { ntfConnId :: ConnId,
+    ntfDbQueueId :: Int64,
     ntfTs :: SystemTime,
+    -- Nothing means that the message failed to decrypt or to decode,
+    -- we can still show event notification
     ntfMsgMeta :: Maybe NMsgMeta
   }
   deriving (Show)
 
+data ConnMsgReq = ConnMsgReq
+  { msgConnId :: ConnId,
+    msgDbQueueId :: Int64,
+    msgTs :: Maybe UTCTime
+  }
+  deriving (Show)
+
 data ConnectionMode = CMInvitation | CMContact
   deriving (Eq, Show)
 
@@ -1109,7 +1130,7 @@ instance StrEncoding AConnectionRequestUri where
 
 connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri
 connReqUriP overrideScheme = do
-  crScheme <- (`fromMaybe` overrideScheme) <$> strP
+  crScheme <- (`fromMaybe` overrideScheme) <$> strP -- always parse, but use the passed one if any
   crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
   query <- strP
   aVRange <- queryParam "v" query
@@ -1133,22 +1154,39 @@ connReqUriP overrideScheme = do
 
 instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
   parseJSON = strParseJSON "ConnectionRequestUri"
+  {-# INLINE parseJSON #-}
 
 instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where
   toJSON = strToJSON
+  {-# INLINE toJSON #-}
   toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
 
 instance FromJSON AConnectionRequestUri where
   parseJSON = strParseJSON "ConnectionRequestUri"
+  {-# INLINE parseJSON #-}
 
 instance ToJSON AConnectionRequestUri where
   toJSON = strToJSON
+  {-# INLINE toJSON #-}
   toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
 
 instance ConnectionModeI m => FromJSON (ConnShortLink m) where
   parseJSON = strParseJSON "ConnShortLink"
+  {-# INLINE parseJSON #-}
 
 instance ConnectionModeI m => ToJSON (ConnShortLink m) where
+  toJSON = strToJSON
+  {-# INLINE toJSON #-}
+  toEncoding = strToJEncoding
+  {-# INLINE toEncoding #-}
+
+instance FromJSON AConnShortLink where
+  parseJSON = strParseJSON "AConnShortLink"
+  {-# INLINE parseJSON #-}
+
+instance ToJSON AConnShortLink where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
@@ -1176,6 +1214,16 @@ 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
@@ -1398,10 +1446,21 @@ instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField
 
 instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
 
-data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
+data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
 
 data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
 
+instance Eq AConnShortLink where
+  ACSL m sl == ACSL m' sl' = case testEquality m m' of
+    Just Refl -> sl == sl'
+    Nothing -> False
+
+deriving instance Show AConnShortLink
+
+instance ToField AConnShortLink where toField = toField . Binary . strEncode
+
+instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode
+
 data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m)
   deriving (Eq, Show)
 
@@ -1410,6 +1469,11 @@ 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)
@@ -1492,7 +1556,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_ =
@@ -1529,7 +1593,8 @@ ctTypeP :: Char -> Parser ContactConnType
 ctTypeP = \case
   'A' -> pure CCTContact
   'C' -> pure CCTChannel
-  'G' -> pure CCTGroup 
+  'G' -> pure CCTGroup
+  'R' -> pure CCTRelay
   _ -> fail "unknown contact address type"
 {-# INLINE ctTypeP #-}
 
@@ -1538,6 +1603,7 @@ ctTypeChar = \case
   CCTContact -> 'A'
   CCTChannel -> 'C'
   CCTGroup -> 'G'
+  CCTRelay -> 'R'
 {-# INLINE ctTypeChar #-}
 
 -- the servers passed to this function should be all preset servers, not servers configured by the user.
@@ -1609,7 +1675,7 @@ data FixedLinkData c = FixedLinkData
   }
 
 data ConnLinkData c where
-  InvitationLinkData :: VersionRangeSMPA -> ConnInfo -> ConnLinkData 'CMInvitation
+  InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
   ContactLinkData ::
     { agentVRange :: VersionRangeSMPA,
       -- direct connection via connReq in fixed data is allowed.
@@ -1618,15 +1684,22 @@ data ConnLinkData c where
       owners :: [OwnerAuth],
       -- alternative addresses of chat relays that receive requests for this contact address.
       relays :: [ConnShortLink 'CMContact],
-      userData :: ConnInfo
+      userData :: UserLinkData
     } -> ConnLinkData 'CMContact
 
+newtype UserLinkData = UserLinkData ByteString
+
 data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m)
 
-linkUserData :: ConnLinkData c -> ConnInfo
+linkUserData :: ConnLinkData c -> UserLinkData
 linkUserData = \case
   InvitationLinkData _ d -> d
   ContactLinkData {userData} -> userData
+{-# INLINE linkUserData #-}
+
+linkUserData' :: ConnLinkData c -> ByteString
+linkUserData' d = let UserLinkData s = linkUserData d in s
+{-# INLINE linkUserData' #-}
 
 type OwnerId = ByteString
 
@@ -1673,15 +1746,31 @@ instance Encoding AConnLinkData where
   smpP =
     smpP >>= \case
       CMInvitation -> do
-        (vr, userData) <- smpP
+        (vr, userData) <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
         pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
       CMContact -> do
         (agentVRange, direct) <- smpP
         owners <- smpListP
         relays <- smpListP
-        userData <- smpP
+        userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
         pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData}
 
+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
+
 -- | SMP queue status.
 data QueueStatus
   = -- | queue is created
@@ -1751,7 +1840,7 @@ data AgentErrorType
   = -- | command or response error
     CMD {cmdErr :: CommandErrorType, errContext :: String}
   | -- | connection errors
-    CONN {connErr :: ConnectionErrorType}
+    CONN {connErr :: ConnectionErrorType, errContext :: String}
   | -- | user not found in database
     NO_USER
   | -- | SMP protocol errors forwarded to agent clients
@@ -1778,6 +1867,12 @@ data AgentErrorType
     INACTIVE
   deriving (Eq, Show, Exception)
 
+instance AnyError AgentErrorType where
+  fromSomeException e = case fromException e of
+    Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
+    _ -> INTERNAL $ show e
+  {-# INLINE fromSomeException #-}
+
 -- | SMP agent protocol command or response error.
 data CommandErrorType
   = -- | command is prohibited in this context
@@ -1885,7 +1980,7 @@ commandP binaryP =
     s :: Parser a -> Parser a
     s p = A.space *> p
     pqIKP :: Parser InitialKeys
-    pqIKP = strP_ <|> pure (IKNoPQ PQSupportOff)
+    pqIKP = strP_ <|> pure (IKLinkPQ PQSupportOff)
     pqSupP :: Parser PQSupport
     pqSupP = strP_ <|> pure PQSupportOff
 

src/Simplex/Messaging/Agent/Store.hs

@@ -29,6 +29,7 @@ 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)
@@ -52,30 +53,19 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util (AnyError (..), bshow)
 
 createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createStore dbOpts = createDBStore dbOpts appMigrations
 
 -- * Queue types
 
-data QueueStored = QSStored | QSNew
+type RcvQueue = StoredRcvQueue 'DBStored
 
-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
+type NewRcvQueue = StoredRcvQueue 'DBNew
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
-data StoredRcvQueue (q :: QueueStored) = RcvQueue
+data StoredRcvQueue (q :: DBStored) = RcvQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -95,10 +85,12 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
     queueMode :: Maybe QueueMode,
     -- | short link ID and credentials
     shortLink :: Maybe ShortLinkCreds,
+    -- | associated client service
+    clientService :: Maybe (StoredClientService q),
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: DBQueueId q,
+    dbQueueId :: DBEntityId' 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
@@ -120,10 +112,18 @@ data ShortLinkCreds = ShortLinkCreds
   }
   deriving (Show)
 
+clientServiceId :: RcvQueue -> Maybe ClientServiceId
+clientServiceId = fmap dbServiceId . clientService
+{-# INLINE clientServiceId #-}
+
 rcvQueueInfo :: RcvQueue -> RcvQueueInfo
 rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
   RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
 
+rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
+rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
+  SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
+
 canAbortRcvSwitch :: RcvQueue -> Bool
 canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
   where
@@ -160,12 +160,12 @@ data InvShortLink = InvShortLink
   }
   deriving (Show)
 
-type SndQueue = StoredSndQueue 'QSStored
+type SndQueue = StoredSndQueue 'DBStored
 
-type NewSndQueue = StoredSndQueue 'QSNew
+type NewSndQueue = StoredSndQueue 'DBNew
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
-data StoredSndQueue (q :: QueueStored) = SndQueue
+data StoredSndQueue (q :: DBStored) = SndQueue
   { userId :: UserId,
     connId :: ConnId,
     server :: SMPServer,
@@ -184,7 +184,7 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
     -- | queue status
     status :: QueueStatus,
     -- | database queue ID (within connection)
-    dbQueueId :: DBQueueId q,
+    dbQueueId :: DBEntityId' 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
@@ -257,7 +257,7 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qUserId #-}
   qConnId RcvQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId RcvQueue {dbQueueId = DBQueueId qId} = qId
+  dbQId RcvQueue {dbQueueId = DBEntityId qId} = qId
   {-# INLINE dbQId #-}
   dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -267,7 +267,7 @@ instance SMPQueueRec SndQueue where
   {-# INLINE qUserId #-}
   qConnId SndQueue {connId} = connId
   {-# INLINE qConnId #-}
-  dbQId SndQueue {dbQueueId = DBQueueId qId} = qId
+  dbQId SndQueue {dbQueueId = DBEntityId qId} = qId
   {-# INLINE dbQId #-}
   dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
@@ -516,7 +516,7 @@ data NewInvitation = NewInvitation
 
 data Invitation = Invitation
   { invitationId :: InvitationId,
-    contactConnId :: ConnId,
+    contactConnId_ :: Maybe ConnId,
     connReq :: ConnectionRequestUri 'CMInvitation,
     recipientConnInfo :: ConnInfo,
     ownConnInfo :: Maybe ConnInfo,
@@ -667,13 +667,13 @@ data StoreError
     SESndQueueExists
   | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.
     -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.
-    SEBadConnType ConnType
+    SEBadConnType String ConnType
   | -- | Confirmation not found.
     SEConfirmationNotFound
   | -- | Invitation not found
     SEInvitationNotFound String InvitationId
   | -- | Message not found
-    SEMsgNotFound
+    SEMsgNotFound String
   | -- | Command not found
     SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
@@ -697,3 +697,6 @@ data StoreError
   | -- | Servers stats not found.
     SEServersStatsNotFound
   deriving (Eq, Show, Exception)
+
+instance AnyError StoreError where
+  fromSomeException = SEInternal . bshow

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

@@ -98,6 +98,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     -- Messages
     updateRcvIds,
     createRcvMsg,
+    setLastBrokerTs,
     updateRcvMsgHash,
     createSndMsgBody,
     updateSndIds,
@@ -282,6 +283,7 @@ import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
 import Simplex.Messaging.Version.Internal
@@ -379,12 +381,13 @@ 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 -> 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 $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
   where
     updateConn :: IO (Either StoreError RcvQueue)
     updateConn = Right <$> addConnRcvQueue_ db connId rq
@@ -393,7 +396,7 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr
 updateNewConnSnd db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
-    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c
   where
     updateConn :: IO (Either StoreError SndQueue)
     updateConn = Right <$> addConnSndQueue_ db connId sq
@@ -469,20 +472,22 @@ upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either S
 upgradeRcvConnToDuplex db connId sq =
   getConn db connId $>>= \case
     (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
-    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    (SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
 
+-- TODO [certs rcv] store clientServiceId from NewRcvQueue
 upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 upgradeSndConnToDuplex db connId rq =
   getConn db connId >>= \case
     Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
     _ -> pure $ Left SEConnNotFound
 
+-- TODO [certs rcv] store clientServiceId from NewRcvQueue
 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
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
@@ -494,7 +499,7 @@ addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreErr
 addConnSndQueue db connId sq =
   getConn db connId >>= \case
     Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
@@ -723,7 +728,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)
 
@@ -740,8 +745,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 =
@@ -759,12 +764,9 @@ unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
 unacceptInvitation db invitationId =
   DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId))
 
-deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
-deleteInvitation db contactConnId invId =
-  getConn db contactConnId $>>= \case
-    SomeConn SCContact _ ->
-      Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
-    _ -> pure $ Left SEConnNotFound
+deleteInvitation :: DB.Connection -> InvitationId -> IO ()
+deleteInvitation db invId =
+  DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId))
 
 getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
 getInvShortLink db server linkId =
@@ -855,7 +857,11 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta =
   insertRcvMsgBase_ db connId rcvMsgData
   insertRcvMsgDetails_ db connId rq rcvMsgData
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
-  DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId)
+  setLastBrokerTs db connId dbQueueId brokerTs
+
+setLastBrokerTs :: DB.Connection -> ConnId -> DBEntityId -> 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)
 
 createSndMsgBody :: DB.Connection -> AMessage -> IO Int64
 createSndMsgBody db aMessage =
@@ -885,7 +891,7 @@ createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
 
 getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
 getSndMsgViaRcpt db connId sndMsgId =
-  firstRow toSndMsg SEMsgNotFound $
+  firstRow toSndMsg (SEMsgNotFound "getSndMsgViaRcpt") $
     DB.query
       db
       [sql|
@@ -969,13 +975,10 @@ getWorkItems itemName getIds getItem markFailed =
   runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
 
 tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
-tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
+tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchAllErrors` \e -> mark >> throwE e
   where
     mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
 
-catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
-catchStoreError = catchAllErrors (SEInternal . bshow)
-
 -- Errors caught by this function will suspend worker as if there is no more work,
 handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
 handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
@@ -1021,7 +1024,7 @@ getExpiredSndMessages db connId SndQueue {dbQueueId} expireTs = do
 setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId))
 setMsgUserAck db connId agentMsgId = runExceptT $ do
   (dbRcvId, srvMsgId) <-
-    ExceptT . firstRow id SEMsgNotFound $
+    ExceptT . firstRow id (SEMsgNotFound "setMsgUserAck") $
       DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
   rq <- ExceptT $ getRcvQueueById db connId dbRcvId
   liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (BI True, connId, agentMsgId)
@@ -1029,7 +1032,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do
 
 getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg)
 getRcvMsg db connId agentMsgId =
-  firstRow toRcvMsg SEMsgNotFound $
+  firstRow toRcvMsg (SEMsgNotFound "getRcvMsg") $
     DB.query
       db
       [sql|
@@ -1079,7 +1082,7 @@ checkRcvMsgHashExists db connId hash = do
 
 getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
 getRcvMsgBrokerTs db connId msgId =
-  firstRow fromOnly SEMsgNotFound $
+  firstRow fromOnly (SEMsgNotFound "getRcvMsgBrokerTs") $
     DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId)
 
 deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
@@ -1207,7 +1210,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))
@@ -1781,19 +1784,19 @@ getActiveNtfToken db =
           ntfMode = fromMaybe NMPeriodic ntfMode_
        in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
-getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime))
+getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime))
 getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
   firstRow' res SEConnNotFound $
     DB.query
       db
       [sql|
-        SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts
+        SELECT conn_id, rcv_queue_id, rcv_ntf_dh_secret, last_broker_ts
         FROM rcv_queues
         WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
       |]
       (host, port, notifierId)
   where
-    res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_)
+    res (connId, dbQueueId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, dbQueueId, rcvNtfDhSecret, lastBrokerTs_)
     res _ = Left SEConnNotFound
 
 setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
@@ -1806,15 +1809,6 @@ 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
@@ -1972,14 +1966,22 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
       INSERT INTO rcv_queues
         ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
           snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
-          link_id, link_key, link_priv_sig_key, link_enc_fixed_data
-        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
+          link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
+          ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
+        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
         :. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
         :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
+        :. ntfCredsFields
     )
-  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
+  -- TODO [certs rcv] save client service
+  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
+  where
+    ntfCredsFields = case clientNtfCreds of
+      Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
+        (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
+      Nothing -> (Nothing, Nothing, Nothing, Nothing)
 
 -- * createSndConn helpers
 
@@ -2013,13 +2015,13 @@ 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', sndPublicKey, 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] -> DBQueueId 'QSStored
-newQueueId_ [] = DBQueueId 1
-newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
+newQueueId_ :: [Only Int64] -> DBEntityId
+newQueueId_ [] = DBEntityId 1
+newQueueId_ (Only maxId : _) = DBEntityId (maxId + 1)
 
 -- * getConn helpers
 
@@ -2155,7 +2157,7 @@ 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, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
+    :. (QueueStatus, DBEntityId, 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
@@ -2173,7 +2175,8 @@ toRcvQueue
       shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
         (Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
         _ -> Nothing
-   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
+      -- TODO [certs rcv] read client service
+   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, clientService = Nothing, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
 
 getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
 getRcvQueueById db connId dbRcvId =
@@ -2205,7 +2208,7 @@ sndQueueQuery =
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode)
     :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
+    :. (DBEntityId, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId, queueMode)

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

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

@@ -33,7 +33,6 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Exit (exitFailure)
-import UnliftIO.MVar
 
 -- | 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.
@@ -54,23 +53,26 @@ createDBStore opts migrations confirmMigrations = do
 
 connectPostgresStore :: DBOpts -> IO DBStore
 connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do
-  dbSem <- newMVar ()
-  dbPool <- newTBQueueIO poolSize
+  dbPriorityPool <- newDBStorePool poolSize
+  dbPool <- newDBStorePool poolSize
   dbClosed <- newTVarIO True
-  let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPool, dbSem, dbNew = False, dbClosed}
-  dbNew <- connectPool st createSchema
+  let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbNew = False, dbClosed}
+  dbNew <- connectStore st createSchema
   pure st {dbNew}
 
 -- uninterruptibleMask_ here and below is used here so that it is not interrupted half-way,
 -- it relies on the assumption that when dbClosed = True, the queue is empty,
 -- and when it is False, the queue is full (or will have connections returned to it by the threads that use them).
-connectPool :: DBStore -> Bool -> IO Bool
-connectPool DBStore {dbConnstr, dbSchema, dbPoolSize, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do
+connectStore :: DBStore -> Bool -> IO Bool
+connectStore DBStore {dbConnstr, dbSchema, dbPoolSize, dbPriorityPool, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do
   (conn, dbNew) <- connectDB dbConnstr dbSchema createSchema -- TODO [postgres] analogue for dbBusyLoop?
-  conns <- replicateM (dbPoolSize - 1) $ fst <$> connectDB dbConnstr dbSchema False
-  mapM_ (atomically . writeTBQueue dbPool) (conn : conns)
+  writeConns dbPriorityPool . (conn :) =<< mkConns (dbPoolSize - 1)
+  writeConns dbPool =<< mkConns dbPoolSize
   atomically $ writeTVar dbClosed False
   pure dbNew
+  where
+    writeConns pool conns = mapM_ (atomically . writeTBQueue (dbPoolConns pool)) conns
+    mkConns n = replicateM n $ fst <$> connectDB dbConnstr dbSchema False
 
 connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool)
 connectDB connstr schema createSchema = do
@@ -111,16 +113,19 @@ doesSchemaExist db schema = do
   pure schemaExists
 
 closeDBStore :: DBStore -> IO ()
-closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} =
+closeDBStore DBStore {dbPoolSize, dbPriorityPool, dbPool, dbClosed} =
   ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do
-    replicateM_ dbPoolSize $ atomically (readTBQueue dbPool) >>= DB.close
+    closePool dbPriorityPool
+    closePool dbPool
     atomically $ writeTVar dbClosed True
+  where
+    closePool pool = replicateM_ dbPoolSize $ atomically (readTBQueue $ dbPoolConns pool) >>= DB.close
 
 reopenDBStore :: DBStore -> IO ()
 reopenDBStore st =
   ifM
     (readTVarIO $ dbClosed st)
-    (void $ connectPool st False)
+    (void $ connectStore st False)
     (putStrLn "reopenDBStore: already opened")
 
 -- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL)

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

@@ -6,7 +6,9 @@
 
 module Simplex.Messaging.Agent.Store.Postgres.Common
   ( DBStore (..),
+    DBStorePool (..),
     DBOpts (..),
+    newDBStorePool,
     withConnection,
     withConnection',
     withTransaction,
@@ -20,6 +22,7 @@ import Control.Concurrent.STM
 import Control.Exception (bracket)
 import Data.ByteString (ByteString)
 import qualified Database.PostgreSQL.Simple as PSQL
+import Numeric.Natural (Natural)
 import Simplex.Messaging.Agent.Store.Postgres.Options
 
 -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type)
@@ -27,19 +30,40 @@ data DBStore = DBStore
   { dbConnstr :: ByteString,
     dbSchema :: ByteString,
     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 (),
+    dbPriorityPool :: DBStorePool,
+    dbPool :: DBStorePool,
+    -- dbPoolSize :: Int,
+    -- dbPool :: TBQueue PSQL.Connection,
+    -- -- MVar is needed for fair pool distribution, without STM retry contention.
+    -- -- Only one thread can be blocked on STM read.
+    -- dbSem :: MVar (),
     dbClosed :: TVar Bool,
     dbNew :: Bool
   }
 
+newDBStorePool :: Natural -> IO DBStorePool
+newDBStorePool poolSize = do
+  dbSem <- newMVar ()
+  dbPoolConns <- newTBQueueIO poolSize
+  pure DBStorePool {dbSem, dbPoolConns}
+
+data DBStorePool = DBStorePool
+  { dbPoolConns :: 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 ()
+  }
+
 withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
-withConnectionPriority DBStore {dbPool, dbSem} _priority =
+withConnectionPriority DBStore {dbPriorityPool, dbPool} priority =
+  withConnectionPool $ if priority then dbPriorityPool else dbPool
+{-# INLINE withConnectionPriority #-}
+
+withConnectionPool :: DBStorePool -> (PSQL.Connection -> IO a) -> IO a
+withConnectionPool DBStorePool {dbPoolConns, dbSem} =
   bracket
-    (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPool)
-    (atomically . writeTBQueue dbPool)
+    (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/App.hs

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

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

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

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

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

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

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

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

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

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

src/Simplex/Messaging/Client/Agent.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -9,7 +11,27 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Simplex.Messaging.Client.Agent where
+module Simplex.Messaging.Client.Agent
+  ( SMPClientAgent (..),
+    SMPClientAgentConfig (..),
+    SMPClientAgentEvent (..),
+    OwnServer,
+    defaultSMPClientAgentConfig,
+    newSMPClientAgent,
+    getSMPServerClient'',
+    getConnectedSMPServerClient,
+    closeSMPClientAgent,
+    lookupSMPServerClient,
+    isOwnServer,
+    subscribeServiceNtfs,
+    subscribeQueuesNtfs,
+    activeClientSession',
+    removeActiveSub,
+    removeActiveSubs,
+    removePendingSub,
+    removePendingSubs,
+  )
+where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
@@ -20,29 +42,43 @@ 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.Set (Set)
+import Data.Maybe (isJust, isNothing)
 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, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
+import Simplex.Messaging.Protocol
+  ( BrokerMsg,
+    ErrorType,
+    NotifierId,
+    NtfPrivateAuthKey,
+    Party (..),
+    PartyI,
+    ProtocolServer (..),
+    QueueId,
+    SMPServer,
+    SParty (..),
+    ServiceParty,
+    serviceParty,
+    partyServiceRole
+  )
 import Simplex.Messaging.Session
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=), (<$$>))
+import Simplex.Messaging.Util (catchAll_, ifM, safeDecodeUtf8, toChunks, tshow, whenM, ($>>=), (<$$>))
 import System.Timeout (timeout)
 import UnliftIO (async)
 import qualified UnliftIO.Exception as E
@@ -51,17 +87,18 @@ import UnliftIO.STM
 type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient))
 
 data SMPClientAgentEvent
-  = 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)
+  = 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)
 
 data SMPClientAgentConfig = SMPClientAgentConfig
   { smpCfg :: ProtocolClientConfig SMPVersion,
@@ -92,8 +129,9 @@ defaultSMPClientAgentConfig =
   where
     second = 1000000
 
-data SMPClientAgent = SMPClientAgent
+data SMPClientAgent p = SMPClientAgent
   { agentCfg :: SMPClientAgentConfig,
+    agentParty :: SParty p,
     active :: TVar Bool,
     startedAt :: UTCTime,
     msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
@@ -101,29 +139,39 @@ data SMPClientAgent = SMPClientAgent
     randomDrg :: TVar ChaChaDRG,
     smpClients :: TMap SMPServer SMPClientVar,
     smpSessions :: TMap SessionId (OwnServer, SMPClient),
-    srvSubs :: TMap SMPServer (TMap SMPSub (SessionId, C.APrivateAuthKey)),
-    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
+    -- 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),
     smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
     workerSeq :: TVar Int
   }
 
 type OwnServer = Bool
 
-newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
-newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
+newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO (SMPClientAgent p)
+newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
   active <- newTVarIO True
   startedAt <- getCurrentTime
   msgQ <- newTBQueueIO msgQSize
   agentQ <- newTBQueueIO agentQSize
   smpClients <- TM.emptyIO
   smpSessions <- TM.emptyIO
-  srvSubs <- TM.emptyIO
-  pendingSrvSubs <- TM.emptyIO
+  activeServiceSubs <- TM.emptyIO
+  activeQueueSubs <- TM.emptyIO
+  pendingServiceSubs <- TM.emptyIO
+  pendingQueueSubs <- TM.emptyIO
   smpSubWorkers <- TM.emptyIO
   workerSeq <- newTVarIO 0
   pure
     SMPClientAgent
       { agentCfg,
+        agentParty,
         active,
         startedAt,
         msgQ,
@@ -131,18 +179,20 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
         randomDrg,
         smpClients,
         smpSessions,
-        srvSubs,
-        pendingSrvSubs,
+        activeServiceSubs,
+        activeQueueSubs,
+        pendingServiceSubs,
+        pendingQueueSubs,
         smpSubWorkers,
         workerSeq
       }
 
 -- | Get or create SMP client for SMPServer
-getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
+getSMPServerClient' :: SMPClientAgent p -> SMPServer -> ExceptT SMPClientError IO SMPClient
 getSMPServerClient' ca srv = snd <$> getSMPServerClient'' ca srv
 {-# INLINE getSMPServerClient' #-}
 
-getSMPServerClient'' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
+getSMPServerClient'' :: SMPClientAgent p -> 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
@@ -153,7 +203,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
     waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
     waitForSMPClient v = do
       let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
+      smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
       case smpClient_ of
         Just (Right smpClient) -> pure smpClient
         Just (Left (e, ts_)) -> case ts_ of
@@ -176,7 +226,8 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
           atomically $ do
             putTMVar (sessionVar v) (Right c)
             TM.insert (sessionId $ thParams smp) c smpSessions
-          notify ca $ CAConnected srv
+          let serviceId_ = (\THClientService {serviceId} -> serviceId) <$> smpClientService smp
+          notify ca $ CAConnected srv serviceId_
           pure $ Right c
         Left e -> do
           let ei = persistErrorInterval agentCfg
@@ -190,49 +241,68 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
           reconnectClient ca srv
           pure $ Left e
 
-isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer
+isOwnServer :: SMPClientAgent p -> 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 -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
+connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
 connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
-  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
+  getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
   where
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected smp = do
-      removeClientAndSubs smp >>= (`forM_` serverDown)
+      removeClientAndSubs smp >>= serverDown
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    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
+    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)
       where
         sessId = sessionId $ thParams smp
-        updateSubs sVar = do
+        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
           -- removing subscriptions that have matching sessionId to disconnected client
           -- and keep the other ones (they can be made by the new client)
-          pending <- M.map snd <$> stateTVar sVar (M.partition ((sessId ==) . fst))
-          addSubs_ (pendingSrvSubs ca) srv pending
-          pure pending
+          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
 
-    serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
-    serverDown ss = unless (M.null ss) $ do
-      notify ca . CADisconnected srv $ M.keysSet ss
-      reconnectClient ca srv
+    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
 
 -- | Spawn reconnect worker if needed
-reconnectClient :: SMPClientAgent -> SMPServer -> IO ()
+reconnectClient :: SMPClientAgent p -> 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)
+        (noPending <$> getPending TM.lookup readTVar)
         (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
         (Just <$> getSessVar workerSeq srv smpSubWorkers ts)
     newSubWorker :: SessionVar (Async ()) -> IO ()
@@ -241,13 +311,17 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       atomically $ putTMVar (sessionVar v) a
     runSubWorker =
       withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
-        pending <- liftIO getPending
-        unless (null pending) $ whenM (readTVarIO active) $ do
-          void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending)
+        subs <- getPending TM.lookupIO readTVarIO
+        unless (noPending subs) $ whenM (readTVarIO active) $ do
+          void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
           loop
     ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-    noPending = maybe (pure True) (fmap M.null . readTVar) =<< TM.lookup srv (pendingSrvSubs ca)
-    getPending = maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (pendingSrvSubs ca)
+    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)
     cleanup :: SessionVar (Async ()) -> STM ()
     cleanup v = do
       -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
@@ -255,32 +329,28 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       whenM (isEmptyTMVar $ sessionVar v) retry
       removeSessVar v srv smpSubWorkers
 
-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
+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 ()
   where
-    groupSub :: Map SMPSub (SessionId, C.APrivateAuthKey) -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
-    groupSub currSubs (s@(party, qId), k) acc@(nSubs, rSubs)
-      | M.member s currSubs = acc
-      | 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)
+    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'
 
-notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
+notify :: MonadIO m => SMPClientAgent p -> 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 -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
+getConnectedSMPServerClient :: SMPClientAgent p -> 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
@@ -293,10 +363,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 -> SessionId -> IO (Maybe (OwnServer, SMPClient))
+lookupSMPServerClient :: SMPClientAgent p -> SessionId -> IO (Maybe (OwnServer, SMPClient))
 lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookupIO sessId smpSessions
 
-closeSMPClientAgent :: SMPClientAgent -> IO ()
+closeSMPClientAgent :: SMPClientAgent p -> IO ()
 closeSMPClientAgent c = do
   atomically $ writeTVar (active c) False
   closeSMPServerClients c
@@ -305,7 +375,7 @@ closeSMPClientAgent c = do
     cancelReconnect :: SessionVar (Async ()) -> IO ()
     cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel
 
-closeSMPServerClients :: SMPClientAgent -> IO ()
+closeSMPServerClients :: SMPClientAgent p -> IO ()
 closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient)
   where
     closeClient v =
@@ -316,30 +386,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 -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
+withSMP :: SMPClientAgent p -> 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
-      liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
+      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode srv) <> "): " <> tshow e
       throwE e
 
-subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO ()
-subscribeQueuesSMP = subscribeQueues_ SPRecipient
+subscribeQueuesNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
+subscribeQueuesNtfs = subscribeQueues_
+{-# INLINE subscribeQueuesNtfs #-}
 
-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
+subscribeQueues_ :: ServiceParty p => SMPClientAgent p -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
+subscribeQueues_ ca srv subs = do
+  atomically $ addPendingSubs ca srv $ L.toList subs
   runExceptT (getSMPServerClient' ca srv) >>= \case
-    Right smp -> smpSubscribeQueues party ca smp srv subs
+    Right smp -> smpSubscribeQueues ca smp srv subs
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
 
-smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
-smpSubscribeQueues party ca smp srv subs = do
-  rs <- subscribe smp $ L.map swap subs
+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
   rs' <-
     atomically $
       ifM
@@ -347,79 +417,164 @@ smpSubscribeQueues party ca smp srv subs = do
         (Just <$> processSubscriptions rs)
         (pure Nothing)
   case rs' of
-    Just (tempErrs, finalErrs, oks, _) -> do
-      notify_ CASubscribed $ map fst oks
+    Just (tempErrs, finalErrs, (qOks, sQs), _) -> do
+      notify_ (`CASubscribed` Nothing) $ map fst qOks
+      when (isJust smpServiceId) $ notify_ (`CASubscribed` smpServiceId) sQs
       notify_ CASubError finalErrs
       when tempErrs $ reconnectClient ca srv
     Nothing -> reconnectClient ca srv
   where
-    processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
+    processSubscriptions :: NonEmpty (Either SMPClientError (Maybe ServiceId)) -> STM (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId])
     processSubscriptions rs = do
-      pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
-      let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs)
-      unless (null oks) $ addSubscriptions ca srv party oks
-      unless (null notPending) $ removePendingSubs ca srv party notPending
+      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
       pure acc
     sessId = sessionId $ thParams smp
-    groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
-    groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
-      Right ()
-        | M.member (party, qId) pending -> (tempErrs, finalErrs, (qId, (sessId, pk)) : oks, qId : notPending)
+    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)
         | otherwise -> acc
       Left e
         | temporaryClientError e -> (True, finalErrs, oks, notPending)
         | otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending)
-    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
+    notify_ :: (SMPServer -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
+    notify_ evt qs = mapM_ (notify ca . evt srv) $ L.nonEmpty qs
 
-activeClientSession' :: SMPClientAgent -> SessionId -> SMPServer -> STM Bool
+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' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
   where
     sameSess = \case
       Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
       _ -> False
 
-activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
+activeClientSession :: SMPClientAgent p -> 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)
 
-addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
-addSubscriptions = addSubsList_ . srvSubs
-{-# INLINE addSubscriptions #-}
+addActiveSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
+addActiveSubs = addSubsList_ . activeQueueSubs
+{-# INLINE addActiveSubs #-}
 
-addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
-addPendingSubs = addSubsList_ . pendingSrvSubs
+addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> STM ()
+addPendingSubs = addSubsList_ . pendingQueueSubs
 {-# INLINE addPendingSubs #-}
 
-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
+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
 
-addSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> Map SMPSub s -> STM ()
+addSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> STM ()
 addSubs_ subs srv ss =
   TM.lookup srv subs >>= \case
     Just m -> TM.union ss m
-    _ -> newTVar ss >>= \v -> TM.insert srv v subs
+    _ -> TM.insertM srv (newTVar ss) subs
 
-removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removeSubscription = removeSub_ . srvSubs
-{-# INLINE removeSubscription #-}
+setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe ((ServiceId, Int64), SessionId) -> STM ()
+setActiveServiceSub = setServiceSub_ activeServiceSubs
+{-# INLINE setActiveServiceSub #-}
 
-removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM ()
+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
+{-# INLINE removePendingSub #-}
+
+removeSub_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> QueueId -> STM ()
 removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
 
-removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
-removePendingSubs = removeSubs_ . pendingSrvSubs
+removeActiveSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
+removeActiveSubs = removeSubs_ . activeQueueSubs
+{-# INLINE removeActiveSubs #-}
+
+removePendingSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
+removePendingSubs = removeSubs_ . pendingQueueSubs
 {-# INLINE removePendingSubs #-}
 
-removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> 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
+removeSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [QueueId] -> STM ()
+removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` S.fromList qs))

src/Simplex/Messaging/Crypto.hs

@@ -64,6 +64,7 @@ module Simplex.Messaging.Crypto
     AAuthKeyPair,
     KeyPair,
     KeyPairX25519,
+    KeyPairEd25519,
     ASignatureKeyPair,
     DhSecret (..),
     DhSecretX25519,
@@ -78,7 +79,9 @@ module Simplex.Messaging.Crypto
     generateDhKeyPair,
     privateToX509,
     x509ToPublic,
+    x509ToPublic',
     x509ToPrivate,
+    x509ToPrivate',
     publicKey,
     signatureKeyPair,
     publicToX509,
@@ -179,8 +182,6 @@ module Simplex.Messaging.Crypto
     unPad,
 
     -- * X509 Certificates
-    SignedCertificate,
-    Certificate,
     signCertificate,
     signX509,
     verifyX509,
@@ -240,7 +241,7 @@ import Data.String
 import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
 import Data.Word (Word32)
-import Data.X509
+import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
@@ -680,6 +681,8 @@ 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
 
@@ -1160,12 +1163,12 @@ sign :: APrivateSignKey -> ByteString -> ASignature
 sign (APrivateSignKey a k) = ASignature a . sign' k
 {-# INLINE sign #-}
 
-signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
+signCertificate :: APrivateSignKey -> X.Certificate -> X.SignedCertificate
 signCertificate = signX509
 {-# INLINE signCertificate #-}
 
-signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
-signX509 key = fst . objectToSignedExact f
+signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> X.SignedExact o
+signX509 key = fst . X.objectToSignedExact f
   where
     f bytes =
       ( signatureBytes $ sign key bytes,
@@ -1174,33 +1177,33 @@ signX509 key = fst . objectToSignedExact f
       )
 {-# INLINE signX509 #-}
 
-verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o
+verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> X.SignedExact o -> Either String o
 verifyX509 key exact = do
   signature <- case signedAlg of
-    SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
-    SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
+    X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
+    X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
     _ -> Left "unknown x509 signature algorithm"
-  if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature"
+  if verify key signature $ X.getSignedData exact then Right signedObject else Left "bad signature"
   where
-    Signed {signedObject, signedAlg, signedSignature} = getSigned exact
+    X.Signed {signedObject, signedAlg, signedSignature} = X.getSigned exact
 {-# INLINE verifyX509 #-}
 
-certificateFingerprint :: SignedCertificate -> KeyHash
+certificateFingerprint :: X.SignedCertificate -> KeyHash
 certificateFingerprint = signedFingerprint
 {-# INLINE certificateFingerprint #-}
 
-signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
+signedFingerprint :: (ASN1Object o, Eq o, Show o) => X.SignedExact o -> KeyHash
 signedFingerprint o = KeyHash fp
   where
-    Fingerprint fp = getFingerprint o HashSHA256
+    Fingerprint fp = getFingerprint o X.HashSHA256
 
 class SignatureAlgorithmX509 a where
-  signatureAlgorithmX509 :: a -> SignatureALG
+  signatureAlgorithmX509 :: a -> X.SignatureALG
 
 instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
   signatureAlgorithmX509 = \case
-    SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
-    SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
+    SEd25519 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519
+    SEd448 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448
   {-# INLINE signatureAlgorithmX509 #-}
 
 instance SignatureAlgorithmX509 APrivateSignKey where
@@ -1217,31 +1220,31 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
   {-# INLINE signatureAlgorithmX509 #-}
 
 -- | A wrapper to marshall signed ASN1 objects, like certificates.
-newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
+newtype SignedObject a = SignedObject {getSignedExact :: X.SignedExact a}
 
 instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
 #if defined(dbPostgres)
-  fromField f dat = SignedObject <$> blobFieldDecoder decodeSignedObject f dat
+  fromField f dat = SignedObject <$> blobFieldDecoder X.decodeSignedObject f dat
 #else
-  fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
+  fromField = fmap SignedObject . blobFieldDecoder X.decodeSignedObject
 #endif
 
 instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
-  toField (SignedObject s) = toField . Binary $ encodeSignedObject s
+  toField (SignedObject s) = toField . Binary $ X.encodeSignedObject s
 
 instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
-  smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
-  smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP
+  smpEncode (SignedObject exact) = smpEncode . Large $ X.encodeSignedObject exact
+  smpP = fmap SignedObject . X.decodeSignedObject . unLarge <$?> smpP
 
-encodeCertChain :: CertificateChain -> L.NonEmpty Large
+encodeCertChain :: X.CertificateChain -> L.NonEmpty Large
 encodeCertChain cc = L.fromList $ map Large blobs
   where
-    CertificateChainRaw blobs = encodeCertificateChain cc
+    X.CertificateChainRaw blobs = X.encodeCertificateChain cc
 
-certChainP :: A.Parser CertificateChain
+certChainP :: A.Parser X.CertificateChain
 certChainP = do
-  rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP
-  either (fail . show) pure $ decodeCertificateChain rawChain
+  rawChain <- X.CertificateChainRaw . map unLarge . L.toList <$> smpP
+  either (fail . show) pure $ X.decodeCertificateChain rawChain
 
 -- | Signature verification.
 --
@@ -1453,19 +1456,19 @@ xSalsa20 secret nonce msg = (rs, msg')
     (rs, state2) = XSalsa.generate state1 32
     (msg', _) = XSalsa.combine state2 msg
 
-publicToX509 :: PublicKey a -> PubKey
+publicToX509 :: PublicKey a -> X.PubKey
 publicToX509 = \case
-  PublicKeyEd25519 k -> PubKeyEd25519 k
-  PublicKeyEd448 k -> PubKeyEd448 k
-  PublicKeyX25519 k -> PubKeyX25519 k
-  PublicKeyX448 k -> PubKeyX448 k
+  PublicKeyEd25519 k -> X.PubKeyEd25519 k
+  PublicKeyEd448 k -> X.PubKeyEd448 k
+  PublicKeyX25519 k -> X.PubKeyX25519 k
+  PublicKeyX448 k -> X.PubKeyX448 k
 
-privateToX509 :: PrivateKey a -> PrivKey
+privateToX509 :: PrivateKey a -> X.PrivKey
 privateToX509 = \case
-  PrivateKeyEd25519 k _ -> PrivKeyEd25519 k
-  PrivateKeyEd448 k _ -> PrivKeyEd448 k
-  PrivateKeyX25519 k _ -> PrivKeyX25519 k
-  PrivateKeyX448 k _ -> PrivKeyX448 k
+  PrivateKeyEd25519 k _ -> X.PrivKeyEd25519 k
+  PrivateKeyEd448 k _ -> X.PrivKeyEd448 k
+  PrivateKeyX25519 k _ -> X.PrivKeyX25519 k
+  PrivateKeyX448 k _ -> X.PrivKeyX448 k
 
 encodeASNObj :: ASN1Object a => a -> ByteString
 encodeASNObj k = toStrict . encodeASN1 DER $ toASN1 k []
@@ -1478,22 +1481,30 @@ decodePubKey = decodeKey >=> x509ToPublic >=> pubKey
 decodePrivKey :: CryptoPrivateKey k => ByteString -> Either String k
 decodePrivKey = decodeKey >=> x509ToPrivate >=> privKey
 
-x509ToPublic :: (PubKey, [ASN1]) -> Either String APublicKey
+x509ToPublic :: (X.PubKey, [ASN1]) -> Either String APublicKey
 x509ToPublic = \case
-  (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
+  (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
   r -> keyError r
 
-x509ToPrivate :: (PrivKey, [ASN1]) -> Either String APrivateKey
+x509ToPublic' :: CryptoPublicKey k => X.PubKey -> Either String k
+x509ToPublic' k = x509ToPublic (k, []) >>= pubKey
+{-# INLINE x509ToPublic' #-}
+
+x509ToPrivate :: (X.PrivKey, [ASN1]) -> Either String APrivateKey
 x509ToPrivate = \case
-  (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
+  (X.PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k
+  (X.PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k
+  (X.PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 . PrivateKeyX25519 k $ X25519.toPublic k
+  (X.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,8 +55,10 @@ module Simplex.Messaging.Crypto.Ratchet
     supportedE2EEncryptVRange,
     generateRcvE2EParams,
     generateSndE2EParams,
+    mkRcvE2ERatchetParams,
     initialPQEncryption,
     connPQEncryption,
+    joinContactInitialKeys,
     replyKEM_,
     pqSupportToEnc,
     pqEncToSupport,
@@ -195,6 +197,8 @@ data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RK
 
 deriving instance Show ARKEMParams
 
+type RcvRKEMParams = RKEMParams 'RKSProposed
+
 instance RatchetKEMStateI s => Encoding (RKEMParams s) where
   smpEncode = \case
     RKParamsProposed k -> smpEncode ('P', k)
@@ -308,7 +312,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
@@ -405,6 +409,12 @@ data UseKEM (s :: RatchetKEMState) where
 
 data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
 
+mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
+mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem)
+  where
+    mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
+    mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k
+
 generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
 generateE2EParams g v useKEM_ = do
   (k1, pk1) <- atomically $ generateKeyPair g
@@ -851,32 +861,39 @@ instance StrEncoding PQSupport where
   strP = pqEncToSupport <$> strP
   {-# INLINE strP #-}
 
-data InitialKeys = IKUsePQ | IKNoPQ PQSupport
+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
   deriving (Eq, Show)
 
 pattern IKPQOn :: InitialKeys
-pattern IKPQOn = IKNoPQ PQSupportOn
+pattern IKPQOn = IKLinkPQ PQSupportOn
 
 pattern IKPQOff :: InitialKeys
-pattern IKPQOff = IKNoPQ PQSupportOff
+pattern IKPQOff = IKLinkPQ PQSupportOff
 
 instance StrEncoding InitialKeys where
   strEncode = \case
     IKUsePQ -> "pq=invitation"
-    IKNoPQ pq -> strEncode pq
-  strP = IKNoPQ <$> strP <|> "pq=invitation" $> IKUsePQ
+    IKLinkPQ pq -> strEncode pq
+  strP = IKLinkPQ <$> strP <|> "pq=invitation" $> IKUsePQ
 
 -- determines whether PQ key should be included in invitation link
-initialPQEncryption :: InitialKeys -> PQSupport
-initialPQEncryption = \case
+initialPQEncryption :: Bool -> InitialKeys -> PQSupport
+initialPQEncryption shortLink = \case
   IKUsePQ -> PQSupportOn
-  IKNoPQ _ -> PQSupportOff -- default
+  IKLinkPQ (PQSupport enable) -> PQSupport $ enable && shortLink
 
 -- determines whether PQ encryption should be used in connection
 connPQEncryption :: InitialKeys -> PQSupport
 connPQEncryption = \case
   IKUsePQ -> PQSupportOn
-  IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn
+  IKLinkPQ pq -> pq -- default for creating connection is IKLinkPQ PQEncOn
+
+joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
+joinContactInitialKeys pqCompatible = \case
+  PQSupportOn | pqCompatible -> IKUsePQ
+  pqEnc -> IKLinkPQ pqEnc
 
 rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
 rcCheckCanPad paddedMsgLen msg =
@@ -1187,7 +1204,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,11 +10,10 @@ 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 (withDRG)
+import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (rngFuncPtr, withDRG)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 
@@ -43,7 +42,7 @@ sntrup761Keypair drg =
       c_SNTRUP761_SECRETKEY_SIZE
       ( \skPtr ->
           BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr ->
-            withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr
+            withDRG drg $ \cxtPtr -> c_sntrup761_keypair pkPtr skPtr cxtPtr rngFuncPtr
       )
 
 sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
@@ -54,7 +53,7 @@ sntrup761Enc drg (KEMPublicKey pk) =
         c_SNTRUP761_SIZE
         ( \kPtr ->
             BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr ->
-              withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr
+              withDRG drg $ \cxtPtr -> c_sntrup761_enc cPtr kPtr pkPtr cxtPtr rngFuncPtr
         )
 
 sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey

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

@@ -1,5 +1,6 @@
 module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
   ( withDRG,
+    rngFuncPtr,
     RNGContext,
     RNGFunc,
   ) where
@@ -12,19 +13,20 @@ import Foreign
 import Foreign.C
 import qualified Simplex.Messaging.Crypto as C
 
-withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a
-withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr
+withDRG :: TVar ChaChaDRG -> (Ptr RNGContext -> IO a) -> IO a
+withDRG drg = bracket (castStablePtrToPtr <$> newStablePtr drg) (freeStablePtr . castPtrToStablePtr)
 
-createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc)
-createRNGFunc drg =
-  mkRNGFunc $ \_ctx sz buf -> do
-    bs <- atomically $ C.randomBytes (fromIntegral sz) drg
-    copyByteArrayToPtr bs buf
+rngFunc :: RNGFunc
+rngFunc cxt sz buf = do
+  drg <- deRefStablePtr $ castPtrToStablePtr cxt
+  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 import ccall "wrapper"
-  mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc)
+foreign export ccall "haskell_rng_func" rngFunc :: RNGFunc
+
+foreign import ccall "&haskell_rng_func" rngFuncPtr :: FunPtr RNGFunc

src/Simplex/Messaging/Crypto/ShortLink.hs

@@ -48,17 +48,17 @@ contactShortLinkKdf (LinkKey k) =
 invShortLinkKdf :: LinkKey -> C.SbKey
 invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
 
-encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
+encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> UserLinkData -> (LinkKey, (ByteString, ByteString))
 encodeSignLinkData (rootKey, pk) agentVRange connReq userData =
   let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq}
       md = smpEncode $ connLinkData @c agentVRange userData
    in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md))
 
-encodeSignUserData :: C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString
-encodeSignUserData pk agentVRange userData =
-  encodeSign pk $ smpEncode $ connLinkData @'CMContact agentVRange userData
+encodeSignUserData :: forall c. ConnectionModeI c => SConnectionMode c -> C.PrivateKeyEd25519 -> VersionRangeSMPA -> UserLinkData -> ByteString
+encodeSignUserData _ pk agentVRange userData =
+  encodeSign pk $ smpEncode $ connLinkData @c agentVRange userData
 
-connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> ConnInfo -> ConnLinkData c
+connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> UserLinkData -> ConnLinkData c
 connLinkData agentVRange userData = case sConnectionMode @c of
   SCMInvitation -> InvitationLinkData agentVRange userData
   SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData}

src/Simplex/Messaging/Encoding.hs

@@ -143,7 +143,7 @@ instance Encoding Large where
 instance Encoding SystemTime where
   smpEncode = smpEncode . systemSeconds
   {-# INLINE smpEncode #-}
-  smpP = MkSystemTime <$> smpP <*> pure 0
+  smpP = (`MkSystemTime` 0) <$> smpP
   {-# INLINE smpP #-}
 
 _smpP :: Encoding a => Parser a

src/Simplex/Messaging/Encoding/String.hs

@@ -39,9 +39,11 @@ 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, (<$?>))
+import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
 
 class TextEncoding a where
   textEncode :: a -> Text
@@ -89,6 +91,10 @@ 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
@@ -140,11 +146,23 @@ instance StrEncoding Int64 where
 
 instance StrEncoding SystemTime where
   strEncode = strEncode . systemSeconds
-  strP = MkSystemTime <$> strP <*> pure 0
+  strP = (`MkSystemTime` 0) <$> strP
 
 instance StrEncoding UTCTime where
   strEncode = B.pack . iso8601Show
-  strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
+  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

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

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -154,10 +154,15 @@ 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
@@ -209,7 +214,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
@@ -249,7 +254,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfCmd where
   fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
+  checkCredentials tAuth entId (NtfCmd e c) = NtfCmd e <$> checkCredentials tAuth entId c
 
 data NtfResponseTag
   = NRTknId_
@@ -329,7 +334,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
@@ -478,6 +483,8 @@ 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)
@@ -491,6 +498,7 @@ ntfShouldSubscribe = \case
   NSEnd -> False
   NSDeleted -> False
   NSAuth -> False
+  NSService -> True
   NSErr _ -> False
 
 instance Encoding NtfSubStatus where
@@ -502,6 +510,7 @@ instance Encoding NtfSubStatus where
     NSEnd -> "END"
     NSDeleted -> "DELETED"
     NSAuth -> "AUTH"
+    NSService -> "SERVICE"
     NSErr err -> "ERR " <> err
   smpP =
     A.takeTill (== ' ') >>= \case
@@ -512,12 +521,15 @@ 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"
 
 instance StrEncoding NtfSubStatus where
   strEncode = smpEncode
+  {-# INLINE strEncode #-}
   strP = smpP
+  {-# INLINE strP #-}
 
 data NtfTknStatus
   = -- | Token created in DB
@@ -534,6 +546,26 @@ data NtfTknStatus
     NTExpired
   deriving (Eq, Show)
 
+allowTokenVerification :: NtfTknStatus -> Bool
+allowTokenVerification = \case
+  NTNew -> False
+  NTRegistered -> True
+  NTInvalid _ -> False
+  NTConfirmed -> True
+  NTActive -> True
+  NTExpired -> False
+
+allowNtfSubCommands :: NtfTknStatus -> Bool
+allowNtfSubCommands = \case
+  NTNew -> False
+  NTRegistered -> False
+  -- TODO we could have separate statuses to show whether it became invalid
+  -- after verification (allow commands) or before (do not allow)
+  NTInvalid _ -> True
+  NTConfirmed -> False
+  NTActive -> True
+  NTExpired -> True
+
 instance Encoding NtfTknStatus where
   smpEncode = \case
     NTNew -> "NEW"

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -8,60 +9,72 @@
 module Simplex.Messaging.Notifications.Server.Env where
 
 import Control.Concurrent (ThreadId)
-import Control.Concurrent.Async (Async)
 import Control.Logger.Simple
+import Control.Monad
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
-import Data.Word (Word16)
-import Data.X509.Validation (Fingerprint (..))
+import qualified Data.X509.Validation as XV
 import Network.Socket
-import qualified Network.TLS as T
+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
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Stats
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Server.StoreLog
+import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
+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, SMPServer, Transmission)
+import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), Transmission)
+import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
+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 (ATransport, THandleParams, TransportPeer (..))
+import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), ServiceCredentials (..), THandleParams, TransportPeer (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
-import System.IO (IOMode (..))
+import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data NtfServerConfig = NtfServerConfig
-  { transports :: [(ServiceName, ATransport, AddHTTP)],
+  { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
     controlPort :: Maybe ServiceName,
     controlPortUserAuth :: Maybe BasicAuth,
     controlPortAdminAuth :: Maybe BasicAuth,
     subIdBytes :: Int,
     regCodeBytes :: Int,
     clientQSize :: Natural,
-    subQSize :: Natural,
     pushQSize :: Natural,
     smpAgentCfg :: SMPClientAgentConfig,
     apnsConfig :: APNSPushClientConfig,
     subsBatchSize :: Int,
     inactiveClientExpiration :: Maybe ExpirationConfig,
-    storeLogFile :: Maybe FilePath,
-    storeLastNtfsFile :: Maybe FilePath,
+    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,
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
+    -- | interval and file to save prometheus metrics
+    prometheusInterval :: Maybe Int,
+    prometheusMetricsFile :: FilePath,
     ntfServerVRange :: VersionRangeNTF,
-    transportConfig :: TransportServerConfig
+    transportConfig :: TransportServerConfig,
+    startOptions :: StartOptions
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig
@@ -75,71 +88,75 @@ data NtfEnv = NtfEnv
   { config :: NtfServerConfig,
     subscriber :: NtfSubscriber,
     pushServer :: NtfPushServer,
-    store :: NtfStore,
-    storeLog :: Maybe (StoreLog 'WriteMode),
+    store :: NtfPostgresStore,
     random :: TVar ChaChaDRG,
-    tlsServerCreds :: T.Credential,
+    tlsServerCreds :: TLS.Credential,
     serverIdentity :: C.KeyHash,
     serverStats :: NtfServerStats
   }
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do
+newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
+  when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
   random <- C.newRandom
-  store <- newNtfStore
-  logInfo "restoring subscriptions..."
-  storeLog <- mapM (`readWriteNtfStore` store) storeLogFile
-  logInfo "restored subscriptions"
-  subscriber <- newNtfSubscriber subQSize smpAgentCfg random
-  pushServer <- newNtfPushServer pushQSize apnsConfig
+  store <- newNtfDbStore dbStoreConfig
   tlsServerCreds <- loadServerCredential ntfCredentials
-  Fingerprint fp <- loadFingerprint 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
+  pushServer <- newNtfPushServer pushQSize apnsConfig
   serverStats <- newNtfServerStats =<< getCurrentTime
-  pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
+  pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
+  where
+    compactDbStoreLog = \case
+      Just f -> do
+        logNote $ "compacting store log " <> T.pack f
+        newNtfSTMStore >>= readWriteNtfSTMStore False f >>= closeStoreLog
+      Nothing -> do
+        logError "Error: `--compact-log` used without `enable: on` option in STORE_LOG section of INI file"
+        exitFailure
 
 data NtfSubscriber = NtfSubscriber
-  { smpSubscribers :: TMap SMPServer SMPSubscriber,
-    newSubQ :: TBQueue [NtfEntityRec 'Subscription],
-    smpAgent :: SMPClientAgent
+  { smpSubscribers :: TMap SMPServer SMPSubscriberVar,
+    subscriberSeq :: TVar Int,
+    smpAgent :: SMPClientAgent 'NotifierService
   }
 
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
-newNtfSubscriber qSize smpAgentCfg random = do
+type SMPSubscriberVar = SessionVar SMPSubscriber
+
+newNtfSubscriber :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
+newNtfSubscriber smpAgentCfg random = do
   smpSubscribers <- TM.emptyIO
-  newSubQ <- newTBQueueIO qSize
-  smpAgent <- newSMPClientAgent smpAgentCfg random
-  pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
+  subscriberSeq <- newTVarIO 0
+  smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg random
+  pure NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent}
 
 data SMPSubscriber = SMPSubscriber
-  { newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)),
-    subThreadId :: TVar (Maybe (Weak ThreadId))
+  { smpServer :: SMPServer,
+    smpServerId :: Int64,
+    subscriberSubQ :: TQueue ServerNtfSub,
+    subThreadId :: Weak ThreadId
   }
 
-newSMPSubscriber :: IO SMPSubscriber
-newSMPSubscriber = do
-  newSubQ <- newTQueueIO
-  subThreadId <- newTVarIO Nothing
-  pure SMPSubscriber {newSubQ, subThreadId}
-
 data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (NtfTknData, PushNotification),
+  { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
     pushClients :: TMap PushProvider PushProviderClient,
-    intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
     apnsConfig :: APNSPushClientConfig
   }
 
-data IntervalNotifier = IntervalNotifier
-  { action :: Async (),
-    token :: NtfTknData,
-    interval :: Word16
-  }
-
 newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
 newNtfPushServer qSize apnsConfig = do
   pushQ <- newTBQueueIO qSize
   pushClients <- TM.emptyIO
-  intervalNotifiers <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
+  pure NtfPushServer {pushQ, pushClients, apnsConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
@@ -159,7 +176,7 @@ data NtfRequest
   | NtfReqPing CorrId NtfEntityId
 
 data NtfServerClient = NtfServerClient
-  { rcvQ :: TBQueue (NonEmpty (Maybe NtfTknData, NtfRequest)),
+  { rcvQ :: TBQueue (NonEmpty NtfRequest),
     sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)),
     ntfThParams :: THandleParams NTFVersion 'TServer,
     connected :: TVar Bool,

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

@@ -10,30 +10,49 @@
 
 module Simplex.Messaging.Notifications.Server.Main where
 
+import Control.Logger.Simple (setLogLevel)
 import Control.Monad ((<$!>))
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
+import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.IO as T
-import Network.Socket (HostName)
+import Network.Socket (HostName, ServiceName)
 import Options.Applicative
-import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
+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.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Server (runNtfServer)
+import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
+import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs)
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
-import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
+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.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
 import Simplex.Messaging.Server.CLI
+import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion)
+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.Client (TransportHost (..))
-import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
-import Simplex.Messaging.Util (tshow)
-import System.Directory (createDirectoryIfMissing, doesFileExist)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
+import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig)
+import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
+import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
+import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
@@ -45,14 +64,8 @@ ntfServerCLI cfgPath logPath =
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
-    OnlineCert certOpts ->
-      doesFileExist iniFile >>= \case
-        True -> genOnline cfgPath certOpts
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts
+    Start opts -> withIniFile $ runServer opts
     Delete -> do
       confirmOrExit
         "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
@@ -60,13 +73,75 @@ ntfServerCLI cfgPath logPath =
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
+    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+      schemaExists <- checkSchemaExists connstr schema
+      storeLogExists <- doesFileExist storeLogFilePath
+      lastNtfsExists <- doesFileExist defaultLastNtfsFile
+      case cmd of
+        SCImport skipTokens
+          | schemaExists && (storeLogExists || lastNtfsExists) -> exitConfigureNtfStore connstr schema
+          | schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | not storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file does not exist."
+              exitFailure
+          | not lastNtfsExists -> do
+              putStrLn $ defaultLastNtfsFile <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              storeLogFile <- getRequiredStoreLogFile ini
+              confirmOrExit
+                ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Notification server store not imported"
+              stmStore <- newNtfSTMStore
+              sl <- readWriteNtfSTMStore True storeLogFile stmStore
+              closeStoreLog sl
+              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
+              renameFile storeLogFile $ storeLogFile <> ".bak"
+              putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show serviceCnt <> " service associations, " <> show nCnt <> " last token notifications."
+              putStrLn "Configure database options in INI file."
+        SCExport
+          | schemaExists && storeLogExists -> exitConfigureNtfStore connstr schema
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file already exists."
+              exitFailure
+          | lastNtfsExists -> do
+              putStrLn $ defaultLastNtfsFile <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                "Notification server store not imported"
+              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Just storeLogFilePath, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
+              st <- newNtfDbStore storeCfg
+              (tCnt, sCnt, nCnt) <- exportNtfDbStore st defaultLastNtfsFile
+              putStrLn $ "Export completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications."
   where
+    withIniFile a =
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError a
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    getRequiredStoreLogFile ini = do
+      case enableStoreLog' ini $> storeLogFilePath of
+        Just storeLogFile -> do
+          ifM
+            (doesFileExist storeLogFile)
+            (pure storeLogFile)
+            (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
+        Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
     iniFile = combine cfgPath "ntf-server.ini"
-    serverVersion = "SMP notifications server v" <> simplexMQVersion
+    serverVersion = "SMP notifications server v" <> simplexmqVersionCommit
     defaultServerPort = "443"
     executableName = "ntf-server"
     storeLogFilePath = combine logPath "ntf-server-store.log"
-    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+    initializeServer InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn} = do
       clearDirIfExists cfgPath
       clearDirIfExists logPath
       createDirectoryIfMissing True cfgPath
@@ -88,10 +163,14 @@ ntfServerCLI cfgPath logPath =
           \# and restoring it when the server is started.\n\
           \# Log is compacted on start (deleted objects are removed).\n"
             <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-            <> "# Last notifications are optionally saved and restored when the server restarts,\n\
-               \# they are preserved in the .bak file until the next restart.\n"
-            <> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n")
+            <> "# Database connection settings for PostgreSQL database.\n"
+            <> iniDbOpts dbOptions defaultNtfDBOpts
+            <> "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\
@@ -120,31 +199,37 @@ 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"
             <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
             <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
-    runServer ini = do
+    enableStoreLog' = settingIsOn "STORE_LOG" "enable"
+    runServer startOptions ini = do
+      setLogLevel $ logLevel startOptions
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
+          cfg@NtfServerConfig {transports} = serverConfig
           srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
       printServiceInfo serverVersion srv
-      printServerConfig transports storeLogFile
+      printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
       where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        restoreLastNtfsFile path = case iniOnOff "STORE_LOG" "restore_last_notifications" ini of
-          Just True -> Just path
-          Just False -> Nothing
-          -- if the setting is not set, it is enabled when store log is enabled
-          _ -> enableStoreLog $> path
+        dbStoreLogPath = enableStoreLog' ini $> storeLogFilePath
+        dbStoreConfig =
+          PostgresStoreCfg
+            { dbOpts = iniDBOptions ini defaultNtfDBOpts,
+              dbStoreLogPath,
+              confirmMigrations = MCYesUp,
+              deletedTTL = iniDeletedTTL ini
+            }
         serverConfig =
           NtfServerConfig
             { transports = iniTransports ini,
@@ -154,8 +239,7 @@ ntfServerCLI cfgPath logPath =
               subIdBytes = 24,
               regCodeBytes = 32,
               clientQSize = 64,
-              subQSize = 512,
-              pushQSize = 16384,
+              pushQSize = 32768,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
                   { smpCfg =
@@ -166,6 +250,7 @@ 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
                               }
                         },
@@ -180,48 +265,95 @@ ntfServerCLI cfgPath logPath =
                     { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
                       checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
                     },
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeLastNtfsFile = restoreLastNtfsFile $ combine logPath "ntf-server-last-notifications.log",
+              dbStoreConfig,
               ntfCredentials =
                 ServerCredentials
                   { caCertificateFile = Just $ c caCrtFile,
                     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
               serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
+              prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
+              prometheusMetricsFile = combine logPath "ntf-server-metrics.txt",
               ntfServerVRange = supportedServerNTFVRange,
               transportConfig =
-                defaultTransportServerConfig
-                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  }
+                mkTransportServerConfig
+                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
+                  (Just $ alpnSupportedNTFHandshakes <> httpALPN)
+                  False,
+              startOptions
             }
+    iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
+    defaultLastNtfsFile = combine logPath "ntf-server-last-notifications.log"
+    exitConfigureNtfStore connstr schema = do
+      putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
+      putStrLn "Configure notification server storage."
+      exitFailure
+
+printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
+printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
+  B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
+  printServerConfig "NTF" transports dbStoreLogPath
 
 data CliCommand
   = Init InitOptions
   | OnlineCert CertOptions
-  | Start
+  | Start StartOptions
   | Delete
+  | Database StoreCmd DBOpts
+
+data StoreCmd = SCImport (Set NtfTokenId) | SCExport
 
 data InitOptions = InitOptions
   { enableStoreLog :: Bool,
+    dbOptions :: DBOpts,
     signAlgorithm :: SignAlgorithm,
     ip :: HostName,
     fqdn :: Maybe HostName
   }
   deriving (Show)
 
+defaultNtfDBOpts :: DBOpts
+defaultNtfDBOpts =
+  DBOpts
+    { connstr = "postgresql://ntf@/ntf_server_store",
+      schema = "ntf_server",
+      poolSize = 10,
+      createSchema = False
+    }
+
+-- time to retain deleted tokens and subscriptions in the database (days), for debugging
+defaultDeletedTTL :: Int64
+defaultDeletedTTL = 21
+
 cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
     ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
         <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultNtfDBOpts) (progDesc "Import/export notifications server store to/from PostgreSQL database"))
     )
   where
+    databaseCmdP =
+      hsubparser
+        ( command "import" (info (SCImport <$> skipTokensP) (progDesc $ "Import store logs into a new PostgreSQL database schema"))
+            <> command "export" (info (pure SCExport) (progDesc $ "Export PostgreSQL database schema to store logs"))
+        )
+    skipTokensP :: Parser (Set NtfTokenId)
+    skipTokensP =
+      option
+        strParse
+          ( long "skip-tokens"
+              <> help "Skip tokens during import"
+              <> value S.empty
+          )
     initP :: Parser InitOptions
     initP = do
       enableStoreLog <-
@@ -234,6 +366,7 @@ cliCommandP cfgPath logPath iniFile =
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"
             )
+      dbOptions <- dbOptsP defaultNtfDBOpts
       signAlgorithm <-
         option
           (maybeReader readMaybe)
@@ -261,4 +394,4 @@ cliCommandP cfgPath logPath iniFile =
               <> showDefault
               <> metavar "FQDN"
           )
-      pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn}
+      pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn}

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

@@ -0,0 +1,285 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
+
+module Simplex.Messaging.Notifications.Server.Prometheus where
+
+import Data.Int (Int64)
+import qualified Data.Map.Strict as M
+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 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,
+    activeTokensCounts :: PeriodStatCounts,
+    activeSubsCounts :: PeriodStatCounts,
+    tokenCount :: Int64,
+    approxSubCount :: Int64,
+    lastNtfCount :: Int64,
+    rtsOptions :: Text
+  }
+
+rtsOptionsEnv :: Text
+rtsOptionsEnv = "NTF_RTS_OPTIONS"
+
+data NtfRealTimeMetrics = NtfRealTimeMetrics
+  { threadsCount :: Int,
+    srvSubscribers :: NtfSMPWorkerMetrics,
+    srvClients :: NtfSMPWorkerMetrics,
+    srvSubWorkers :: NtfSMPWorkerMetrics,
+    ntfActiveServiceSubs :: NtfSMPSubMetrics,
+    ntfActiveQueueSubs :: NtfSMPSubMetrics,
+    ntfPendingServiceSubs :: NtfSMPSubMetrics,
+    ntfPendingQueueSubs :: NtfSMPSubMetrics,
+    smpSessionCount :: Int,
+    apnsPushQLength :: Natural
+  }
+
+data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int}
+
+data NtfSMPSubMetrics = NtfSMPSubMetrics {ownSrvSubs :: M.Map Text Int, otherServers :: Int, otherSrvSubCount :: Int}
+
+{-# FOURMOLU_DISABLE\n#-}
+ntfPrometheusMetrics :: NtfServerMetrics -> NtfRealTimeMetrics -> UTCTime -> Text
+ntfPrometheusMetrics sm rtm ts =
+  time <> tokens <> subscriptions <> notifications <> info
+  where
+    NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm
+    NtfRealTimeMetrics
+      { threadsCount,
+        srvSubscribers,
+        srvClients,
+        srvSubWorkers,
+        ntfActiveServiceSubs,
+        ntfActiveQueueSubs,
+        ntfPendingServiceSubs,
+        ntfPendingQueueSubs,
+        smpSessionCount,
+        apnsPushQLength
+      } = rtm
+    NtfServerStatsData
+      { _fromTime,
+        _tknCreated,
+        _tknVerified,
+        _tknDeleted,
+        _tknReplaced,
+        _subCreated,
+        _subDeleted,
+        _ntfReceived,
+        _ntfReceivedAuth,
+        _ntfDelivered,
+        _ntfFailed,
+        _ntfReceivedOwn,
+        _ntfReceivedAuthOwn,
+        _ntfDeliveredOwn,
+        _ntfFailedOwn,
+        _ntfCronDelivered,
+        _ntfCronFailed,
+        _ntfVrfQueued,
+        _ntfVrfDelivered,
+        _ntfVrfFailed,
+        _ntfVrfInvalidTkn
+      } = statsData
+    time =
+      "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
+      \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\
+      \\n"
+    tokens =
+      "# Tokens\n\
+      \# ------\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_created Created tokens\n\
+      \# TYPE simplex_ntf_tokens_created counter\n\
+      \simplex_ntf_tokens_created " <> mshow _tknCreated <> "\n# tknCreated\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_verified Verified tokens\n\
+      \# TYPE simplex_ntf_tokens_verified counter\n\
+      \simplex_ntf_tokens_verified " <> mshow _tknVerified <> "\n# tknVerified\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_deleted Deleted tokens\n\
+      \# TYPE simplex_ntf_tokens_deleted counter\n\
+      \simplex_ntf_tokens_deleted " <> mshow _tknDeleted <> "\n# tknDeleted\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_replaced Deleted tokens\n\
+      \# TYPE simplex_ntf_tokens_replaced counter\n\
+      \simplex_ntf_tokens_replaced " <> mshow _tknReplaced <> "\n# tknReplaced\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_daily Daily active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_daily gauge\n\
+      \simplex_ntf_tokens_count_daily " <> mstr (dayCount psTkns) <> "\n# dayCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_weekly Weekly active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_weekly gauge\n\
+      \simplex_ntf_tokens_count_weekly " <> mstr (weekCount psTkns) <> "\n# weekCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_monthly Monthly active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_monthly gauge\n\
+      \simplex_ntf_tokens_count_monthly " <> mstr (monthCount psTkns) <> "\n# monthCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_total Total number of tokens stored.\n\
+      \# TYPE simplex_ntf_tokens_total gauge\n\
+      \simplex_ntf_tokens_total " <> mshow tokenCount <> "\n# tokenCount\n\
+      \\n"
+    subscriptions =
+      "# Subscriptions\n\
+      \# -------------\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_created Created subscriptions\n\
+      \# TYPE simplex_ntf_subscriptions_created counter\n\
+      \simplex_ntf_subscriptions_created " <> mshow _subCreated <> "\n# subCreated\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_deleted Deleted subscriptions\n\
+      \# TYPE simplex_ntf_subscriptions_deleted counter\n\
+      \simplex_ntf_subscriptions_deleted " <> mshow _subDeleted <> "\n# subDeleted\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_daily Daily subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_daily gauge\n\
+      \simplex_ntf_subscriptions_count_daily " <> mstr (dayCount psSubs) <> "\n# dayCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_weekly Weekly subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_weekly gauge\n\
+      \simplex_ntf_subscriptions_count_weekly " <> mstr (weekCount psSubs) <> "\n# weekCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_monthly Monthly subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_monthly gauge\n\
+      \simplex_ntf_subscriptions_count_monthly " <> mstr (monthCount psSubs) <> "\n# monthCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_approx_total Approximate total number of subscriptions stored.\n\
+      \# 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"
+    notifications =
+      "# Notifications\n\
+      \# -------------\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_received Received notifications\n\
+      \# 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\
+      \\n\
+      \# HELP simplex_ntf_notifications_failed Failed notifications\n\
+      \# TYPE simplex_ntf_notifications_failed counter\n\
+      \simplex_ntf_notifications_failed " <> mshow _ntfFailed <> "\n# ntfFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_periodic_delivered Delivered periodic notifications\n\
+      \# TYPE simplex_ntf_notifications_periodic_delivered counter\n\
+      \simplex_ntf_notifications_periodic_delivered " <> mshow _ntfCronDelivered <> "\n# ntfCronDelivered\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_periodic_failed Failed periodic notifications\n\
+      \# TYPE simplex_ntf_notifications_periodic_failed counter\n\
+      \simplex_ntf_notifications_periodic_failed " <> mshow _ntfCronFailed <> "\n# ntfCronFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_queued Token verifications queued\n\
+      \# TYPE simplex_ntf_notifications_verification_queued counter\n\
+      \simplex_ntf_notifications_verification_queued " <> mshow _ntfVrfQueued <> "\n# ntfVrfQueued\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_delivered Delivered token verifications\n\
+      \# TYPE simplex_ntf_notifications_verification_delivered counter\n\
+      \simplex_ntf_notifications_verification_delivered " <> mshow _ntfVrfDelivered <> "\n# ntfVrfDelivered\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_failed Failed token verification deliveries\n\
+      \# TYPE simplex_ntf_notifications_verification_failed counter\n\
+      \simplex_ntf_notifications_verification_failed " <> mshow _ntfVrfFailed <> "\n# ntfVrfFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_invalid_tkn Invalid token errors while delivering verifications\n\
+      \# TYPE simplex_ntf_notifications_verification_invalid_tkn counter\n\
+      \simplex_ntf_notifications_verification_invalid_tkn " <> mshow _ntfVrfInvalidTkn <> "\n# ntfVrfInvalidTkn\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_total Total number of last notifications stored.\n\
+      \# 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\
+      \\n\
+      \# HELP simplex_ntf_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
+      \# TYPE simplex_ntf_info gauge\n\
+      \simplex_ntf_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
+      \\n\
+      \# HELP simplex_ntf_threads_total Thread count\n\
+      \# TYPE simplex_ntf_threads_total gauge\n\
+      \simplex_ntf_threads_total " <> mshow threadsCount <> "\n# threadsCount\n\
+      \\n"
+      <> showWorkerMetric srvSubscribers "simplex_ntf_smp_subscribers_" "SMP subcscribers"
+      <> showWorkerMetric srvClients "simplex_ntf_smp_agent_clients_" "SMP agent clients"
+      <> showWorkerMetric srvSubWorkers "simplex_ntf_smp_agent_sub_workers_" "SMP agent subscription workers"
+      <> "# HELP simplex_ntf_smp_sessions_count SMP sessions count\n\
+      \# TYPE simplex_ntf_smp_sessions_count gauge\n\
+      \simplex_ntf_smp_sessions_count " <> mshow smpSessionCount <> "\n# smpSessionCount\n\
+      \\n\
+      \# HELP simplex_ntf_apns_push_queue_length Count of notifications in push queue\n\
+      \# TYPE simplex_ntf_apns_push_queue_length gauge\n\
+      \simplex_ntf_apns_push_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\
+      \\n"
+    showSubMetric NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} mPfx descrPfx =
+      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
+        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
+    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 =
+      "# HELP " <> name <> " " <> descr <> "\n\
+      \# TYPE " <> name <> " gauge\n"
+      <> T.concat (map (\(param, value) -> name <> param <> " " <> mshow value <> "\n") subMetrics)
+      <> "# " <> codeRef <> "\n\n"
+    metricHost host = "{server=\"" <> host <> "\"}"
+    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/Messaging/Notifications/Server/Push/APNS.hs

@@ -33,15 +33,19 @@ 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)
 import qualified Network.HTTP.Types as N
 import Network.HTTP2.Client (Request)
@@ -50,7 +54,7 @@ import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
-import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
+import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import Simplex.Messaging.Transport.HTTP2.Client
@@ -263,8 +267,8 @@ disconnectApnsHTTP2Client APNSPushClient {https2Client} =
 ntfCategoryCheckMessage :: Text
 ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
 
-apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
-apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
+apnsNotification :: NtfTknRec -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
+apnsNotification NtfTknRec {tknDhSecret} nonce paddedLen = \case
   PNVerification (NtfRegCode code) ->
     encrypt code $ \code' ->
       apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
@@ -313,7 +317,7 @@ data PushProviderError
   | PPPermanentError
   deriving (Show, Exception)
 
-type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
+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}
@@ -321,7 +325,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.randomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
@@ -330,9 +334,16 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
   let status = H.responseStatus response
       reason' = maybe "" reason $ J.decodeStrict' bodyHead
-  logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
+  if status == Just N.ok200
+    then logDebug $ "APNS response: ok" <> apnsIds response
+    else logWarn $ "APNS error: " <> T.pack (show status) <> " " <> reason' <> apnsIds response
   result status reason'
   where
+    apnsIds response = headerStr "apns-id" <> headerStr "apns-unique-id"
+      where
+        headerStr name =
+          maybe "" (\(_, v) -> ", " <> name <> ": " <> safeDecodeUtf8 v) $
+            find (\(t, _) -> HT.tokenKey t == CI.mk (encodeUtf8 name)) (fst (H.responseHeaders response))
     result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
     result status reason'
       | status == Just N.ok200 = pure ()

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

@@ -5,12 +5,17 @@
 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,
@@ -21,8 +26,13 @@ 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,
@@ -42,8 +52,13 @@ 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,
@@ -64,8 +79,13 @@ 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
@@ -84,8 +104,13 @@ newNtfServerStats ts = do
         subCreated,
         subDeleted,
         ntfReceived,
+        ntfReceivedAuth,
         ntfDelivered,
         ntfFailed,
+        ntfReceivedOwn,
+        ntfReceivedAuthOwn,
+        ntfDeliveredOwn,
+        ntfFailedOwn,
         ntfCronDelivered,
         ntfCronFailed,
         ntfVrfQueued,
@@ -106,8 +131,13 @@ 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
@@ -126,8 +156,13 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
         _subCreated,
         _subDeleted,
         _ntfReceived,
+        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
+        _ntfReceivedOwn,
+        _ntfReceivedAuthOwn,
+        _ntfDeliveredOwn,
+        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -149,8 +184,13 @@ 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
@@ -171,8 +211,13 @@ instance StrEncoding NtfServerStatsData where
         _subCreated,
         _subDeleted,
         _ntfReceived,
+        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
+        _ntfReceivedOwn,
+        _ntfReceivedAuthOwn,
+        _ntfDeliveredOwn,
+        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -191,8 +236,13 @@ 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,
@@ -213,8 +263,13 @@ 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="
@@ -235,8 +290,13 @@ instance StrEncoding NtfServerStatsData where
           _subCreated,
           _subDeleted,
           _ntfReceived,
+          _ntfReceivedAuth,
           _ntfDelivered,
           _ntfFailed,
+          _ntfReceivedOwn,
+          _ntfReceivedAuthOwn,
+          _ntfDeliveredOwn,
+          _ntfFailedOwn,
           _ntfCronDelivered,
           _ntfCronFailed,
           _ntfVrfQueued,
@@ -248,3 +308,26 @@ 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,45 +24,47 @@ 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)
+import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
 
-data NtfStore = NtfStore
+data NtfSTMStore = NtfSTMStore
   { tokens :: TMap NtfTokenId NtfTknData,
     -- multiple registrations exist to protect from malicious registrations if token is compromised
     tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
     subscriptions :: TMap NtfSubscriptionId NtfSubData,
     tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
     subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
-    tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
+    tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)),
+    ntfServices :: TMap SMPServer ServiceId
   }
 
-newNtfStore :: IO NtfStore
-newNtfStore = do
+newNtfSTMStore :: IO NtfSTMStore
+newNtfSTMStore = do
   tokens <- TM.emptyIO
   tokenRegistrations <- TM.emptyIO
   subscriptions <- TM.emptyIO
   tokenSubscriptions <- TM.emptyIO
   subscriptionLookup <- TM.emptyIO
   tokenLastNtfs <- TM.emptyIO
-  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
+  ntfServices <- TM.emptyIO
+  pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs, ntfServices}
 
 data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
     token :: DeviceToken,
     tknStatus :: TVar NtfTknStatus,
     tknVerifyKey :: NtfPublicAuthKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
+    tknDhKeys :: C.KeyPairX25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
     tknCronInterval :: TVar Word16,
     tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
   }
 
-mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
+mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
 mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
   tknStatus <- newTVarIO NTRegistered
   tknCronInterval <- newTVarIO 0
@@ -74,24 +76,18 @@ data NtfSubData = NtfSubData
     smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
-    subStatus :: TVar NtfSubStatus
+    subStatus :: TVar NtfSubStatus,
+    ntfServiceAssoc :: TVar Bool
   }
 
 ntfSubServer :: NtfSubData -> SMPServer
 ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
 
-data NtfEntityRec (e :: NtfEntity) where
-  NtfTkn :: NtfTknData -> NtfEntityRec 'Token
-  NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
+stmGetNtfTokenIO :: NtfSTMStore -> NtfTokenId -> IO (Maybe NtfTknData)
+stmGetNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
 
-getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getNtfToken st tknId = TM.lookup tknId (tokens st)
-
-getNtfTokenIO :: NtfStore -> NtfTokenId -> IO (Maybe NtfTknData)
-getNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
-
-addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
-addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
+stmAddNtfToken :: NtfSTMStore -> NtfTokenId -> NtfTknData -> STM ()
+stmAddNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
   TM.insert tknId tkn $ tokens st
   TM.lookup token regs >>= \case
     Just tIds -> TM.insert regKey tknId tIds
@@ -102,16 +98,8 @@ addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
 
-getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
-getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
-  TM.lookup token (tokenRegistrations st)
-    $>>= TM.lookup regKey
-    $>>= (`TM.lookup` tokens st)
-  where
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
-removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
+stmRemoveInactiveTokenRegistrations :: NtfSTMStore -> NtfTknData -> STM [NtfTokenId]
+stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
   TM.lookup token (tokenRegistrations st)
     >>= maybe (pure []) removeRegs
   where
@@ -125,8 +113,8 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
         void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
-removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
-removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
+stmRemoveTokenRegistration :: NtfSTMStore -> NtfTknData -> STM ()
+stmRemoveTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
   TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
   where
     removeReg regs =
@@ -134,8 +122,8 @@ removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
         >>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
     k = C.toPubKey C.pubKeyBytes tknVerifyKey
 
-deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
-deleteNtfToken st tknId = do
+stmDeleteNtfToken :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
+stmDeleteNtfToken st tknId = do
   void $
     TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} ->
       TM.lookup token regs $>>= \tIds ->
@@ -147,7 +135,7 @@ deleteNtfToken st tknId = do
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes
 
-deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
+deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
 deleteTokenSubs st tknId = do
   qs <-
     TM.lookupDelete tknId (tokenSubscriptions st)
@@ -159,32 +147,11 @@ deleteTokenSubs st tknId = do
         $>>= \NtfSubData {smpQueue} ->
           TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
 
-getNtfSubscriptionIO :: NtfStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
-getNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
+stmGetNtfSubscriptionIO :: NtfSTMStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
+stmGetNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
 
-findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
-findNtfSubscription st smpQueue = do
-  TM.lookup smpQueue (subscriptionLookup st)
-    $>>= \subId -> TM.lookup subId (subscriptions st)
-
-findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
-findNtfSubscriptionToken st smpQueue = do
-  findNtfSubscription st smpQueue
-    $>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
-
-getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getActiveNtfToken st tknId =
-  getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
-    tStatus <- readTVar tknStatus
-    pure $ if tStatus == NTActive then Just tkn else Nothing
-
-mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
-mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
-  subStatus <- newTVar NSNew
-  pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
-
-addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
-addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
+stmAddNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
+stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
   TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
   where
     newTokenSub = do
@@ -198,8 +165,8 @@ addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
       -- return Nothing if subscription existed before
       pure $ Just ()
 
-deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
-deleteNtfSubscription st subId = do
+stmDeleteNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> STM ()
+stmDeleteNtfSubscription st subId = do
   TM.lookupDelete subId (subscriptions st)
     >>= mapM_
       ( \NtfSubData {smpQueue, tokenId} -> do
@@ -208,32 +175,10 @@ deleteNtfSubscription st subId = do
           forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
       )
 
-addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData)
-addTokenLastNtf st tknId newNtf =
-  TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf)
-  where
-    maybeNewTokenLastNtfs =
-      TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf
-    newTokenLastNtfs = do
-      v <- newTVar [newNtf]
-      TM.insert tknId v $ tokenLastNtfs st
-      pure [newNtf]
-    addNtf v =
-      stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs')
-      where
-        rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData
-        rebuildList = foldr keepPrevNtf [newNtf]
-          where
-            PNMessageData {smpQueue = newNtfQ} = newNtf
-            keepPrevNtf ntf@PNMessageData {smpQueue} ntfs
-              | smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs
-              | otherwise = ntfs
-        maxNtfs = 6
-
 -- This function is expected to be called after store log is read,
 -- as it checks for token existence when adding last notification.
-storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO ()
-storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do
+stmStoreTokenLastNtf :: NtfSTMStore -> NtfTokenId -> PNMessageData -> IO ()
+stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
   TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|))
   where
     newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|))
@@ -241,6 +186,10 @@ storeTokenLastNtf (NtfStore {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

@@ -0,0 +1,106 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# 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)
+  ]
+
+-- | The list of migrations in ascending order by date
+ntfServerMigrations :: [Migration]
+ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up, down = down}
+
+m20250417_initial :: Text
+m20250417_initial =
+  T.pack
+    [r|
+CREATE TABLE tokens(
+  token_id BYTEA NOT NULL,
+  push_provider TEXT NOT NULL,
+  push_provider_token BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  verify_key BYTEA NOT NULL,
+  dh_priv_key BYTEA NOT NULL,
+  dh_secret BYTEA NOT NULL,
+  reg_code BYTEA NOT NULL,
+  cron_interval BIGINT NOT NULL, -- minutes
+  cron_sent_at BIGINT, -- seconds
+  updated_at BIGINT,
+  PRIMARY KEY (token_id)
+);
+
+CREATE UNIQUE INDEX idx_tokens_push_provider_token ON tokens(push_provider, push_provider_token, verify_key);
+CREATE INDEX idx_tokens_status_cron_interval_sent_at ON tokens(status, cron_interval, (cron_sent_at + cron_interval * 60));
+
+CREATE TABLE smp_servers(
+  smp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  smp_host TEXT NOT NULL,
+  smp_port TEXT NOT NULL,
+  smp_keyhash BYTEA NOT NULL
+);
+
+CREATE UNIQUE INDEX idx_smp_servers ON smp_servers(smp_host, smp_port, smp_keyhash);
+
+CREATE TABLE subscriptions(
+  subscription_id BYTEA NOT NULL,
+  token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
+  smp_server_id BIGINT REFERENCES smp_servers ON DELETE RESTRICT ON UPDATE RESTRICT,
+  smp_notifier_id BYTEA NOT NULL,
+  smp_notifier_key BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  PRIMARY KEY (subscription_id)
+);
+
+CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON subscriptions(smp_server_id, smp_notifier_id);
+CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
+CREATE INDEX idx_subscriptions_token_id ON subscriptions(token_id);
+
+CREATE TABLE last_notifications(
+  token_ntf_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
+  subscription_id BYTEA NOT NULL REFERENCES subscriptions ON DELETE CASCADE ON UPDATE RESTRICT,
+  sent_at TIMESTAMPTZ NOT NULL,
+  nmsg_nonce BYTEA NOT NULL,
+  nmsg_data BYTEA NOT NULL
+);
+
+CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token_id, sent_at);
+CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id);
+
+CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
+    |]
+
+m20250517_service_cert :: Text
+m20250517_service_cert =
+  T.pack
+    [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 =
+  T.pack
+    [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

@@ -0,0 +1,931 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-ambiguous-fields #-}
+
+module Simplex.Messaging.Notifications.Server.Store.Postgres where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Data.Bitraversable (bimapM)
+import qualified Data.ByteString.Base64.URL as B64
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Containers.ListUtils (nubOrd)
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Int (Int64)
+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 qualified Data.Set as S
+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 (..), systemToUTCTime, utcToSystemTime)
+import Data.Word (Word16)
+import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, ToRow, (:.) (..))
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Network.Socket (ServiceName)
+import Simplex.Messaging.Agent.Store.AgentStore ()
+import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer)
+import Simplex.Messaging.Notifications.Server.Store.Migrations
+import Simplex.Messaging.Notifications.Server.Store.Types
+import Simplex.Messaging.Notifications.Server.StoreLog
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId, pattern SMPServer)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
+import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_)
+import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
+import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
+import Simplex.Messaging.Transport.Client (TransportHost)
+import Simplex.Messaging.Util (anyM, firstRow, maybeFirstRow, toChunks, tshow)
+import System.Exit (exitFailure)
+import System.IO (IOMode (..), hFlush, stdout, withFile)
+import Text.Hex (decodeHex)
+
+#if !defined(dbPostgres)
+import Simplex.Messaging.Util (eitherToMaybe)
+#endif
+
+data NtfPostgresStore = NtfPostgresStore
+  { dbStore :: DBStore,
+    dbStoreLog :: Maybe (StoreLog 'WriteMode),
+    deletedTTL :: Int64
+  }
+
+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}
+
+ntfSubServer' :: NtfSubRec -> SMPServer
+ntfSubServer' NtfSubRec {smpQueue = SMPQueueNtf {smpServer}} = smpServer
+
+data NtfEntityRec (e :: NtfEntity) where
+  NtfTkn :: NtfTknRec -> NtfEntityRec 'Token
+  NtfSub :: NtfSubRec -> NtfEntityRec 'Subscription
+
+newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
+newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
+  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
+  dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
+  pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
+  where
+    err e = do
+      logError $ "STORE: newNtfStore, error opening PostgreSQL database, " <> tshow e
+      exitFailure
+
+closeNtfDbStore :: NtfPostgresStore -> IO ()
+closeNtfDbStore NtfPostgresStore {dbStore, dbStoreLog} = do
+  closeDBStore dbStore
+  mapM_ closeStoreLog dbStoreLog
+
+addNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
+addNtfToken st tkn =
+  withFastDB "addNtfToken" st $ \db ->
+    E.try (DB.execute db insertNtfTknQuery $ ntfTknToRow tkn)
+      >>= bimapM handleDuplicate (\_ -> withLog "addNtfToken" st (`logCreateToken` tkn))
+
+insertNtfTknQuery :: Query
+insertNtfTknQuery =
+  [sql|
+    INSERT INTO tokens
+      (token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at)
+    VALUES (?,?,?,?,?,?,?,?,?,?)
+  |]
+
+replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
+replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
+  withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do
+    ExceptT $ assertUpdated <$>
+      DB.execute
+        db
+        [sql|
+          UPDATE tokens
+          SET push_provider = ?, push_provider_token = ?, status = ?, reg_code = ?
+          WHERE token_id = ?
+        |]
+        (pp, Binary ppToken, tknStatus, Binary regCode, ntfTknId)
+    withLog "replaceNtfToken" st $ \sl -> logUpdateToken sl ntfTknId token code
+
+ntfTknToRow :: NtfTknRec -> NtfTknRow
+ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
+  let DeviceToken pp ppToken = token
+      NtfRegCode regCode = tknRegCode
+   in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)
+
+getNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType NtfTknRec)
+getNtfToken st tknId =
+  (maybe (Left AUTH) Right =<<) <$>
+    getNtfToken_ st " WHERE token_id = ?" (Only tknId)
+
+findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec))
+findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) =
+  getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey)
+
+getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec))
+getNtfToken_ st cond params =
+  withFastDB' "getNtfToken" st $ \db -> do
+    tkn_ <- maybeFirstRow rowToNtfTkn $ DB.query db (ntfTknQuery <> cond) params
+    mapM_ (updateTokenDate st db) tkn_
+    pure tkn_
+
+updateTokenDate :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> IO ()
+updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
+  ts <- getSystemDate
+  when (maybe True (ts /=) 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 RoundedSystemTime)
+
+ntfTknQuery :: Query
+ntfTknQuery =
+  [sql|
+    SELECT token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at
+    FROM tokens
+  |]
+
+rowToNtfTkn :: NtfTknRow -> NtfTknRec
+rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)  =
+  let token = DeviceToken pp ppToken
+      tknRegCode = NtfRegCode regCode
+   in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+deleteNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType [(SMPServer, [NotifierId])])
+deleteNtfToken st tknId =
+  withFastDB "deleteNtfToken" st $ \db -> runExceptT $ do
+    -- This SELECT obtains exclusive lock on token row and prevents any inserts
+    -- into other tables for this token ID until the deletion completes.
+    _ <- ExceptT $ firstRow (fromOnly @Int) AUTH $
+      DB.query db "SELECT 1 FROM tokens WHERE token_id = ? FOR UPDATE" (Only tknId)
+    subs <-
+      liftIO $ map toServerSubs <$>
+        DB.query
+          db
+          [sql|
+            SELECT p.smp_host, p.smp_port, p.smp_keyhash,
+              string_agg(s.smp_notifier_id :: TEXT, ',') AS notifier_ids
+            FROM smp_servers p
+            JOIN subscriptions s ON s.smp_server_id = p.smp_server_id
+            WHERE s.token_id = ?
+            GROUP BY p.smp_host, p.smp_port, p.smp_keyhash;
+          |]
+          (Only tknId)
+    liftIO $ void $ DB.execute db "DELETE FROM tokens WHERE token_id = ?" (Only tknId)
+    withLog "deleteNtfToken" st (`logDeleteToken` tknId)
+    pure subs
+  where
+    toServerSubs :: SMPServerRow :. Only Text -> (SMPServer, [NotifierId])
+    toServerSubs (srv :. Only nIdsStr) = (rowToSrv srv, parseByteaString nIdsStr)
+    parseByteaString :: Text -> [NotifierId]
+    parseByteaString s = mapMaybe (fmap EntityId . decodeHex . T.drop 2) $ T.splitOn "," s  -- drop 2 to remove "\\x"
+
+type SMPServerRow = (NonEmpty TransportHost, ServiceName, C.KeyHash)
+
+type SMPQueueNtfRow = (NonEmpty TransportHost, ServiceName, C.KeyHash, NotifierId)
+
+rowToSrv :: SMPServerRow -> SMPServer
+rowToSrv (host, port, kh) = SMPServer host port kh
+
+srvToRow :: SMPServer -> SMPServerRow
+srvToRow (SMPServer host port kh) = (host, port, kh)
+
+smpQueueToRow :: SMPQueueNtf -> SMPQueueNtfRow
+smpQueueToRow (SMPQueueNtf (SMPServer host port kh) nId) = (host, port, kh, nId)
+
+rowToSMPQueue :: SMPQueueNtfRow -> SMPQueueNtf
+rowToSMPQueue (host, port, kh, nId) = SMPQueueNtf (SMPServer host port kh) nId
+
+updateTknCronInterval :: NtfPostgresStore -> NtfTokenId -> Word16 -> IO (Either ErrorType ())
+updateTknCronInterval st tknId cronInt =
+  withFastDB "updateTknCronInterval" st $ \db -> runExceptT $ do
+    ExceptT $ assertUpdated <$>
+      DB.execute db "UPDATE tokens SET cron_interval = ? WHERE token_id = ?" (cronInt, tknId)
+    withLog "updateTknCronInterval" st $ \sl -> logTokenCron sl tknId 0
+
+-- 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 =
+  withTransaction (dbStore st) $ \db ->
+    map rowToSrvSubs <$>
+      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
+          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
+        |]
+        (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 =
+  withDB' "getServerNtfSubscriptions" st $ \db -> do
+    subs <-
+      map toServerNtfSub <$> case afterSubId_ of
+        Nothing ->
+          DB.query db (query <> orderLimit) (srvId, statusIn, count)
+        Just afterSubId ->
+          DB.query db (query <> " AND subscription_id > ?" <> orderLimit) (srvId, statusIn, afterSubId, count)
+    void $
+      DB.executeMany
+        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
+        |]
+        (map ((NSPending,) . fst) subs)
+    pure subs
+  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 ?
+      |]
+    orderLimit = " ORDER BY subscription_id LIMIT ?"
+    statusIn = In [NSNew, NSPending, NSActive, NSInactive]
+    toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey))
+
+-- Returns token and subscription.
+-- If subscription exists but belongs to another token, returns Left AUTH
+findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec))
+findNtfSubscription st tknId q =
+  withFastDB "findNtfSubscription" st $ \db -> runExceptT $ do
+    tkn@NtfTknRec {ntfTknId, tknStatus} <- ExceptT $ getNtfToken st tknId
+    unless (allowNtfSubCommands tknStatus) $ throwE AUTH
+    liftIO $ updateTokenDate st db tkn
+    sub_ <-
+      liftIO $ maybeFirstRow (rowToNtfSub q) $
+        DB.query
+          db
+          [sql|
+            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc
+            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.smp_notifier_id = ?
+          |]
+          (smpQueueToRow q)
+    forM_ sub_ $ \NtfSubRec {tokenId} -> unless (ntfTknId == tokenId) $ throwE AUTH
+    pure (tkn, sub_)
+
+getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec))
+getNtfSubscription st subId =
+  withFastDB "getNtfSubscription" st $ \db -> runExceptT $ do
+    r@(tkn@NtfTknRec {tknStatus}, _) <-
+      ExceptT $ firstRow rowToNtfTknSub AUTH $
+        DB.query
+          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,
+              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)
+
+rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec)
+rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow)  =
+  let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow
+      smpQueue = rowToSMPQueue qRow
+   in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc})
+
+rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec
+rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc)) =
+  NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
+
+mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec
+mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) =
+  NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey, ntfServiceAssoc = False}
+
+updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ())
+updateTknStatus st tkn status =
+  withFastDB' "updateTknStatus" st $ \db -> updateTknStatus_ st db tkn status
+
+updateTknStatus_ :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> NtfTknStatus -> IO ()
+updateTknStatus_ st db NtfTknRec {ntfTknId} status = do
+  updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ?" (status, ntfTknId, status)
+  when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId status
+
+-- unless it was already active
+setTknStatusConfirmed :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
+setTknStatusConfirmed st NtfTknRec {ntfTknId} =
+  withFastDB' "updateTknStatus" st $ \db -> do
+    updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ? AND status != ?" (NTConfirmed, ntfTknId, NTConfirmed, NTActive)
+    when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed
+
+setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
+setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} =
+  withFastDB' "setTokenActive" st $ \db -> do
+    updateTknStatus_ st db tkn NTActive
+    -- this removes other instances of the same token, e.g. because of repeated token registration attempts
+    tknIds <-
+      liftIO $ map fromOnly <$>
+        DB.query
+          db
+          [sql|
+            DELETE FROM tokens
+            WHERE push_provider = ? AND push_provider_token = ? AND token_id != ?
+            RETURNING token_id
+          |]
+          (pp, Binary ppToken, ntfTknId)
+    withLog "deleteNtfToken" st $ \sl -> mapM_ (logDeleteToken sl) tknIds
+
+withPeriodicNtfTokens :: NtfPostgresStore -> Int64 -> (NtfTknRec -> IO ()) -> IO Int
+withPeriodicNtfTokens st now notify =
+  fmap (fromRight 0) $ withDB' "withPeriodicNtfTokens" st $ \db ->
+    DB.fold db (ntfTknQuery <> " WHERE status = ? AND cron_interval != 0 AND (cron_sent_at + cron_interval * 60) < ?") (NTActive, now) 0 $ \ !n row -> do
+      notify (rowToNtfTkn row) $> (n + 1)
+
+updateTokenCronSentAt :: NtfPostgresStore -> NtfTokenId -> Int64 -> IO (Either ErrorType ())
+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 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)
+  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.
+    -- With 2 statements it will succeed on the first `select` in most cases.
+    upsertServer db srv = getServer >>= maybe insertServer (pure . Right)
+      where
+        getServer =
+          maybeFirstRow fromOnly $
+            DB.query
+              db
+              [sql|
+                SELECT smp_server_id
+                FROM smp_servers
+                WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
+              |]
+              (srvToRow srv)
+        insertServer =
+          firstRow fromOnly (STORE "error inserting SMP server when adding subscription") $
+            DB.query
+              db
+              [sql|
+                INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?)
+                ON CONFLICT (smp_host, smp_port, smp_keyhash)
+                DO UPDATE SET smp_host = EXCLUDED.smp_host
+                RETURNING smp_server_id
+              |]
+              (srvToRow srv)
+
+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 (?,?,?,?,?,?,?)
+  |]
+
+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)
+
+deleteNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType ())
+deleteNtfSubscription st subId =
+  withFastDB "deleteNtfSubscription" st $ \db -> runExceptT $ do
+    ExceptT $ assertUpdated <$>
+      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 $
+        DB.query
+          db
+          [sql|
+            UPDATE subscriptions s
+            SET status = ?
+            FROM smp_servers p
+            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
+          |]
+          (Only status :. smpQueueToRow q :. Only status)
+    forM_ sub_ $ \(subId, serviceAssoc) ->
+      withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
+
+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
+          db
+          [sql|
+            SELECT smp_server_id, ntf_service_id
+            FROM smp_servers
+            WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
+            FOR UPDATE
+          |]
+          (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'
+  where
+    getSMPServerId db =
+      firstRow fromOnly AUTH $
+        DB.query
+          db
+          [sql|
+            SELECT smp_server_id
+            FROM smp_servers
+            WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
+          |]
+          (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)
+
+addTokenLastNtf :: NtfPostgresStore -> PNMessageData -> IO (Either ErrorType (NtfTknRec, NonEmpty PNMessageData))
+addTokenLastNtf st newNtf =
+  withFastDB "addTokenLastNtf" st $ \db -> runExceptT $ do
+    (tkn@NtfTknRec {ntfTknId = tId, tknStatus}, sId) <-
+      ExceptT $ firstRow toTokenSubId AUTH $
+        DB.query
+          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
+            FROM tokens t
+            JOIN subscriptions s ON s.token_id = t.token_id
+            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.smp_notifier_id = ?
+            FOR UPDATE OF t, s
+          |]
+          (smpQueueToRow q)
+    unless (tknStatus == NTActive) $ throwE AUTH
+    lastNtfs_ <-
+      liftIO $ map toLastNtf <$>
+        DB.query
+          db
+            [sql|
+              WITH new AS (
+                INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data)
+                VALUES (?,?,?,?,?)
+                ON CONFLICT (token_id, subscription_id)
+                DO UPDATE SET
+                  sent_at = EXCLUDED.sent_at,
+                  nmsg_nonce = EXCLUDED.nmsg_nonce,
+                  nmsg_data = EXCLUDED.nmsg_data
+                RETURNING subscription_id, sent_at, nmsg_nonce, nmsg_data
+              ),
+              last AS (
+                SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data
+                FROM last_notifications
+                WHERE token_id = ? AND subscription_id != (SELECT subscription_id FROM new)
+                UNION
+                SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data
+                FROM new
+                ORDER BY sent_at DESC
+                LIMIT ?
+              ),
+              delete AS (
+                DELETE FROM last_notifications
+                WHERE token_id = ?
+                  AND sent_at < (SELECT min(sent_at) FROM last)
+              )
+              SELECT p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id,
+                l.sent_at, l.nmsg_nonce, l.nmsg_data
+              FROM last l
+              JOIN subscriptions s ON s.subscription_id = l.subscription_id
+              JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
+              ORDER BY sent_at ASC
+            |]
+            (tId, sId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId)
+    let lastNtfs = fromMaybe (newNtf :| []) (L.nonEmpty lastNtfs_)
+    pure (tkn, lastNtfs)
+  where
+    maxNtfs = 6 :: Int
+    PNMessageData {smpQueue = q, ntfTs, nmsgNonce, encNMsgMeta} = newNtf
+    toTokenSubId :: NtfTknRow :. Only NtfSubscriptionId -> (NtfTknRec, NtfSubscriptionId)
+    toTokenSubId (tknRow :. Only sId) = (rowToNtfTkn tknRow, sId)
+
+toLastNtf :: SMPQueueNtfRow :. (UTCTime, C.CbNonce, Binary EncNMsgMeta) -> PNMessageData
+toLastNtf (qRow :. (ts, nonce, Binary encMeta)) =
+  let ntfTs = MkSystemTime (systemSeconds $ utcToSystemTime ts) 0
+   in PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs, nmsgNonce = nonce, encNMsgMeta = encMeta}
+
+getEntityCounts :: NtfPostgresStore -> IO (Int64, Int64, Int64)
+getEntityCounts st =
+  fmap (fromRight (0, 0, 0)) $ withDB' "getEntityCounts" st $ \db -> do
+    tCnt <- count <$> DB.query_ db "SELECT count(1) FROM tokens"
+    sCnt <- count <$> DB.query_ db "SELECT reltuples::BIGINT FROM pg_class WHERE relname = 'subscriptions' AND relkind = 'r'"
+    nCnt <- count <$> DB.query_ db "SELECT count(1) FROM last_notifications"
+    pure (tCnt, sCnt, nCnt)
+  where
+    count (Only n : _) = n
+    count [] = 0
+
+importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, 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)
+  where
+    importTokens = do
+      allTokens <- M.elems <$> readTVarIO (tokens stmStore)
+      tokens <- filterTokens allTokens
+      let skipped = length allTokens - length tokens
+      when (skipped /= 0) $ putStrLn $ "Total skipped tokens " <> show skipped
+      -- uncomment this line instead of the next two to import tokens one by one.
+      -- tCnt <- withConnection s $ \db -> foldM (importTkn db) 0 tokens
+      -- token interval is reset to 0 to only send notifications to devices with periodic mode,
+      -- and before clients are upgraded - to all active devices.
+      tRows <- mapM (fmap (ntfTknToRow . (\t -> t {tknCronInterval = 0} :: NtfTknRec)) . mkTknRec) tokens
+      tCnt <- withConnection s $ \db -> DB.executeMany db insertNtfTknQuery tRows
+      let tokenIds = S.fromList $ map (\NtfTknData {ntfTknId} -> ntfTknId) tokens
+      (tokenIds,) <$> checkCount "token" (length tokens) tCnt
+      where
+        filterTokens tokens = do
+          let deviceTokens = foldl' (\m t -> M.alter (Just . (t :) . fromMaybe []) (tokenKey t) m) M.empty tokens
+          tokenSubs <- readTVarIO (tokenSubscriptions stmStore)
+          filterM (keepTokenRegistration deviceTokens tokenSubs) tokens
+        tokenKey NtfTknData {token, tknVerifyKey} = strEncode token <> ":" <> C.toPubKey C.pubKeyBytes tknVerifyKey
+        keepTokenRegistration deviceTokens tokenSubs tkn@NtfTknData {ntfTknId, tknStatus} =
+          case M.lookup (tokenKey tkn) deviceTokens of
+            Just ts
+              | length ts < 2 -> pure True
+              | ntfTknId `S.member` skipTokens -> False <$ putStrLn ("Skipped token " <> enc ntfTknId <> " from --skip-tokens")
+              | otherwise ->
+                  readTVarIO tknStatus >>= \case
+                    NTConfirmed -> do
+                      hasSubs <- maybe (pure False) (\v -> not . S.null <$> readTVarIO v) $ M.lookup ntfTknId tokenSubs
+                      if hasSubs
+                        then pure True
+                        else do
+                          anyBetterToken <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> activeOrInvalid <$> readTVarIO tknStatus') ts
+                          if anyBetterToken
+                            then False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId)
+                            else case findIndex (\NtfTknData {ntfTknId = tId} -> tId == ntfTknId) ts of
+                              Just 0 -> pure True -- keeping the first token
+                              Just _ -> False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId <> " (no active token)")
+                              Nothing -> True <$ putStrLn "Error: no device token in the list"
+                    _ -> pure True
+            Nothing -> True <$ putStrLn "Error: no device token in lookup map"
+        activeOrInvalid = \case
+          NTActive -> True
+          NTInvalid _ -> True
+          _ -> False
+        -- importTkn db !n tkn@NtfTknData {ntfTknId} = do
+        --   tknRow <- ntfTknToRow <$> mkTknRec tkn
+        --   (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) ->
+        --     putStrLn ("Error inserting token " <> enc ntfTknId <> " " <> show e) $> n
+    importSubscriptions :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64
+    importSubscriptions tIds subLookup = do
+      subs <- filterSubs . M.elems =<< readTVarIO (subscriptions stmStore)
+      srvIds <- importServers subs
+      putStrLn $ "Importing " <> show (length subs) <> " subscriptions..."
+      -- uncomment this line instead of the next to import subs one by one.
+      -- (sCnt, errTkns) <- withConnection s $ \db -> foldM (importSub db srvIds) (0, M.empty) subs
+      sCnt <- foldM (importSubs srvIds) 0 $ toChunks 500000 subs
+      checkCount "subscription" (length subs) sCnt
+      where
+        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"
+          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
+          where
+            addSubToken acc@(!stIds, !sIds, !qs) NtfSubData {ntfSubId, smpQueue, tokenId} =
+              case M.lookup smpQueue subLookup of
+                Just sId | sId /= ntfSubId ->
+                  (S.insert tokenId stIds, S.insert ntfSubId sIds, S.insert smpQueue qs)
+                _ -> acc
+        importSubs srvIds !n subs = do
+          rows <- mapM (ntfSubRow srvIds) subs
+          cnt <- withConnection s $ \db -> DB.executeMany db insertNtfSubQuery $ L.toList rows
+          let n' = n + cnt
+          putStr $ "Imported " <> show n' <> " subscriptions" <> "\r"
+          hFlush stdout
+          pure n'
+        -- importSub db srvIds (!n, !errTkns) sub@NtfSubData {ntfSubId = sId, tokenId} = do
+        --   subRow <- ntfSubRow srvIds sub
+        --   E.try (DB.execute db insertNtfSubQuery subRow) >>= \case
+        --     Right i -> do
+        --       let n' = n + i
+        --       when (n' `mod` 100000 == 0) $ do
+        --         putStr $ "Imported " <> show n' <> " subscriptions" <> "\r"
+        --         hFlush stdout
+        --       pure (n', errTkns)
+        --     Left (e :: E.SomeException) -> do
+        --       when (n `mod` 100000 == 0) $ putStrLn ""
+        --       putStrLn $ "Error inserting subscription " <> enc sId <> " for token " <> enc tokenId <> " " <> show e
+        --       pure (n, M.alter (Just . maybe [sId] (sId :)) tokenId errTkns)
+        ntfSubRow srvIds sub = case M.lookup srv srvIds of
+          Just sId -> ntfSubToRow sId <$> mkSubRec sub
+          Nothing -> E.throwIO $ userError $ "no matching server ID for server " <> show srv
+          where
+            srv = ntfSubServer sub
+    importServers subs = do
+      sIds <- withConnection s $ \db -> map fromOnly <$> DB.returning db srvQuery (map srvToRow srvs)
+      void $ checkCount "server" (length srvs) (length sIds)
+      pure $ M.fromList $ zip srvs sIds
+      where
+        srvQuery = "INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?) RETURNING smp_server_id"
+        srvs = nubOrd $ map ntfSubServer subs
+    importLastNtfs :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64
+    importLastNtfs tIds subLookup = do
+      ntfs <- readTVarIO (tokenLastNtfs stmStore)
+      ntfRows <- filterLastNtfRows ntfs
+      nCnt <- withConnection s $ \db -> DB.executeMany db lastNtfQuery ntfRows
+      checkCount "last notification" (length ntfRows) nCnt
+      where
+        lastNtfQuery = "INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data) VALUES (?,?,?,?,?)"
+        filterLastNtfRows ntfs = do
+          (skippedTkns, ntfCnt, (skippedQueues, ntfRows)) <- foldM lastNtfRows (S.empty, 0, (S.empty, [])) $ M.assocs ntfs
+          let skipped = ntfCnt - length ntfRows
+          when (skipped /= 0) $ putStrLn $ "Skipped last notifications " <> show skipped <> " for " <> show (S.size skippedTkns) <> " missing tokens and " <> show (S.size skippedQueues) <> " missing subscriptions with token present"
+          pure ntfRows
+        lastNtfRows (!stIds, !cnt, !acc) (tId, ntfVar) = do
+          ntfs <- L.toList <$> readTVarIO ntfVar
+          let cnt' = cnt + length ntfs
+          pure $
+            if S.member tId tIds
+              then (stIds, cnt', foldl' ntfRow acc ntfs)
+              else (S.insert tId stIds, cnt', acc)
+          where
+            ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of
+              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."
+          pure inserted
+      | otherwise = do
+          putStrLn $ "Incorrect " <> name <> " count: expected " <> show expected <> ", imported " <> show inserted
+          putStrLn "Import aborted, fix data and repeat"
+          exitFailure
+    enc = B.unpack . B64.encode . unEntityId
+
+exportNtfDbStore :: NtfPostgresStore -> FilePath -> IO (Int, Int, Int)
+exportNtfDbStore NtfPostgresStore {dbStoreLog = Nothing} _ =
+  putStrLn "Internal error: export requires store log" >> exitFailure
+exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFile =
+  (,,) <$> exportTokens <*> exportSubscriptions <*> exportLastNtfs
+  where
+    exportTokens = do
+      tCnt <- withConnection s $ \db -> DB.fold_ db ntfTknQuery 0 $ \ !i tkn ->
+        logCreateToken sl (rowToNtfTkn tkn) $> (i + 1)
+      putStrLn $ "Exported " <> show tCnt <> " tokens"
+      pure tCnt
+    exportSubscriptions = do
+      sCnt <- withConnection s $ \db -> DB.fold_ db ntfSubQuery 0 $ \ !i sub -> do
+        let i' = i + 1
+        logCreateSubscription sl (toNtfSub sub)
+        when (i' `mod` 500000 == 0) $ do
+          putStr $ "Exported " <> show i' <> " subscriptions" <> "\r"
+          hFlush stdout
+        pure i'
+      putStrLn $ "Exported " <> show sCnt <> " subscriptions"
+      pure sCnt
+      where
+        ntfSubQuery =
+          [sql|
+            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc,
+              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)  =
+          let smpQueue = rowToSMPQueue qRow
+           in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
+    exportLastNtfs =
+      withFile lastNtfsFile WriteMode $ \h ->
+        withConnection s $ \db -> DB.fold_ db lastNtfsQuery 0 $ \ !i (Only tknId :. ntfRow) ->
+          B.hPutStr h (encodeLastNtf tknId $ toLastNtf ntfRow) $> (i + 1)
+      where
+        -- Note that the order here is ascending, to be compatible with how it is imported
+        lastNtfsQuery =
+          [sql|
+            SELECT s.token_id, p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id,
+              n.sent_at, n.nmsg_nonce, n.nmsg_data
+            FROM last_notifications n
+            JOIN subscriptions s ON s.subscription_id = n.subscription_id
+            JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
+            ORDER BY token_ntf_id ASC
+          |]
+        encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n'
+
+withFastDB' :: Text -> 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' 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 op st = withDB_ op st True
+{-# INLINE withFastDB #-}
+
+withDB :: forall a. Text -> 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_ 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)
+      where
+        err = op <> ", withDB, " <> tshow e
+
+withLog :: MonadIO m => Text -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog op NtfPostgresStore {dbStoreLog} = withLog_ op dbStoreLog
+{-# INLINE withLog #-}
+
+assertUpdated :: Int64 -> Either ErrorType ()
+assertUpdated 0 = Left AUTH
+assertUpdated _ = Right ()
+
+instance FromField NtfSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
+
+instance ToField NtfSubStatus where toField = toField . decodeLatin1 . smpEncode
+
+#if !defined(dbPostgres)
+instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
+
+instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
+
+instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
+
+instance FromField (C.PrivateKey 'C.X25519) where fromField = blobFieldDecoder C.decodePrivKey
+
+instance ToField (C.PrivateKey 'C.X25519) where toField = toField . Binary . C.encodePrivKey
+
+instance FromField C.APrivateAuthKey where fromField = blobFieldDecoder C.decodePrivKey
+
+instance ToField C.APrivateAuthKey where toField = toField . Binary . C.encodePrivKey
+
+instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
+
+instance FromField C.KeyHash where fromField = blobFieldDecoder $ parseAll strP
+
+instance ToField C.KeyHash where toField = toField . Binary . strEncode
+
+instance FromField C.CbNonce where fromField = blobFieldDecoder $ parseAll smpP
+
+instance ToField C.CbNonce where toField = toField . Binary . smpEncode
+#endif

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

@@ -0,0 +1,119 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+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.Server.QueueStore (RoundedSystemTime)
+
+data NtfTknRec = NtfTknRec
+  { ntfTknId :: NtfTokenId,
+    token :: DeviceToken,
+    tknStatus :: NtfTknStatus,
+    tknVerifyKey :: NtfPublicAuthKey,
+    tknDhPrivKey :: C.PrivateKeyX25519,
+    tknDhSecret :: C.DhSecretX25519,
+    tknRegCode :: NtfRegCode,
+    tknCronInterval :: Word16,
+    tknUpdatedAt :: Maybe RoundedSystemTime
+  }
+  deriving (Show)
+
+mkTknData :: NtfTknRec -> IO NtfTknData
+mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- newTVarIO status
+  tknCronInterval <- newTVarIO cronInt
+  tknUpdatedAt <- newTVarIO updatedAt
+  let tknDhKeys = (C.publicKey pk, pk)
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+mkTknRec :: NtfTknData -> IO NtfTknRec
+mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys = (_, tknDhPrivKey), tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- readTVarIO status
+  tknCronInterval <- readTVarIO cronInt
+  tknUpdatedAt <- readTVarIO updatedAt
+  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+instance StrEncoding NtfTknRec where
+  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
+    B.unwords
+      [ "tknId=" <> strEncode ntfTknId,
+        "token=" <> strEncode token,
+        "tokenStatus=" <> strEncode tknStatus,
+        "verifyKey=" <> strEncode tknVerifyKey,
+        "dhKeys=" <> strEncode (C.publicKey pk, pk),
+        "dhSecret=" <> strEncode tknDhSecret,
+        "regCode=" <> strEncode tknRegCode,
+        "cron=" <> strEncode tknCronInterval
+      ]
+      <> maybe "" updatedAtStr tknUpdatedAt
+    where
+      updatedAtStr t = " updatedAt=" <> strEncode t
+  strP = do
+    ntfTknId <- "tknId=" *> strP_
+    token <- "token=" *> strP_
+    tknStatus <- "tokenStatus=" *> strP_
+    tknVerifyKey <- "verifyKey=" *> strP_
+    (_ :: C.PublicKeyX25519, tknDhPrivKey) <- "dhKeys=" *> strP_
+    tknDhSecret <- "dhSecret=" *> strP_
+    tknRegCode <- "regCode=" *> strP_
+    tknCronInterval <- "cron=" *> strP
+    tknUpdatedAt <- optional $ " updatedAt=" *> strP
+    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+data NtfSubRec = NtfSubRec
+  { ntfSubId :: NtfSubscriptionId,
+    smpQueue :: SMPQueueNtf,
+    notifierKey :: NtfPrivateAuthKey,
+    tokenId :: NtfTokenId,
+    subStatus :: NtfSubStatus,
+    ntfServiceAssoc :: NtfAssociatedService -- Bool
+  }
+  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
+  subStatus <- newTVarIO status
+  ntfServiceAssoc <- newTVarIO serviceAssoc
+  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
+
+mkSubRec :: NtfSubData -> IO NtfSubRec
+mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
+  subStatus <- readTVarIO status
+  ntfServiceAssoc <- readTVarIO serviceAssoc
+  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
+
+instance StrEncoding NtfSubRec where
+  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc} =
+    B.unwords
+      [ "subId=" <> strEncode ntfSubId,
+        "smpQueue=" <> strEncode smpQueue,
+        "notifierKey=" <> strEncode notifierKey,
+        "tknId=" <> strEncode tokenId,
+        "subStatus=" <> strEncode subStatus,
+        "serviceAssoc=" <> strEncode ntfServiceAssoc
+      ]
+  strP = do
+    ntfSubId <- "subId=" *> strP_
+    smpQueue <- "smpQueue=" *> strP_
+    notifierKey <- "notifierKey=" *> strP_
+    tokenId <- "tknId=" *> strP_
+    subStatus <- "subStatus=" *> strP
+    ntfServiceAssoc <- fromMaybe False <$> optional (" serviceAssoc=" *> strP)
+    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}

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

@@ -0,0 +1,180 @@
+
+
+SET statement_timeout = 0;
+SET lock_timeout = 0;
+SET idle_in_transaction_session_timeout = 0;
+SET client_encoding = 'UTF8';
+SET standard_conforming_strings = on;
+SELECT pg_catalog.set_config('search_path', '', false);
+SET check_function_bodies = false;
+SET xmloption = content;
+SET client_min_messages = warning;
+SET row_security = off;
+
+
+CREATE SCHEMA ntf_server;
+
+
+SET default_table_access_method = heap;
+
+
+CREATE TABLE ntf_server.last_notifications (
+    token_ntf_id bigint NOT NULL,
+    token_id bytea NOT NULL,
+    subscription_id bytea NOT NULL,
+    sent_at timestamp with time zone NOT NULL,
+    nmsg_nonce bytea NOT NULL,
+    nmsg_data bytea NOT NULL
+);
+
+
+
+ALTER TABLE ntf_server.last_notifications ALTER COLUMN token_ntf_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME ntf_server.last_notifications_token_ntf_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
+CREATE TABLE ntf_server.migrations (
+    name text NOT NULL,
+    ts timestamp without time zone NOT NULL,
+    down text
+);
+
+
+
+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
+);
+
+
+
+ALTER TABLE ntf_server.smp_servers ALTER COLUMN smp_server_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME ntf_server.smp_servers_smp_server_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
+CREATE TABLE ntf_server.subscriptions (
+    subscription_id bytea NOT NULL,
+    token_id bytea NOT NULL,
+    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
+);
+
+
+
+CREATE TABLE ntf_server.tokens (
+    token_id bytea NOT NULL,
+    push_provider text NOT NULL,
+    push_provider_token bytea NOT NULL,
+    status text NOT NULL,
+    verify_key bytea NOT NULL,
+    dh_priv_key bytea NOT NULL,
+    dh_secret bytea NOT NULL,
+    reg_code bytea NOT NULL,
+    cron_interval bigint NOT NULL,
+    cron_sent_at bigint,
+    updated_at bigint
+);
+
+
+
+ALTER TABLE ONLY ntf_server.last_notifications
+    ADD CONSTRAINT last_notifications_pkey PRIMARY KEY (token_ntf_id);
+
+
+
+ALTER TABLE ONLY ntf_server.migrations
+    ADD CONSTRAINT migrations_pkey PRIMARY KEY (name);
+
+
+
+ALTER TABLE ONLY ntf_server.smp_servers
+    ADD CONSTRAINT smp_servers_pkey PRIMARY KEY (smp_server_id);
+
+
+
+ALTER TABLE ONLY ntf_server.subscriptions
+    ADD CONSTRAINT subscriptions_pkey PRIMARY KEY (subscription_id);
+
+
+
+ALTER TABLE ONLY ntf_server.tokens
+    ADD CONSTRAINT tokens_pkey PRIMARY KEY (token_id);
+
+
+
+CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id);
+
+
+
+CREATE INDEX idx_last_notifications_token_id_sent_at ON ntf_server.last_notifications USING btree (token_id, sent_at);
+
+
+
+CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON ntf_server.last_notifications USING btree (token_id, subscription_id);
+
+
+
+CREATE UNIQUE INDEX idx_smp_servers ON ntf_server.smp_servers USING btree (smp_host, smp_port, smp_keyhash);
+
+
+
+CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON ntf_server.subscriptions USING btree (smp_server_id, smp_notifier_id);
+
+
+
+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_token_id ON ntf_server.subscriptions USING btree (token_id);
+
+
+
+CREATE UNIQUE INDEX idx_tokens_push_provider_token ON ntf_server.tokens USING btree (push_provider, push_provider_token, verify_key);
+
+
+
+CREATE INDEX idx_tokens_status_cron_interval_sent_at ON ntf_server.tokens USING btree (status, cron_interval, ((cron_sent_at + (cron_interval * 60))));
+
+
+
+ALTER TABLE ONLY ntf_server.last_notifications
+    ADD CONSTRAINT last_notifications_subscription_id_fkey FOREIGN KEY (subscription_id) REFERENCES ntf_server.subscriptions(subscription_id) ON UPDATE RESTRICT ON DELETE CASCADE;
+
+
+
+ALTER TABLE ONLY ntf_server.last_notifications
+    ADD CONSTRAINT last_notifications_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE;
+
+
+
+ALTER TABLE ONLY ntf_server.subscriptions
+    ADD CONSTRAINT subscriptions_smp_server_id_fkey FOREIGN KEY (smp_server_id) REFERENCES ntf_server.smp_servers(smp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT;
+
+
+
+ALTER TABLE ONLY ntf_server.subscriptions
+    ADD CONSTRAINT subscriptions_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE;
+
+
+

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

@@ -10,7 +10,7 @@
 module Simplex.Messaging.Notifications.Server.StoreLog
   ( StoreLog,
     NtfStoreLogRecord (..),
-    readWriteNtfStore,
+    readWriteNtfSTMStore,
     logCreateToken,
     logTokenStatus,
     logUpdateToken,
@@ -24,23 +24,23 @@ module Simplex.Messaging.Notifications.Server.StoreLog
   )
 where
 
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM
-import Control.Logger.Simple
 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 qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.Text as T
+import Data.Functor (($>))
+import qualified Data.Map.Strict as M
+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
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
+import Simplex.Messaging.Notifications.Server.Store.Types
+import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.IO
 
 data NtfStoreLogRecord
@@ -51,56 +51,11 @@ data NtfStoreLogRecord
   | DeleteToken NtfTokenId
   | UpdateTokenTime NtfTokenId RoundedSystemTime
   | CreateSubscription NtfSubRec
-  | SubscriptionStatus NtfSubscriptionId NtfSubStatus
+  | SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
   | DeleteSubscription NtfSubscriptionId
+  | SetNtfService SMPServer (Maybe ServiceId)
   deriving (Show)
 
-data NtfTknRec = NtfTknRec
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: NtfTknStatus,
-    tknVerifyKey :: C.APublicAuthKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: Word16,
-    tknUpdatedAt :: Maybe RoundedSystemTime
-  }
-  deriving (Show)
-
-mkTknData :: NtfTknRec -> IO NtfTknData
-mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
-  tknStatus <- newTVarIO status
-  tknCronInterval <- newTVarIO cronInt
-  tknUpdatedAt <- newTVarIO updatedAt
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-mkTknRec :: NtfTknData -> IO NtfTknRec
-mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
-  tknStatus <- readTVarIO status
-  tknCronInterval <- readTVarIO cronInt
-  tknUpdatedAt <- readTVarIO updatedAt
-  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-data NtfSubRec = NtfSubRec
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateAuthKey,
-    tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus
-  }
-  deriving (Show)
-
-mkSubData :: NtfSubRec -> IO NtfSubData
-mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- newTVarIO status
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-mkSubRec :: NtfSubData -> STM NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- readTVar status
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
 instance StrEncoding NtfStoreLogRecord where
   strEncode = \case
     CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
@@ -110,8 +65,11 @@ 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 -> strEncode (Str "SSTATUS", subId, subStatus)
+    SubscriptionStatus subId subStatus serviceAssoc -> strEncode (Str "SSTATUS", subId, subStatus) <> serviceStr
+      where
+        serviceStr = if serviceAssoc then " service=" <> strEncode True else ""
     DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
+    SetNtfService srv serviceId -> strEncode (Str "SERVICE", srv) <> " service=" <> maybe "off" strEncode serviceId
   strP =
     A.choice
       [ "TCREATE " *> (CreateToken <$> strP),
@@ -121,60 +79,17 @@ instance StrEncoding NtfStoreLogRecord where
         "TDELETE " *> (DeleteToken <$> strP),
         "TTIME " *> (UpdateTokenTime <$> strP_ <*> strP),
         "SCREATE " *> (CreateSubscription <$> strP),
-        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
-        "SDELETE " *> (DeleteSubscription <$> strP)
+        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP <*> (fromMaybe False <$> optional (" service=" *> strP))),
+        "SDELETE " *> (DeleteSubscription <$> strP),
+        "SERVICE " *> (SetNtfService <$> strP <* " service=" <*> ("off" $> Nothing <|> strP))
       ]
 
-instance StrEncoding NtfTknRec where
-  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
-    B.unwords
-      [ "tknId=" <> strEncode ntfTknId,
-        "token=" <> strEncode token,
-        "tokenStatus=" <> strEncode tknStatus,
-        "verifyKey=" <> strEncode tknVerifyKey,
-        "dhKeys=" <> strEncode tknDhKeys,
-        "dhSecret=" <> strEncode tknDhSecret,
-        "regCode=" <> strEncode tknRegCode,
-        "cron=" <> strEncode tknCronInterval
-      ]
-      <> maybe "" updatedAtStr tknUpdatedAt
-    where
-      updatedAtStr t = " updatedAt=" <> strEncode t
-  strP = do
-    ntfTknId <- "tknId=" *> strP_
-    token <- "token=" *> strP_
-    tknStatus <- "tokenStatus=" *> strP_
-    tknVerifyKey <- "verifyKey=" *> strP_
-    tknDhKeys <- "dhKeys=" *> strP_
-    tknDhSecret <- "dhSecret=" *> strP_
-    tknRegCode <- "regCode=" *> strP_
-    tknCronInterval <- "cron=" *> strP
-    tknUpdatedAt <- optional $ " updatedAt=" *> strP
-    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
-    B.unwords
-      [ "subId=" <> strEncode ntfSubId,
-        "smpQueue=" <> strEncode smpQueue,
-        "notifierKey=" <> strEncode notifierKey,
-        "tknId=" <> strEncode tokenId,
-        "subStatus=" <> strEncode subStatus
-      ]
-  strP = do
-    ntfSubId <- "subId=" *> strP_
-    smpQueue <- "smpQueue=" *> strP_
-    notifierKey <- "notifierKey=" *> strP_
-    tokenId <- "tknId=" *> strP_
-    subStatus <- "subStatus=" *> strP
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
 logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
 logNtfStoreRecord = writeStoreLogRecord
 {-# INLINE logNtfStoreRecord #-}
 
-logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
-logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< mkTknRec tkn
+logCreateToken :: StoreLog 'WriteMode -> NtfTknRec -> IO ()
+logCreateToken s = logNtfStoreRecord s . CreateToken
 
 logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
 logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
@@ -191,58 +106,72 @@ logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
 logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
 logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
 
-logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
-logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
+logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()
+logCreateSubscription s = logNtfStoreRecord s . CreateSubscription
 
-logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
-logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
+logSubscriptionStatus :: StoreLog 'WriteMode -> (NtfSubscriptionId, NtfSubStatus, NtfAssociatedService) -> IO ()
+logSubscriptionStatus s (subId, subStatus, serviceAssoc) = logNtfStoreRecord s $ SubscriptionStatus subId subStatus serviceAssoc
 
 logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
 logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
 
-readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
-readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore
+logSetNtfService :: StoreLog 'WriteMode -> SMPServer -> Maybe ServiceId -> IO ()
+logSetNtfService s srv serviceId = logNtfStoreRecord s $ SetNtfService srv serviceId
 
-readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
+readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
+readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore
+
+readNtfStore :: Bool -> FilePath -> NtfSTMStore -> IO ()
+readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
   where
-    addNtfLogRecord s = case strDecode s of
-      Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
-      Right lr -> case lr of
-        CreateToken r@NtfTknRec {ntfTknId} -> do
-          tkn <- mkTknData r
-          atomically $ addNtfToken st ntfTknId tkn
-        TokenStatus tknId status -> do
-          tkn_ <- getNtfTokenIO st tknId
-          forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
-            atomically $ writeTVar tknStatus status
-            when (status == NTActive) $ void $ atomically $ removeInactiveTokenRegistrations st tkn
-        UpdateToken tknId token' tknRegCode -> do
-          getNtfTokenIO st tknId
-            >>= mapM_
-              ( \tkn@NtfTknData {tknStatus} -> do
-                  atomically $ removeTokenRegistration st tkn
-                  atomically $ writeTVar tknStatus NTRegistered
-                  atomically $ addNtfToken st tknId tkn {token = token', tknRegCode}
-              )
-        TokenCron tknId cronInt ->
-          getNtfTokenIO st tknId
-            >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
-        DeleteToken tknId ->
-          atomically $ void $ deleteNtfToken st tknId
-        UpdateTokenTime tknId t ->
-          getNtfTokenIO st tknId
-            >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
-        CreateSubscription r@NtfSubRec {ntfSubId} -> do
-          sub <- mkSubData r
-          void $ atomically $ addNtfSubscription st ntfSubId sub
-        SubscriptionStatus subId status -> do
-          getNtfSubscriptionIO st subId
-            >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
-        DeleteSubscription subId ->
-          atomically $ deleteNtfSubscription st subId
+    processLine s = either printError procNtfLogRecord (strDecode s)
+      where
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> B.take 100 s
+        procNtfLogRecord = \case
+          CreateToken r@NtfTknRec {ntfTknId} -> do
+            tkn <- mkTknData r
+            atomically $ stmAddNtfToken st ntfTknId tkn
+          TokenStatus tknId status -> do
+            tkn_ <- stmGetNtfTokenIO st tknId
+            forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
+              atomically $ writeTVar tknStatus status
+              when (status == NTActive) $ void $ atomically $ stmRemoveInactiveTokenRegistrations st tkn
+          UpdateToken tknId token' tknRegCode -> do
+            stmGetNtfTokenIO st tknId
+              >>= mapM_
+                ( \tkn@NtfTknData {tknStatus} -> do
+                    atomically $ stmRemoveTokenRegistration st tkn
+                    atomically $ writeTVar tknStatus NTRegistered
+                    atomically $ stmAddNtfToken st tknId tkn {token = token', tknRegCode}
+                )
+          TokenCron tknId cronInt ->
+            stmGetNtfTokenIO st tknId
+              >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
+          DeleteToken tknId ->
+            atomically $ void $ stmDeleteNtfToken st tknId
+          UpdateTokenTime tknId t ->
+            stmGetNtfTokenIO st tknId
+              >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
+          CreateSubscription r@NtfSubRec {tokenId, ntfSubId} -> do
+            sub <- mkSubData r
+            atomically (stmAddNtfSubscription st ntfSubId sub) >>= \case
+              Just () -> pure ()
+              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
+          DeleteSubscription subId ->
+            atomically $ stmDeleteNtfSubscription st subId
+          SetNtfService srv serviceId ->
+            atomically $ stmSetNtfService st srv serviceId
 
-writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
-writeNtfStore s NtfStore {tokens, subscriptions} = do
-  mapM_ (logCreateToken s) =<< readTVarIO tokens
-  mapM_ (logCreateSubscription s) =<< readTVarIO subscriptions
+writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO ()
+writeNtfStore s NtfSTMStore {tokens, subscriptions, ntfServices} = 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
 
-supportedNTFHandshakes :: [ALPN]
-supportedNTFHandshakes = ["ntf/1"]
+alpnSupportedNTFHandshakes :: [ALPN]
+alpnSupportedNTFHandshakes = ["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 -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
+ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> 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 -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
-ntfClientHandshake c keyHash ntfVRange _proxyServer = do
+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
   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 = do
         ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
           serverKey <- getServerVerifyKey c
           pubKey <- C.verifyX509 serverKey signedKey
-          (,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
+          (,CertChainPubKey (getPeerCertChain c) signedKey) <$> C.x509ToPublic' pubKey
         let v = maxVersion vr
         sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
         pure $ ntfThHandleClient th v vr ck_
@@ -145,12 +145,13 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer = do
 
 ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
 ntfThHandleServer th v vr pk =
-  let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
+  let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
    in ntfThHandle_ th v vr (Just thAuth)
 
-ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
+ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient
 ntfThHandleClient th v vr ck_ =
-  let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
+  let thAuth = clientTHParams <$> ck_
+      clientTHParams (k, ck) = THAuthClient {peerServerPubKey = k, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
    in ntfThHandle_ th v vr thAuth
 
 ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> VersionRangeNTF -> Maybe (THandleAuth p) -> THandleNTF c p
@@ -160,7 +161,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 -> THandleNTF c p
+ntfTHandle :: Transport c => c p -> THandleNTF c p
 ntfTHandle c = THandle {connection = c, params}
   where
     v = VersionNTF 0
@@ -173,5 +174,6 @@ ntfTHandle c = THandle {connection = c, params}
           thAuth = Nothing,
           implySessId = False,
           encryptBlock = Nothing,
-          batch = False
+          batch = False,
+          serviceAuth = 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.KeyPair 'C.X25519,
+    ntfDhKeys :: C.KeyPairX25519,
     -- | 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.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
+newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
 newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
   NtfToken
     { deviceToken,

src/Simplex/Messaging/Server/CLI.hs

@@ -7,11 +7,13 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Server.CLI where
 
+import Control.Logger.Simple (LogLevel (..))
 import Control.Monad
 import Data.ASN1.Types (asn1CharacterToString)
 import Data.ByteString.Char8 (ByteString)
@@ -28,11 +30,13 @@ import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
 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 (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
+import Simplex.Messaging.Server.Main.GitCommit
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
-import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
+import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -95,6 +99,12 @@ getCliCommand' cmdP version =
   where
     versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
 
+simplexmqVersionCommit :: String
+simplexmqVersionCommit = simplexMQVersion <> " / " <> take 7 simplexmqCommit
+
+simplexmqCommit :: String
+simplexmqCommit = $(gitCommit)
+
 createServerX509 :: FilePath -> X509Config -> IO ByteString
 createServerX509 = createServerX509_ True
 
@@ -174,6 +184,88 @@ certOptionsP = do
         )
   pure CertOptions {signAlgorithm_, commonName_}
 
+dbOptsP :: DBOpts -> Parser DBOpts
+dbOptsP DBOpts {connstr = defDBConnStr, schema = defDBSchema, poolSize = defDBPoolSize} = do
+  connstr <-
+    strOption
+      ( long "database"
+          <> short 'd'
+          <> metavar "DB_CONN"
+          <> help "Database connection string"
+          <> value defDBConnStr
+          <> showDefault
+      )
+  schema <-
+    strOption
+      ( long "schema"
+          <> metavar "DB_SCHEMA"
+          <> help "Database schema"
+          <> value defDBSchema
+          <> showDefault
+      )
+  poolSize <-
+    option
+      auto
+      ( long "pool-size"
+          <> metavar "POOL_SIZE"
+          <> help "Database pool size"
+          <> value defDBPoolSize
+          <> showDefault
+      )
+  pure DBOpts {connstr, schema, poolSize, createSchema = False}
+
+startOptionsP :: Parser StartOptions
+startOptionsP = do
+  maintenance <-
+    switch
+      ( long "maintenance"
+          <> short 'm'
+          <> help "Do not start the server, only perform start and stop tasks"
+      )
+  compactLog <-
+    switch
+      ( long "compact-log"
+          <> help "Compact store log (always enabled with `memory` storage for queues)"
+      )
+  logLevel <-
+    option
+      parseLogLevel
+      ( long "log-level"
+          <> metavar "LOG_LEVEL"
+          <> help "Logging level"
+          <> value LogInfo
+      )
+  skipWarnings <-
+    switch
+      ( long "skip-warnings"
+          <> help "Start the server with non-critical start warnings"
+      )
+  confirmMigrations <-
+    option
+      parseConfirmMigrations
+      ( long "confirm-migrations"
+          <> metavar "CONFIRM_MIGRATIONS"
+          <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
+          <> value MCConsole
+      )
+  pure StartOptions {maintenance, compactLog, logLevel, skipWarnings, confirmMigrations}
+    where
+      parseConfirmMigrations :: ReadM MigrationConfirmation
+      parseConfirmMigrations = eitherReader $ \case
+        "up" -> Right MCYesUp
+        "down" -> Right MCYesUpDown
+        _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
+
+parseLogLevel :: ReadM LogLevel
+parseLogLevel = eitherReader $ \case
+  "trace" -> Right LogTrace
+  "debug" -> Right LogDebug
+  "info" -> Right LogInfo
+  "note" -> Right LogNote
+  "warn" -> Right LogWarn
+  "error" -> Right LogError
+  _ -> Left "Invalid log level"
+
 genOnline :: FilePath -> CertOptions -> IO ()
 genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do
   (signAlgorithm, commonName) <-
@@ -279,7 +371,7 @@ checkSavedFingerprint cfgPath x509cfg = do
   where
     c = combine cfgPath . ($ x509cfg)
 
-iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
+iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
 iniTransports ini =
   let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
       ws = strictIni "TRANSPORT" "websockets" ini
@@ -289,36 +381,45 @@ iniTransports ini =
         | otherwise = ports ws \\ smpPorts
    in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
   where
-    ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
+    ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
     ts t = map (\port -> (port, t, webPort == Just port))
     webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
     ports = map T.unpack . T.splitOn ","
 
-printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
-printServerConfig transports logFile = do
+iniDBOptions :: Ini -> DBOpts -> DBOpts
+iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
+  DBOpts
+    { connstr = either (const connstr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
+      schema = either (const schema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
+      poolSize = readIniDefault poolSize "STORE_LOG" "db_pool_size" ini,
+      createSchema = False
+    }
+
+printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
+printServerConfig protocol transports logFile = do
   putStrLn $ case logFile of
     Just f -> "Store log: " <> f
     _ -> "Store log disabled."
-  printServerTransports transports
+  printServerTransports protocol transports
 
-printServerTransports :: [(ServiceName, ATransport, AddHTTP)] -> IO ()
-printServerTransports ts = do
+printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
+printServerTransports protocol ts = do
   forM_ ts $ \(p, ATransport t, addHTTP) -> do
     let descr = p <> " (" <> transportName t <> ")..."
-    putStrLn $ "Serving SMP protocol on port " <> descr
+    putStrLn $ "Serving " <> protocol <> " protocol on port " <> descr
     when addHTTP $ putStrLn $ "Serving static site on port " <> descr
   unless (any (\(p, _, _) -> p == "443") ts) $
     putStrLn
       "\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, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
-printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
-  SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
-  SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile
+printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
+printSMPServerConfig transports = \case
+  SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile
   SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
     B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
-    printServerTransports transports
+    printServerTransports "SMP" transports
 
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

src/Simplex/Messaging/Server/Control.hs

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

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

@@ -18,20 +18,78 @@
 #endif
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
-module Simplex.Messaging.Server.Env.STM where
+module Simplex.Messaging.Server.Env.STM
+  ( ServerConfig (..),
+    ServerStoreCfg (..),
+    -- AServerStoreCfg (..),
+    SupportedStore,
+    StorePaths (..),
+    StartOptions (..),
+    Env (..),
+    Server (..),
+    ServerSubscribers (..),
+    SubscribedClients,
+    ProxyAgent (..),
+    Client (..),
+    ClientId,
+    ClientSub (..),
+    Sub (..),
+    ServerSub (..),
+    SubscriptionThread (..),
+    MsgStoreType,
+    MsgStore (..),
+    AStoreType (..),
+    VerifiedTransmission,
+    ResponseAndMessage,
+    newEnv,
+    mkJournalStoreConfig,
+    msgStore,
+    fromMsgStore,
+    newClient,
+    getServerClients,
+    getServerClient,
+    insertServerClient,
+    deleteServerClient,
+    getSubscribedClients,
+    getSubscribedClient,
+    upsertSubscribedClient,
+    lookupSubscribedClient,
+    lookupDeleteSubscribedClient,
+    deleteSubcribedClient,
+    sameClientId,
+    sameClient,
+    newSubscription,
+    newProhibitedSub,
+    defaultMsgQueueQuota,
+    defMsgExpirationDays,
+    defNtfExpirationHours,
+    defaultMessageExpiration,
+    defaultNtfExpiration,
+    defaultInactiveClientExpiration,
+    defaultProxyClientConcurrency,
+    defaultMaxJournalMsgCount,
+    defaultMaxJournalStateLines,
+    defaultIdleQueueInterval,
+    journalMsgStoreDepth,
+    readWriteQueueStore,
+    noPostgresExit,
+  )
+where
 
 import Control.Concurrent (ThreadId)
 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
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IS
 import Data.Kind (Constraint)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
 import Data.Maybe (isJust)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime, nominalDay)
@@ -64,16 +122,17 @@ import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Server.StoreLog.ReadWrite
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
+import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP)
 import Simplex.Messaging.Transport.Server
+import Simplex.Messaging.Util (ifM, whenM, ($>>=))
 import System.Directory (doesFileExist)
 import System.Exit (exitFailure)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
-data ServerConfig = ServerConfig
-  { transports :: [(ServiceName, ATransport, AddHTTP)],
+data ServerConfig s = ServerConfig
+  { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     msgQueueQuota :: Int,
@@ -81,7 +140,7 @@ data ServerConfig = ServerConfig
     maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    serverStoreCfg :: AServerStoreCfg,
+    serverStoreCfg :: ServerStoreCfg s,
     storeNtfsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
@@ -90,6 +149,7 @@ data ServerConfig = 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,
@@ -136,6 +196,7 @@ data ServerConfig = ServerConfig
 data StartOptions = StartOptions
   { maintenance :: Bool,
     compactLog :: Bool,
+    logLevel :: LogLevel,
     skipWarnings :: Bool,
     confirmMigrations :: MigrationConfirmation
   }
@@ -188,13 +249,13 @@ defaultMsgQueueQuota = 128
 defaultStateTailSize :: Int
 defaultStateTailSize = 512
 
-data Env = Env
-  { config :: ServerConfig,
+data Env s = Env
+  { config :: ServerConfig s,
     serverActive :: TVar Bool,
     serverInfo :: ServerInformation,
-    server :: Server,
+    server :: Server s,
     serverIdentity :: KeyHash,
-    msgStore :: AMsgStore,
+    msgStore_ :: MsgStore s,
     ntfStore :: NtfStore,
     random :: TVar ChaChaDRG,
     tlsServerCreds :: T.Credential,
@@ -202,10 +263,19 @@ data Env = Env
     serverStats :: ServerStats,
     sockets :: TVar [(ServiceName, SocketState)],
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe AClient)),
     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
+{-# INLINE fromMsgStore #-}
+
 type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
   SupportedStore 'QSMemory 'MSMemory = ()
   SupportedStore 'QSMemory 'MSJournal = ()
@@ -213,95 +283,191 @@ type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
   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 => ASType (SQSType qs) (SMSType ms)
+data AStoreType =
+  forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
+  ASType (SQSType qs) (SMSType ms)
 
-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 ServerStoreCfg s where
+  SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore
+  SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory)
+  SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres)
 
 data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath}
 
-data AServerStoreCfg = forall qs ms. SupportedStore qs ms => ASSCfg (SQSType qs) (SMSType ms) (ServerStoreCfg qs ms)
+type family MsgStoreType (qs :: QSType) (ms :: MSType) where
+  MsgStoreType 'QSMemory 'MSMemory = STMMsgStore
+  MsgStoreType qs 'MSJournal = JournalMsgStore qs
 
-type family MsgStore (qs :: QSType) (ms :: MSType) where
-  MsgStore 'QSMemory 'MSMemory = STMMsgStore
-  MsgStore qs 'MSJournal = JournalMsgStore qs
+data MsgStore s where
+  StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
+  StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
 
-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
-  { subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
-    subscribers :: TMap RecipientId (TVar AClient),
-    ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
-    notifiers :: TMap NotifierId (TVar AClient),
-    subClients :: TVar (IntMap AClient), -- clients with SMP subscriptions
-    ntfSubClients :: TVar (IntMap AClient), -- clients with Ntf subscriptions
-    pendingSubEvents :: TVar (IntMap (NonEmpty (RecipientId, Subscribed))),
-    pendingNtfSubEvents :: TVar (IntMap (NonEmpty (NotifierId, Subscribed))),
+data Server s = Server
+  { clients :: ServerClients s,
+    subscribers :: ServerSubscribers s,
+    ntfSubscribers :: ServerSubscribers s,
     savingLock :: Lock
   }
 
+-- not exported, to prevent concurrent IntMap lookups inside STM transactions.
+newtype ServerClients s = ServerClients {serverClients :: TVar (IntMap (Client s))}
+
+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
+    pendingEvents :: TVar (IntMap (NonEmpty (EntityId, BrokerMsg)))
+  }
+
+-- not exported, to prevent accidental concurrent Map lookups inside STM transactions.
+-- Map stores TVars with pointers to the clients rather than client ID to allow reading the same TVar
+-- inside transactions to ensure that transaction is re-evaluated in case subscriber changes.
+-- Storing Maybe allows to have continuity of subscription when the same user client disconnects and re-connects -
+-- 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))))
+
+getSubscribedClients :: SubscribedClients s -> IO (Map EntityId (TVar (Maybe (Client s))))
+getSubscribedClients (SubscribedClients cs) = readTVarIO cs
+
+getSubscribedClient :: EntityId -> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
+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) =
+  TM.lookup entId cs >>= \case
+    Nothing -> Nothing <$ TM.insertM entId (newTVar (Just c)) 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 #-}
+
+-- lookup and delete currently subscribed client
+lookupDeleteSubscribedClient :: EntityId -> SubscribedClients s -> STM (Maybe (Client s))
+lookupDeleteSubscribedClient entId (SubscribedClients cs) =
+  TM.lookupDelete entId cs $>>= (`swapTVar` Nothing)
+{-# INLINE lookupDeleteSubscribedClient #-}
+
+deleteSubcribedClient :: EntityId -> Client s -> SubscribedClients s -> 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 -
+  -- it prevents removing the next subscribed client and also avoids STM contention for the Map.
+  TM.lookupIO entId cs >>= mapM_ (\cv -> atomically $ whenM (sameClient c cv) $ delete cv)
+  where
+    delete cv = do
+      writeTVar cv Nothing
+      TM.delete entId cs
+
+sameClientId :: Client s -> (Client s) -> Bool
+sameClientId c c' = clientId c == clientId c'
+{-# INLINE sameClientId #-}
+
+sameClient :: Client s -> TVar (Maybe (Client s)) -> 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
+  { smpAgent :: SMPClientAgent 'Sender
   }
 
 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 (),
-    rcvQ :: TBQueue (NonEmpty (Maybe (StoreQueue s, QueueRec), Transmission Cmd)),
-    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
+    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]),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
     endThreads :: TVar (IntMap (Weak ThreadId)),
     endThreadSeq :: TVar Int,
-    thVersion :: VersionSMP,
-    sessionId :: ByteString,
+    clientTHParams :: THandleParams SMPVersion 'TServer,
     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 :: TMVar MsgId
+    delivered :: TVar (Maybe (MsgId, RoundedSystemTime))
   }
 
-newServer :: IO Server
+newServer :: IO (Server s)
 newServer = do
-  subscribedQ <- newTQueueIO
-  subscribers <- TM.emptyIO
-  ntfSubscribedQ <- newTQueueIO
-  notifiers <- TM.emptyIO
-  subClients <- newTVarIO IM.empty
-  ntfSubClients <- newTVarIO IM.empty
-  pendingSubEvents <- newTVarIO IM.empty
-  pendingNtfSubEvents <- newTVarIO IM.empty
+  clients <- ServerClients <$> newTVarIO mempty
+  subscribers <- newServerSubscribers
+  ntfSubscribers <- newServerSubscribers
   savingLock <- createLockIO
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
+  return Server {clients, subscribers, ntfSubscribers, savingLock}
 
-newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms))
-newClient _ _ clientId qSize thVersion sessionId createdAt = do
+getServerClients :: Server s -> IO (IntMap (Client s))
+getServerClients = readTVarIO . serverClients . clients
+{-# INLINE getServerClients #-}
+
+getServerClient :: ClientId -> Server s -> IO (Maybe (Client s))
+getServerClient cId s = IM.lookup cId <$> getServerClients s
+{-# INLINE getServerClient #-}
+
+insertServerClient :: Client s -> Server s -> IO Bool
+insertServerClient c@Client {clientId, connected} Server {clients} =
+  atomically $
+    ifM
+      (readTVar connected)
+      (True <$ modifyTVar' (serverClients clients) (IM.insert clientId c))
+      (pure False)
+{-# INLINE insertServerClient #-}
+
+deleteServerClient :: ClientId -> Server s -> IO ()
+deleteServerClient cId Server {clients} = atomically $ modifyTVar' (serverClients clients) $ IM.delete cId
+{-# INLINE deleteServerClient #-}
+
+newServerSubscribers :: IO (ServerSubscribers s)
+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}
+
+newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s)
+newClient clientId qSize clientTHParams createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
+  serviceSubscribed <- newTVarIO False
+  ntfServiceSubscribed <- newTVarIO False
+  serviceSubsCount <- newTVarIO 0
+  ntfServiceSubsCount <- newTVarIO 0
   rcvQ <- newTBQueueIO qSize
   sndQ <- newTBQueueIO qSize
   msgQ <- newTBQueueIO qSize
@@ -311,45 +477,65 @@ newClient _ _ clientId qSize thVersion sessionId createdAt = do
   connected <- newTVarIO True
   rcvActiveAt <- newTVarIO createdAt
   sndActiveAt <- newTVarIO createdAt
-  return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
+  return
+    Client
+      { clientId,
+        subscriptions,
+        ntfSubscriptions,
+        serviceSubscribed,
+        ntfServiceSubscribed,
+        serviceSubsCount,
+        ntfServiceSubsCount,
+        rcvQ,
+        sndQ,
+        msgQ,
+        procThreads,
+        endThreads,
+        endThreadSeq,
+        clientTHParams,
+        connected,
+        createdAt,
+        rcvActiveAt,
+        sndActiveAt
+      }
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
-  delivered <- newEmptyTMVar
+  delivered <- newTVar Nothing
   subThread <- ServerSub <$> newTVar st
   return Sub {subThread, delivered}
 
 newProhibitedSub :: STM Sub
 newProhibitedSub = do
-  delivered <- newEmptyTMVar
+  delivered <- newTVar Nothing
   return Sub {subThread = ProhibitSub, delivered}
 
-newEnv :: ServerConfig -> IO Env
+newEnv :: ServerConfig s -> IO (Env s)
 newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
   serverActive <- newTVarIO True
   server <- newServer
-  msgStore <- case serverStoreCfg of
-    ASSCfg qt mt (SSCMemory storePaths_) -> do
+  msgStore_ <- case serverStoreCfg of
+    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 $ AMS qt mt ms
-    ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
+      pure $ StoreMemory ms
+    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 $ AMS qt mt ms
+      pure $ StoreJournal ms
 #if defined(dbServerPostgres)
-    ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
+    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
       ms <- newMsgStore cfg
-      pure $ AMS qt mt ms
+      pure $ StoreJournal ms
 #else
-    ASSCfg _ _ SSCDatabaseJournal {} -> noPostgresExit
+    SSCDatabaseJournal {} -> noPostgresExit
 #endif
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
@@ -361,18 +547,34 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
   serverStats <- newServerStats =<< getCurrentTime
   sockets <- newTVarIO []
   clientSeq <- newTVarIO 0
-  clients <- newTVarIO mempty
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure
+    Env
+      { serverActive,
+        config,
+        serverInfo,
+        server,
+        serverIdentity,
+        msgStore_,
+        ntfStore,
+        random,
+        tlsServerCreds,
+        httpServerCreds,
+        serverStats,
+        sockets,
+        clientSeq,
+        proxyAgent
+      }
   where
     loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
     loadStoreLog mkQ f st = do
-      logInfo $ "restoring queues from file " <> T.pack f
+      logNote $ "restoring queues from file " <> T.pack f
       sl <- readWriteQueueStore False mkQ f st
       setStoreLog st sl
+#if defined(dbServerPostgres)
     compactDbStoreLog = \case
       Just f -> do
-        logInfo $ "compacting queues in file " <> T.pack f
+        logNote $ "compacting queues in file " <> T.pack f
         st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota}
         -- we don't need to have locks in the map
         sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st)
@@ -381,6 +583,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
       Nothing -> do
         logError "Error: `--compact-log` used without `db_store_log` INI option"
         exitFailure
+#endif
     getCredentials protocol creds = do
       files <- missingCreds
       unless (null files) $ do
@@ -417,7 +620,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
         }
       where
         persistence = case serverStoreCfg of
-          ASSCfg _ _ (SSCMemory sp_) -> case sp_ of
+          SSCMemory sp_ -> case sp_ of
             Nothing -> SPMMemoryOnly
             Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
             _ -> SPMQueues
@@ -446,8 +649,8 @@ mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount ma
 
 newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
-  smpAgent <- newSMPClientAgent smpAgentCfg random
+  smpAgent <- newSMPClientAgent SSender smpAgentCfg random
   pure ProxyAgent {smpAgent}
 
-readWriteQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO (StoreLog 'WriteMode)
+readWriteQueueStore :: forall q. StoreQueueClass q => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> 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 (ConnectionMode (..), ConnectionRequestUri)
+import Simplex.Messaging.Agent.Protocol (ConnectionLink, ConnectionMode (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
 
@@ -100,7 +100,7 @@ data Entity = Entity {name :: Text, country :: Maybe Text}
   deriving (Show)
 
 data ServerContactAddress = ServerContactAddress
-  { simplex :: Maybe (ConnectionRequestUri 'CMContact),
+  { simplex :: Maybe (ConnectionLink 'CMContact),
     email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present
     pgp :: Maybe PGPKey
   }

src/Simplex/Messaging/Server/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -29,16 +30,17 @@ 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 (connReqUriP')
+import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
-import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
+import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -54,9 +56,10 @@ import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCf
 import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config
 import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
-import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
-import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, ifM)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
@@ -70,9 +73,10 @@ 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.QueueStore.Postgres (batchInsertQueues, foldQueueRecs)
+import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
+import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
 import Simplex.Messaging.Server.QueueStore.Types
-import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue, openWriteStoreLog)
+import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
 import System.Directory (renameFile)
 #endif
 
@@ -144,7 +148,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               case readStoreType ini of
                 Right (ASType SQSMemory SMSMemory) -> putStrLn "store_messages set to `memory`, start the server."
                 Right (ASType SQSMemory SMSJournal) -> putStrLn "store_messages set to `journal`, update it to `memory` in INI file"
-                Right (ASType SQSPostgres SMSJournal) -> 
+                Right (ASType SQSPostgres SMSJournal) ->
 #if defined(dbServerPostgres)
                   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`)."
 #else
@@ -161,7 +165,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 "Messages NOT deleted"
               deleteDirIfExists storeMsgsJournalDir
               putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
-#if defined(dbServerPostgres)              
+#if defined(dbServerPostgres)
     Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
       schemaExists <- checkSchemaExists connstr schema
       storeLogExists <- doesFileExist storeLogFilePath
@@ -179,8 +183,8 @@ 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"
-              qCnt <- importStoreLogToDatabase logPath storeLogFile dbOpts
-              putStrLn $ "Import completed: " <> show qCnt <> " queues"
+              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
+              putStrLn $ "Import completed: " <> show sCnt <> " services, " <> 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
@@ -201,8 +205,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               confirmOrExit
                 ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
                 "Queue records not exported"
-              qCnt <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
-              putStrLn $ "Export completed: " <> show qCnt <> " queues"
+              (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
+              putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
               putStrLn $ case readStoreType ini of
                 Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
                 Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
@@ -231,7 +235,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
         Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
     iniFile = combine cfgPath "smp-server.ini"
-    serverVersion = "SMP server v" <> simplexMQVersion
+    serverVersion = "SMP server v" <> simplexmqVersionCommit
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
     storeMsgsFilePath = combine logPath "smp-server-messages.log"
@@ -247,13 +251,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       where
         iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
         iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
-    iniDBOptions ini =
-      DBOpts
-        { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
-          schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
-          poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini,
-          createSchema = False
-        }
     iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
     defaultStaticPath = combine logPath "www"
     enableStoreLog' = settingIsOn "STORE_LOG" "enable"
@@ -327,56 +324,61 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               SPRandom -> BasicAuth <$> randomBase64 32
             randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
     runServer startOptions ini = do
+      setLogLevel $ logLevel startOptions
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
-      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"
+      run iniStoreType
       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
@@ -387,7 +389,15 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
         iniStoreType = either error id $! readStoreType ini
-        serverConfig =
+        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}
+        serverConfig :: ServerStoreCfg s -> ServerConfig s
+        serverConfig serverStoreCfg =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
@@ -404,21 +414,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     certificateFile = c serverCrtFile
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
-              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, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
-                   in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir},
+              serverStoreCfg,
               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
@@ -443,12 +446,13 @@ 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 = 3000000, -- 3 seconds
+              ntfDeliveryInterval = 1500000, -- 1.5 second
               smpServerVRange = supportedServerSMPRelayVRange,
               transportConfig =
-                defaultTransportServerConfig
-                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  },
+                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
               controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
@@ -462,7 +466,8 @@ 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
+                                requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini,
+                                smpWebPortServers = SWPOff
                               }
                         },
                     ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
@@ -512,7 +517,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
 #if defined(dbServerPostgres)
               SQSPostgres -> do
-                let DBOpts {connstr, schema} = iniDBOptions ini
+                let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
                 schemaExists <- checkSchemaExists connstr schema
                 case enableDbStoreLog' ini of
                   Just ()
@@ -555,26 +560,30 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       putStrLn "Configure queue storage."
       exitFailure
 
-importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO Int64
+importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
 importStoreLogToDatabase logPath storeLogFile dbOpts = do
   ms <- newJournalMsgStore logPath MQStoreCfg
-  sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile (queueStore ms)
+  let st = stmQueueStore ms
+  sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
   closeStoreLog sl
-  queues <- readTVarIO $ loadedQueues $ stmQueueStore ms
+  queues <- readTVarIO $ loadedQueues st
+  services' <- M.elems <$> readTVarIO (services st)
   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 qCnt
+  pure (sCnt, qCnt)
 
-exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO Int
+exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
 exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
   let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
   ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
   sl <- openWriteStoreLog False storeLogFilePath
+  Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
   Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
   closeStoreLog sl
-  pure qCnt
+  pure (sCnt, qCnt)
 #endif
 
 newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
@@ -630,7 +639,8 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
         <$!> infoValue nameField
     countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
     iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
-      let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+      let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+          linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
           email = infoValue emailField
           pkURI_ = infoValue pgpKeyUriField
           pkFingerprint_ = infoValue pgpKeyFingerprintField
@@ -669,7 +679,7 @@ cliCommandP cfgPath logPath iniFile =
         <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
         <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
-        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (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
@@ -684,7 +694,7 @@ cliCommandP cfgPath logPath iniFile =
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"
             )
-      dbOptions <- dbOptsP
+      dbOptions <- dbOptsP defaultDBOpts
       logStats <-
         switch
           ( long "daily-stats"
@@ -799,7 +809,7 @@ cliCommandP cfgPath logPath iniFile =
             sourceCode = T.pack <$> sourceCode,
             serverInfo =
               ServerPublicInfo
-                { sourceCode = T.pack simplexmqSource,
+                { sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode,
                   usageConditions = Nothing,
                   operator = fst operator_,
                   website,
@@ -815,32 +825,6 @@ cliCommandP cfgPath logPath iniFile =
             disableWeb,
             scripted
           }
-    startOptionsP = do
-      maintenance <-
-        switch
-          ( long "maintenance"
-              <> short 'm'
-              <> help "Do not start the server, only perform start and stop tasks"
-          )
-      compactLog <-
-        switch
-          ( long "compact-log"
-              <> help "Compact store log (always enabled with `memory` storage for queues)"
-          )
-      skipWarnings <-
-        switch
-          ( long "skip-warnings"
-              <> help "Start the server with non-critical start warnings"
-          )
-      confirmMigrations <-
-        option
-          parseConfirmMigrations
-          ( long "confirm-migrations"
-              <> metavar "CONFIRM_MIGRATIONS"
-              <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
-              <> value MCConsole
-          )
-      pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations}
     journalCmdP = storeCmdP "message log file" "journal storage"
     databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
     storeCmdP src dest =
@@ -849,39 +833,6 @@ cliCommandP cfgPath logPath iniFile =
             <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
             <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
         )
-    dbOptsP = do
-      connstr <-
-        strOption
-          ( long "database"
-              <> short 'd'
-              <> metavar "DB_CONN"
-              <> help "Database connection string"
-              <> value defaultDBConnStr
-              <> showDefault
-          )
-      schema <-
-        strOption
-          ( long "schema"
-              <> metavar "DB_SCHEMA"
-              <> help "Database schema"
-              <> value defaultDBSchema
-              <> showDefault
-          )
-      poolSize <-
-        option
-          auto
-          ( long "pool-size"
-              <> metavar "POOL_SIZE"
-              <> help "Database pool size"
-              <> value defaultDBPoolSize
-              <> showDefault
-          )
-      pure DBOpts {connstr, schema, poolSize, createSchema = False}
-    parseConfirmMigrations :: ReadM MigrationConfirmation
-    parseConfirmMigrations = eitherReader $ \case
-      "up" -> Right MCYesUp
-      "down" -> Right MCYesUpDown
-      _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
@@ -901,5 +852,6 @@ cliCommandP cfgPath logPath iniFile =
             <> metavar (metavar' <> "_COUNTRY")
             <> help (help' <> " country")
         )
-    strParse :: StrEncoding a => ReadM a
-    strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack
+
+strParse :: StrEncoding a => ReadM a
+strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack

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

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

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

@@ -4,11 +4,9 @@
 
 module Simplex.Messaging.Server.Main.Init where
 
-import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isNothing)
-import Numeric.Natural (Natural)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
@@ -27,14 +25,14 @@ import System.FilePath ((</>))
 defaultControlPort :: Int
 defaultControlPort = 5224
 
-defaultDBConnStr :: ByteString
-defaultDBConnStr = "postgresql://smp@/smp_server_store"
-
-defaultDBSchema :: ByteString
-defaultDBSchema = "smp_server"
-
-defaultDBPoolSize :: Natural
-defaultDBPoolSize = 10
+defaultDBOpts :: DBOpts
+defaultDBOpts =
+  DBOpts
+    { connstr = "postgresql://smp@/smp_server_store",
+      schema = "smp_server",
+      poolSize = 10,
+      createSchema = False
+    }
 
 -- time to retain deleted queues in the database (days), for debugging
 defaultDeletedTTL :: Int64
@@ -77,13 +75,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
         \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\
         \store_queues: memory\n\n\
         \# Database connection settings for PostgreSQL database (`store_queues: database`).\n"
-    <> (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n")
-    <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n")
-    <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n")
+    <> iniDbOpts dbOptions defaultDBOpts
     <> "# Write database changes to store log file\n\
         \# db_store_log: off\n\n\
         \# Time to retain deleted queues in the database, days.\n"
-    <> ("db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
+    <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
     <> "# Message storage mode: `memory` or `journal`.\n\
         \store_messages: memory\n\n\
         \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
@@ -96,7 +92,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
     <> "# Log daily server statistics to CSV file\n"
     <> ("log_stats: " <> onOff logStats <> "\n\n")
     <> "# Log interval for real-time Prometheus metrics\n\
-        \# prometheus_interval: 300\n\n\
+        \# prometheus_interval: 60\n\n\
         \[AUTH]\n\
         \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
         \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
@@ -111,8 +107,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
         )
     <> "\n\n"
     <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
-    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
-    <> "\n\
+    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n\n")
+    <> "# The limit for queues that can be blocked via control port per day, resets at 0:00 UTC.\n\
+        \# Set to 0 to disable limit, to -1 to prohibit blocking. Default is 20.\n\
+        \# daily_block_queue_quota: 20\n\
+        \\n\
         \[TRANSPORT]\n\
         \# Host is only used to print server address on start.\n\
         \# You can specify multiple server ports.\n"
@@ -164,7 +163,6 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
     <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
   where
     InitOptions {enableStoreLog, dbOptions, socksProxy, ownDomains, controlPort, webStaticPath, disableWeb, logStats} = opts
-    DBOpts {connstr, schema, poolSize} = dbOptions
     defaultServerPorts = "5223,443"
     defaultStaticPath = logPath </> "www"
     httpsCertFile = cfgPath </> "web.crt"
@@ -221,6 +219,12 @@ informationIniContent InitOptions {sourceCode, serverInfo} =
         <> "\n"
         <> countryStr optName (country =<< entity)
 
+iniDbOpts :: DBOpts -> DBOpts -> Text
+iniDbOpts DBOpts {connstr, schema, poolSize} DBOpts {connstr = defConnstr, schema = defSchema, poolSize = defPoolSize} =
+  (optDisabled' (connstr == defConnstr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n")
+    <> (optDisabled' (schema == defSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n")
+    <> (optDisabled' (poolSize == defPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n")
+
 optDisabled :: Maybe a -> Text
 optDisabled = optDisabled' . isNothing
 {-# INLINE optDisabled #-}

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

@@ -61,11 +61,12 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (intercalate, sort)
+import Data.List (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)
@@ -296,7 +297,7 @@ instance StoreQueueClass (JournalQueue s) where
   {-# INLINE queueRec #-}
   msgQueue = msgQueue'
   {-# INLINE msgQueue #-}
-  withQueueLock :: JournalQueue s -> String -> IO a -> IO a
+  withQueueLock :: JournalQueue s -> Text -> IO a -> IO a
   withQueueLock JournalQueue {recipientId', queueLock, sharedLock} =
     withLockWaitShared recipientId' queueLock sharedLock
   {-# INLINE withQueueLock #-}
@@ -317,12 +318,14 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
   {-# INLINE loadedQueues #-}
   compactQueues = withQS (compactQueues @(JournalQueue s))
   {-# INLINE compactQueues #-}
-  queueCounts = withQS (queueCounts @(JournalQueue s))
-  {-# INLINE queueCounts #-}
+  getEntityCounts = withQS (getEntityCounts @(JournalQueue s))
+  {-# INLINE getEntityCounts #-}
   addQueue_ = withQS addQueue_
   {-# INLINE addQueue_ #-}
   getQueue_ = withQS getQueue_
   {-# INLINE getQueue_ #-}
+  getQueues_ = withQS getQueues_
+  {-# INLINE getQueues_ #-}
   addQueueLinkData = withQS addQueueLinkData
   {-# INLINE addQueueLinkData #-}
   getQueueLinkData = withQS getQueueLinkData
@@ -347,6 +350,14 @@ 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 +388,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}
 
@@ -396,7 +407,7 @@ instance MsgStoreClass (JournalMsgStore s) where
   -- It does not cache queues and is NOT concurrency safe.
   unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
   unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of
-    MQStore st -> withLoadedQueues st run 
+    MQStore st -> withLoadedQueues st run
 #if defined(dbServerPostgres)
     PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkQueue ms False) >=> run
 #endif
@@ -638,28 +649,28 @@ instance MsgStoreClass (JournalMsgStore s) where
         $>>= \len -> readTVarIO handles
         $>>= \hs -> updateReadPos q mq logState len hs $> Just ()
 
-  isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a
+  isolateQueue :: JournalQueue s -> Text -> StoreIO s a -> ExceptT ErrorType IO a
   isolateQueue sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO
 
-  unsafeRunStore :: JournalQueue s -> String -> StoreIO s a -> IO a
+  unsafeRunStore :: JournalQueue s -> Text -> 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' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
+tryStore' :: Text -> RecipientId -> IO a -> ExceptT ErrorType IO a
 tryStore' op rId = tryStore op rId . fmap Right
 
-tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+tryStore :: forall a. Text -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
 tryStore op rId a = ExceptT $ E.mask_ $ a `E.catch` storeError op rId
 
-storeError :: String -> RecipientId -> E.SomeException -> IO (Either ErrorType a)
+storeError :: Text -> RecipientId -> E.SomeException -> IO (Either ErrorType a)
 storeError op rId e =
-  let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
-    in logError ("STORE: " <> T.pack e') $> Left (STORE e')
+  let e' = T.intercalate ", " [op, decodeLatin1 $ strEncode rId, tshow e]
+    in logError ("STORE: " <> e') $> Left (STORE e')
 
-isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+isolateQueueId :: Text -> 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
 

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

@@ -8,6 +8,7 @@ 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)
@@ -16,14 +17,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 -> String -> IO a -> IO a
+withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> Text -> 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 -> String -> IO a -> IO a
+withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> Text -> 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/STM.hs

@@ -24,6 +24,7 @@ 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
@@ -178,10 +179,10 @@ instance MsgStoreClass STMMsgStore where
       Just _ -> modifyTVar' size (subtract 1)
       _ -> pure ()
 
-  isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a
+  isolateQueue :: STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
   isolateQueue _ _ = liftIO . atomically
   {-# INLINE isolateQueue #-}
 
-  unsafeRunStore :: STMQueue -> String -> STM a -> IO a
+  unsafeRunStore :: STMQueue -> Text -> STM a -> IO a
   unsafeRunStore _ _ = atomically
   {-# INLINE unsafeRunStore #-}

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -17,11 +18,13 @@
 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
@@ -61,8 +64,8 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M
   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
+  isolateQueue :: StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a
+  unsafeRunStore :: StoreQueue s -> Text -> StoreMonad s a -> IO a
 
 data MSType = MSMemory | MSJournal
 
@@ -105,14 +108,23 @@ addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorT
 addQueue st = addQueue_ (queueStore st) (mkQueue st True)
 {-# INLINE addQueue #-}
 
-getQueue :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
+getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
 getQueue st = getQueue_ (queueStore st) (mkQueue st)
 {-# INLINE getQueue #-}
 
-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))
+getQueueRec :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
+getQueueRec st party qId = getQueue st party qId $>>= readQueueRec
+
+getQueues :: (MsgStoreClass s, BatchParty p) => s -> SParty p -> [QueueId] -> IO [Either ErrorType (StoreQueue s)]
+getQueues st = getQueues_ (queueStore st) (mkQueue st)
+{-# INLINE getQueues #-}
+
+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)
+
+readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec))
+readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)
+{-# INLINE readQueueRec #-}
 
 getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int
 getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
@@ -141,7 +153,7 @@ tryDelPeekMsg st q msgId' =
         | 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 -> String -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
+withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
 withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a
 {-# INLINE withPeekMsgQueue #-}
 

src/Simplex/Messaging/Server/NtfStore.hs

@@ -28,7 +28,7 @@ data MsgNtf = MsgNtf
 storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO ()
 storeNtf (NtfStore ns) nId ntf = do
   TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :))
-  -- TODO coalesce messages here once the client is updated to process multiple messages
+  -- TODO [ntfdb] coalesce messages here once the client is updated to process multiple messages
   -- for single notification.
   -- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats
   where

src/Simplex/Messaging/Server/Prometheus.hs

@@ -6,6 +6,8 @@
 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)
@@ -13,42 +15,54 @@ 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,
-    queueCount :: Int,
-    notifierCount :: Int
+    entityCounts :: EntityCounts,
+    rtsOptions :: Text
   }
 
+rtsOptionsEnv :: Text
+rtsOptionsEnv = "SMP_RTS_OPTIONS"
+
 data RealTimeMetrics = RealTimeMetrics
   { socketStats :: [(ServiceName, SocketStats)],
     threadsCount :: Int,
     clientsCount :: Int,
-    smpSubsCount :: Int,
-    smpSubClientsCount :: Int,
-    ntfSubsCount :: Int,
-    ntfSubClientsCount :: Int,
+    deliveredSubs :: RTSubscriberMetrics,
+    deliveredTimes :: TimeBuckets,
+    smpSubs :: RTSubscriberMetrics,
+    ntfSubs :: RTSubscriberMetrics,
     loadedCounts :: LoadedQueueCounts
   }
 
+data RTSubscriberMetrics = RTSubscriberMetrics
+  { subsCount :: Int,
+    subClientsCount :: Int,
+    subServicesCount :: Int
+  }
+
 {-# FOURMOLU_DISABLE\n#-}
 prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
 prometheusMetrics sm rtm ts =
-  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info
+  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> info
   where
-    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} = sm
+    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions} = sm
     RealTimeMetrics
       { socketStats,
         threadsCount,
         clientsCount,
-        smpSubsCount,
-        smpSubClientsCount,
-        ntfSubsCount,
-        ntfSubClientsCount,
+        deliveredSubs,
+        deliveredTimes,
+        smpSubs,
+        ntfSubs,
         loadedCounts
       } = rtm
     ServerStatsData
@@ -68,6 +82,7 @@ prometheusMetrics sm rtm ts =
         _qSubEnd,
         _qSubEndB,
         _ntfCreated,
+        _ntfNewCreated,
         _ntfDeleted,
         _ntfDeletedB,
         _ntfSub,
@@ -80,6 +95,7 @@ prometheusMetrics sm rtm ts =
         _msgSentLarge,
         _msgSentBlock,
         _msgRecv,
+        _msgRecvAckTimes,
         _msgRecvGet,
         _msgGet,
         _msgGetNoMsg,
@@ -87,10 +103,8 @@ prometheusMetrics sm rtm ts =
         _msgGetDuplicate,
         _msgGetProhibited,
         _msgExpired,
-        _activeQueues,
         _msgSentNtf,
         _msgRecvNtf,
-        _activeQueuesNtf,
         _msgNtfs,
         _msgNtfsB,
         _msgNtfNoSub,
@@ -101,6 +115,8 @@ prometheusMetrics sm rtm ts =
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
+        _rcvServices,
+        _ntfServices,
         _qCount,
         _msgCount,
         _ntfCount
@@ -141,7 +157,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 <> "\n# qCount2\n\
+      \simplex_smp_queues_total2 " <> mshow (queueCount entityCounts) <> "\n# qCount2\n\
       \\n\
       \# HELP simplex_smp_queues_daily Daily active queues.\n\
       \# TYPE simplex_smp_queues_daily gauge\n\
@@ -247,15 +263,19 @@ prometheusMetrics sm rtm ts =
       \simplex_smp_messages_notify_get_errors{type=\"duplicate\"} " <> mshow _msgGetDuplicate <> "\n# msgGetDuplicate\n\
       \simplex_smp_messages_notify_get_errors{type=\"prohibited\"} " <> mshow _msgGetProhibited <> "\n# msgGetProhibited\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_created Created queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_created counter\n\
       \simplex_smp_queues_notify_created " <> mshow _ntfCreated <> "\n# ntfCreated\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_new_created Created new queues with notification credentials.\n\
+      \# TYPE simplex_smp_queues_notify_new_created counter\n\
+      \simplex_smp_queues_notify_new_created " <> mshow _ntfNewCreated <> "\n# ntfNewCreated\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_deleted Deleted queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_deleted counter\n\
       \simplex_smp_queues_notify_deleted " <> mshow _ntfDeleted <> "\n# ntfDeleted\n\
       \\n\
-      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\
+      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queue notification credentials.\n\
       \# TYPE simplex_smp_queues_notify_deleted_batch counter\n\
       \simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\
       \\n\
@@ -265,7 +285,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 <> "\n# ntfCount2\n\
+      \simplex_smp_queues_notify_total2 " <> mshow (notifierCount entityCounts) <> "\n# ntfCount2\n\
       \\n"
     ntfs =
       "# Notifications (server)\n\
@@ -344,9 +364,67 @@ 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\
+      \\n\
+      \# HELP simplex_smp_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
+      \# TYPE simplex_smp_info gauge\n\
+      \simplex_smp_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
       \\n"
       <> socketsMetric socketsAccepted "simplex_smp_sockets_accepted" "Accepted sockets"
       <> socketsMetric socketsClosed "simplex_smp_sockets_closed" "Closed sockets"
@@ -360,21 +438,56 @@ prometheusMetrics sm rtm ts =
       \# TYPE simplex_smp_clients_total gauge\n\
       \simplex_smp_clients_total " <> mshow clientsCount <> "\n\
       \\n\
-      \# HELP simplex_smp_subscribtion_total Total subscriptions\n\
-      \# TYPE simplex_smp_subscribtion_total gauge\n\
-      \simplex_smp_subscribtion_total " <> mshow smpSubsCount <> "\n# smpSubs\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_subscribtion_clients_total Subscribed clients, first counting method\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\
+      \\n\
+      \# HELP simplex_smp_subscribtion_clients_total Subscribed clients\n\
       \# TYPE simplex_smp_subscribtion_clients_total gauge\n\
-      \simplex_smp_subscribtion_clients_total " <> mshow smpSubClientsCount <> "\n# smpSubClients\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 ntfSubsCount <> "\n# ntfSubs\n\
+      \simplex_smp_subscription_ntf_total " <> mshow (subsCount ntfSubs) <> "\n# ntf.subsCount\n\
       \\n\
-      \# HELP simplex_smp_subscription_ntf_clients_total Total subscribed NTF servers, first counting method\n\
+      \# HELP simplex_smp_subscription_ntf_clients_total Total subscribed NTF servers\n\
       \# TYPE simplex_smp_subscription_ntf_clients_total gauge\n\
-      \simplex_smp_subscription_ntf_clients_total " <> mshow ntfSubClientsCount <> "\n# ntfSubClients\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\
@@ -396,15 +509,32 @@ 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 = T.pack a <> " " <> tsEpoch
+    mstr a = a <> " " <> tsEpoch ts
     mshow :: Show a => a -> Text
-    mshow = mstr . show
-    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    mshow = mstr . tshow
+    tsEpoch t = tshow @Int64 $ floor @Double $ realToFrac (t `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 DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
@@ -10,13 +11,18 @@
 
 module Simplex.Messaging.Server.QueueStore where
 
-import Control.Applicative ((<|>))
+import Control.Applicative (optional, (<|>))
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import qualified Data.X509 as X
+import qualified Data.X509.Validation as XV
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Transport (SMPServiceRole)
 #if defined(dbServerPostgres)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Database.PostgreSQL.Simple.FromField (FromField (..))
@@ -34,22 +40,55 @@ data QueueRec = QueueRec
     queueData :: Maybe (LinkId, QueueLinkData),
     notifier :: Maybe NtfCreds,
     status :: ServerEntityStatus,
-    updatedAt :: Maybe RoundedSystemTime
+    updatedAt :: Maybe RoundedSystemTime,
+    rcvServiceId :: Maybe ServiceId
   }
   deriving (Show)
 
 data NtfCreds = NtfCreds
-  { notifierId :: !NotifierId,
-    notifierKey :: !NtfPublicAuthKey,
-    rcvNtfDhSecret :: !RcvNtfDhSecret
+  { notifierId :: NotifierId,
+    notifierKey :: NtfPublicAuthKey,
+    rcvNtfDhSecret :: RcvNtfDhSecret,
+    ntfServiceId :: Maybe ServiceId
   }
   deriving (Show)
 
 instance StrEncoding NtfCreds where
-  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
+  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId} =
+    strEncode (notifierId, notifierKey, rcvNtfDhSecret)
+      <> maybe "" ((" nsrv=" <>) . strEncode) ntfServiceId
   strP = do
     (notifierId, notifierKey, rcvNtfDhSecret) <- strP
-    pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
+    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 :: RoundedSystemTime
+  }
+  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}
 
 data ServerEntityStatus
   = EntityActive
@@ -88,3 +127,6 @@ getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` pr
 
 getSystemDate :: IO RoundedSystemTime
 getSystemDate = getRoundedSystemTime 86400
+
+getSystemSeconds :: IO RoundedSystemTime
+getSystemSeconds = RoundedSystemTime . systemSeconds <$> getSystemTime

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

@@ -21,8 +21,13 @@
 module Simplex.Messaging.Server.QueueStore.Postgres
   ( PostgresQueueStore (..),
     PostgresStoreCfg (..),
+    batchInsertServices,
     batchInsertQueues,
+    foldServiceRecs,
     foldQueueRecs,
+    handleDuplicate,
+    withLog_,
+    withDB',
   )
 where
 
@@ -32,21 +37,26 @@ 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)
+import Data.Either (fromRight, lefts)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (intersperse)
+import Data.List (foldl', intersperse, partition)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Text as T
+import qualified Data.Set as S
+import Data.Text (Text)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..))
+import qualified Data.X509 as X
+import qualified Data.X509.Validation as XV
+import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, SqlError, (:.) (..))
 import qualified Database.PostgreSQL.Simple as DB
 import qualified Database.PostgreSQL.Simple.Copy as DB
 import Database.PostgreSQL.Simple.FromField (FromField (..))
@@ -56,28 +66,29 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import GHC.IO (catchAny)
 import Simplex.Messaging.Agent.Client (withLockMap)
 import Simplex.Messaging.Agent.Lock (Lock)
+import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
-import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
 import 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 (readQueueRecIO)
+import Simplex.Messaging.Server.QueueStore.STM (STMService (..), readQueueRecIO)
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, tshow, (<$$>))
+import Simplex.Messaging.Transport (SMPServiceRole (..))
+import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>))
 import System.Exit (exitFailure)
 import System.IO (IOMode (..), hFlush, stdout)
 import UnliftIO.STM
 
 #if !defined(dbPostgres)
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
 import Simplex.Messaging.Encoding.String
 #endif
 
@@ -92,6 +103,7 @@ 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
   }
 
@@ -107,7 +119,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     links <- TM.emptyIO
     notifiers <- TM.emptyIO
     notifierLocks <- TM.emptyIO
-    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, deletedTTL}
+    serviceLocks <- TM.emptyIO
+    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL}
     where
       err e = do
         logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -127,18 +140,23 @@ 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)
 
-  queueCounts :: PostgresQueueStore q -> IO QueueCounts
-  queueCounts st =
-    withConnection (dbStore st) $ \db -> do
-      (queueCount, notifierCount) : _ <-
-        DB.query_
+  getEntityCounts :: PostgresQueueStore q -> IO EntityCounts
+  getEntityCounts st =
+    withTransaction (dbStore st) $ \db -> do
+      (queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount) : _ <-
+        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 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
           |]
-      pure QueueCounts {queueCount, notifierCount}
+          (SRMessaging, SRNotifier)
+      pure EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount}
 
   -- this implementation assumes that the lock is already taken by addQueue
   -- and relies on unique constraints in the database to prevent duplicate IDs.
@@ -162,7 +180,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
       -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
 
-  getQueue_ :: DirectParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
   getQueue_ st mkQ party qId = case party of
     SRecipient -> getRcvQueue qId
     SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
@@ -208,6 +226,47 @@ 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 = 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)
+    where
+      PostgresQueueStore {queues, notifiers} = 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_ <-
+              runExceptT $ fmap M.fromList $
+                withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
+                  >>= liftIO . fmap catMaybes . mapM (mkCacheQueue . rowToQueueRec)
+            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_
+      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')
+
   getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
   getQueueLinkData st sq lnkId = runExceptT $ do
     qr <- ExceptT $ readQueueRecIO $ queueRec sq
@@ -218,7 +277,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))
@@ -269,20 +328,20 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     where
       rId = recipientId sq
 
-  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
   addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
     withQueueRec sq "addQueueNotifier" $ \q ->
       ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
         ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do
           assertUpdated $ withDB "addQueueNotifier" st $ \db ->
             E.try (update db) >>= bimapM handleDuplicate pure
-          nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId
+          nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
           let !q' = q {notifier = Just ntfCreds}
           atomically $ writeTVar (queueRec sq) $ Just q'
           -- cache queue notifier ID – after notifier is added ntf server will likely subscribe
           atomically $ TM.insert nId rId notifiers
           withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
-          pure nId_
+          pure nc_
     where
       PostgresQueueStore {notifiers} = st
       rId = recipientId sq
@@ -291,21 +350,21 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
           db
           [sql|
             UPDATE msg_queues
-            SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ?
+            SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ?, ntf_service_id = NULL
             WHERE recipient_id = ? AND deleted_at IS NULL
           |]
           (nId, notifierKey, rcvNtfDhSecret, rId)
 
-  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
   deleteQueueNotifier st sq =
     withQueueRec sq "deleteQueueNotifier" $ \q ->
-      ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} ->
+      ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
         withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do
           assertUpdated $ withDB' "deleteQueueNotifier" st update
           atomically $ TM.delete nId $ notifiers st
           atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
           withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
-          pure nId
+          pure nc
     where
       rId = recipientId sq
       update db =
@@ -313,7 +372,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
           db
           [sql|
             UPDATE msg_queues
-            SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL
+            SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL, ntf_service_id = NULL
             WHERE recipient_id = ? AND deleted_at IS NULL
           |]
           (Only rId)
@@ -332,7 +391,7 @@ 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 -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
   updateQueueTime st sq t =
     withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
@@ -367,22 +426,95 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) 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 ->
+      fmap (fromMaybe 0) $ maybeFirstRow 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 <-
-    withConnection st $ \db -> do
+    withTransaction 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, status, updated_at, link_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, ntf_service_id, status, updated_at, link_id, rcv_service_id, fixed_data, user_data)
           FROM STDIN WITH (FORMAT CSV)
         |]
       mapM_ (putQueue db) (zip [1..] qs)
       DB.putCopyEnd db
-  Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues")
+  Only qCnt : _ <- withTransaction st (`DB.query_` "SELECT count(*) FROM msg_queues")
   putStrLn $ progress count
   pure qCnt
   where
@@ -395,13 +527,27 @@ 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, status, updated_at, link_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, ntf_service_id, status, updated_at, link_id, rcv_service_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 :: 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 ->
+  (n, r) <- withTransaction (dbStore st) $ \db ->
     foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
       r <- f qr
       let !i' = i + 1
@@ -413,12 +559,11 @@ foldQueueRecs tty withData st skipOld_ f = do
   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
+        | withData -> DB.fold_ db (queueRecQueryWithData <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
+        | otherwise -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
       Just old
-        | withData -> DB.fold db (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
+        | withData -> DB.fold db (queueRecQueryWithData <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
+        | otherwise -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
     progress i = "Processed: " <> show i <> " records"
 
 queueRecQuery :: Query
@@ -426,9 +571,8 @@ queueRecQuery =
   [sql|
     SELECT 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
+      notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id,
+      status, updated_at, link_id, rcv_service_id
     FROM msg_queues
   |]
 
@@ -437,23 +581,28 @@ queueRecQueryWithData =
   [sql|
     SELECT 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
+      notifier_id, notifier_key, rcv_ntf_dh_secret, ntf_service_id,
+      status, updated_at, link_id, rcv_service_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, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId)
+type QueueRecRow =
+  ( RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret,
+    SenderId, Maybe SndPublicAuthKey, Maybe QueueMode,
+    Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, Maybe ServiceId,
+    ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId, Maybe ServiceId
+  )
 
 queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes)
-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_)
+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)
     :. (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}) =
+queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt, rcvServiceId}) =
   LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
   where
     tabFields = BB.char7 ',' `intersperse` fields
@@ -467,9 +616,11 @@ 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_)
       ]
@@ -490,19 +641,32 @@ queueDataColumns = \case
   Nothing -> (Nothing, Nothing)
 
 rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec)
-rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) =
-  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
+rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, ntfServiceId, status, updatedAt, linkId_, rcvServiceId) =
+  let notifier = mkNotifier (notifierId_, notifierKey_, rcvNtfDhSecret_) ntfServiceId
       queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_
-   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
+   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId})
 
 rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec)
-rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) =
-  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
+rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, ntfServiceId, status, updatedAt, linkId_, rcvServiceId) :. (immutableData_, userData_)) =
+  let notifier = mkNotifier (notifierId_, notifierKey_, rcvNtfDhSecret_) ntfServiceId
       encData =  fromMaybe (EncDataBytes "")
       queueData = (,(encData immutableData_, encData userData_)) <$> linkId_
-   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
+   in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId})
 
-setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
+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, RoundedSystemTime)
+serviceRecToRow ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash = XV.Fingerprint fp, serviceCreatedAt} =
+  (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedAt)
+
+rowToServiceRec :: (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, RoundedSystemTime) -> 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 op st sq status writeLog =
   withQueueRec sq op $ \q -> do
     assertUpdated $ withDB' op st $ \db ->
@@ -510,29 +674,33 @@ setStatusDB op st sq status writeLog =
     atomically $ writeTVar (queueRec sq) $ Just q {status}
     writeLog
 
-withQueueRec :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
+withQueueRec :: StoreQueueClass q => q -> Text -> (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' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
+withDB' :: Text -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
 withDB' op st action = withDB op st $ fmap Right . action
 
-withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
+withDB :: forall a q. Text -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
 withDB op st action =
-  ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure
+  ExceptT $ E.try (withTransaction (dbStore st) action) >>= either logErr pure
   where
     logErr :: E.SomeException -> IO (Either ErrorType a)
-    logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err)
+    logErr e = logError ("STORE: " <> err) $> Left (STORE err)
       where
-        err = op <> ", withDB, " <> show e
+        err = op <> ", withDB, " <> tshow e
 
-withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
-withLog op PostgresQueueStore {dbStoreLog} action =
-  forM_ dbStoreLog $ \sl -> liftIO $ action sl `catchAny` \e ->
-    logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e)
+withLog :: MonadIO m => Text -> 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_ op sl_ action =
+  forM_ sl_ $ \sl -> liftIO $ action sl `catchAny` \e ->
+    logWarn $ "STORE: " <> op <> ", withLog, " <> tshow e
 
 handleDuplicate :: SqlError -> IO ErrorType
 handleDuplicate e = case constraintViolation e of
@@ -541,15 +709,23 @@ handleDuplicate e = case constraintViolation e of
 
 -- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL
 
-instance ToField EntityId where toField (EntityId s) = toField $ Binary s
-
-deriving newtype instance FromField EntityId
-
 instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary . smpEncode
 
 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
+
+deriving newtype instance FromField EntityId
+
 instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
 
 instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode

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

@@ -13,7 +13,8 @@ serverSchemaMigrations :: [(String, Text, Maybe Text)]
 serverSchemaMigrations =
   [ ("20250207_initial", m20250207_initial, Nothing),
     ("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index),
-    ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links)
+    ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links),
+    ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -48,7 +49,7 @@ CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at);
     |]
 
 m20250319_updated_index :: Text
-m20250319_updated_index = 
+m20250319_updated_index =
   T.pack
     [r|
 DROP INDEX idx_msg_queues_deleted_at;
@@ -119,3 +120,42 @@ UPDATE msg_queues SET recipient_keys = substring(recipient_keys from 3);
 
 ALTER TABLE msg_queues RENAME COLUMN recipient_keys TO recipient_key;
     |]
+
+m20250514_service_certs :: Text
+m20250514_service_certs =
+  T.pack
+    [r|
+CREATE TABLE services(
+  service_id BYTEA NOT NULL,
+  service_role TEXT NOT NULL,
+  service_cert BYTEA NOT NULL,
+  service_cert_hash BYTEA NOT NULL UNIQUE,
+  created_at BIGINT NOT NULL,
+  PRIMARY KEY (service_id)
+);
+
+CREATE INDEX idx_services_service_role ON services(service_role);
+
+ALTER TABLE msg_queues
+  ADD COLUMN rcv_service_id BYTEA REFERENCES services(service_id) ON DELETE SET NULL ON UPDATE RESTRICT,
+  ADD COLUMN ntf_service_id BYTEA REFERENCES services(service_id) ON DELETE SET NULL ON UPDATE RESTRICT;
+
+CREATE INDEX idx_msg_queues_rcv_service_id ON msg_queues(rcv_service_id, deleted_at);
+CREATE INDEX idx_msg_queues_ntf_service_id ON msg_queues(ntf_service_id, deleted_at);
+    |]
+
+down_m20250514_service_certs :: Text
+down_m20250514_service_certs =
+  T.pack
+    [r|
+DROP INDEX idx_msg_queues_rcv_service_id;
+DROP INDEX idx_msg_queues_ntf_service_id;
+
+ALTER TABLE msg_queues
+  DROP COLUMN rcv_service_id,
+  DROP COLUMN ntf_service_id;
+
+DROP INDEX idx_services_service_role;
+
+DROP TABLE services;
+    |]

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

@@ -41,7 +41,19 @@ CREATE TABLE smp_server.msg_queues (
     queue_mode text,
     link_id bytea,
     fixed_data bytea,
-    user_data bytea
+    user_data bytea,
+    rcv_service_id bytea,
+    ntf_service_id bytea
+);
+
+
+
+CREATE TABLE smp_server.services (
+    service_id bytea NOT NULL,
+    service_role text NOT NULL,
+    service_cert bytea NOT NULL,
+    service_cert_hash bytea NOT NULL,
+    created_at bigint NOT NULL
 );
 
 
@@ -56,6 +68,16 @@ ALTER TABLE ONLY smp_server.msg_queues
 
 
 
+ALTER TABLE ONLY smp_server.services
+    ADD CONSTRAINT services_pkey PRIMARY KEY (service_id);
+
+
+
+ALTER TABLE ONLY smp_server.services
+    ADD CONSTRAINT services_service_cert_hash_key UNIQUE (service_cert_hash);
+
+
+
 CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id);
 
 
@@ -64,6 +86,14 @@ CREATE UNIQUE INDEX idx_msg_queues_notifier_id ON smp_server.msg_queues USING bt
 
 
 
+CREATE INDEX idx_msg_queues_ntf_service_id ON smp_server.msg_queues USING btree (ntf_service_id, deleted_at);
+
+
+
+CREATE INDEX idx_msg_queues_rcv_service_id ON smp_server.msg_queues USING btree (rcv_service_id, deleted_at);
+
+
+
 CREATE UNIQUE INDEX idx_msg_queues_sender_id ON smp_server.msg_queues USING btree (sender_id);
 
 
@@ -72,3 +102,17 @@ CREATE INDEX idx_msg_queues_updated_at ON smp_server.msg_queues USING btree (del
 
 
 
+CREATE INDEX idx_services_service_role ON smp_server.services USING btree (service_role);
+
+
+
+ALTER TABLE ONLY smp_server.msg_queues
+    ADD CONSTRAINT msg_queues_ntf_service_id_fkey FOREIGN KEY (ntf_service_id) REFERENCES smp_server.services(service_id) ON UPDATE RESTRICT ON DELETE SET NULL;
+
+
+
+ALTER TABLE ONLY smp_server.msg_queues
+    ADD CONSTRAINT msg_queues_rcv_service_id_fkey FOREIGN KEY (rcv_service_id) REFERENCES smp_server.services(service_id) ON UPDATE RESTRICT ON DELETE SET NULL;
+
+
+

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

@@ -16,6 +16,7 @@
 
 module Simplex.Messaging.Server.QueueStore.STM
   ( STMQueueStore (..),
+    STMService (..),
     setStoreLog,
     withLog',
     readQueueRecIO,
@@ -28,16 +29,22 @@ import Control.Logger.Simple
 import Control.Monad
 import Data.Bitraversable (bimapM)
 import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.List (partition)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
-import qualified Data.Text as T
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.X509.Validation as XV
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (anyM, ifM, ($>>), ($>>=), (<$$))
+import Simplex.Messaging.Transport (SMPServiceRole (..))
+import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>), ($>>=), (<$$))
 import System.IO
 import UnliftIO.STM
 
@@ -45,10 +52,18 @@ data STMQueueStore q = STMQueueStore
   { queues :: TMap RecipientId q,
     senders :: TMap SenderId RecipientId,
     notifiers :: TMap NotifierId RecipientId,
+    services :: TMap ServiceId STMService,
+    serviceCerts :: TMap CertFingerprint ServiceId,
     links :: TMap LinkId RecipientId,
     storeLog :: TVar (Maybe (StoreLog 'WriteMode))
   }
 
+data STMService = STMService
+  { serviceRec :: ServiceRec,
+    serviceRcvQueues :: TVar (Set RecipientId),
+    serviceNtfQueues :: TVar (Set NotifierId)
+  }
+
 setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO ()
 setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
 
@@ -60,9 +75,11 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
     queues <- TM.emptyIO
     senders <- TM.emptyIO
     notifiers <- TM.emptyIO
+    services <- TM.emptyIO
+    serviceCerts <- TM.emptyIO
     links <- TM.emptyIO
     storeLog <- newTVarIO Nothing
-    pure STMQueueStore {queues, senders, notifiers, links, storeLog}
+    pure STMQueueStore {queues, senders, notifiers, links, services, serviceCerts, storeLog}
 
   closeQueueStore :: STMQueueStore q -> IO ()
   closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do
@@ -76,14 +93,28 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
   compactQueues _ = pure 0
   {-# INLINE compactQueues #-}
 
-  queueCounts :: STMQueueStore q -> IO QueueCounts
-  queueCounts st = do
+  getEntityCounts :: STMQueueStore q -> IO EntityCounts
+  getEntityCounts st = do
     queueCount <- M.size <$> readTVarIO (queues st)
     notifierCount <- M.size <$> readTVarIO (notifiers st)
-    pure QueueCounts {queueCount, notifierCount}
+    ss <- readTVarIO (services st)
+    rcvServiceQueuesCount <- serviceQueuesCount serviceRcvQueues ss
+    ntfServiceQueuesCount <- serviceQueuesCount serviceNtfQueues ss
+    pure
+      EntityCounts
+        { queueCount,
+          notifierCount,
+          rcvServiceCount = serviceCount SRMessaging ss,
+          ntfServiceCount = serviceCount SRNotifier ss,
+          rcvServiceQueuesCount,
+          ntfServiceQueuesCount
+        }
+    where
+      serviceCount role = M.foldl' (\ !n s -> if serviceRole (serviceRec s) == role then n + 1 else n) 0
+      serviceQueuesCount serviceSel = foldM (\n s -> (n +) . S.size <$> readTVarIO (serviceSel s)) 0
 
   addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
-  addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do
+  addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do
     sq <- mkQ rId qr
     add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
     where
@@ -91,13 +122,16 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
       add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do
         TM.insert rId q queues
         TM.insert sId rId senders
-        forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
+        forM_ notifier $ \NtfCreds {notifierId = nId, ntfServiceId} -> do
+          TM.insert nId rId notifiers
+          mapM_ (addServiceQueue st serviceNtfQueues nId) ntfServiceId
         forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links
+        mapM_ (addServiceQueue st serviceRcvQueues rId) rcvServiceId
       hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink]
       hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
       hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
 
-  getQueue_ :: DirectParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: QueueParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
   getQueue_ st _ party qId =
     maybe (Left AUTH) Right <$> case party of
       SRecipient -> TM.lookupIO qId queues
@@ -107,6 +141,20 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
     where
       STMQueueStore {queues, senders, notifiers, links} = st
 
+  getQueues_ :: BatchParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
+  getQueues_ st _ party qIds = case party of
+    SRecipient -> do
+      qs <- readTVarIO queues
+      pure $ map (get qs) qIds
+    SNotifier -> do
+      ns <- readTVarIO notifiers
+      qs <- readTVarIO queues
+      pure $ map (get qs <=< get ns) qIds
+    where
+      STMQueueStore {queues, notifiers} = st
+      get :: M.Map QueueId a -> QueueId -> Either ErrorType a
+      get m = maybe (Left AUTH) Right . (`M.lookup` m)
+
   getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
   getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData
     where
@@ -162,31 +210,31 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
           writeTVar qr $ Just q {senderKey = Just sKey}
           pure $ Right ()
 
-  addQueueNotifier :: STMQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier :: STMQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
   addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
     atomically (readQueueRec qr $>>= add)
-      $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
+      $>>= \nc_ -> nc_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
     where
       rId = recipientId sq
       qr = queueRec sq
       STMQueueStore {notifiers} = st
       add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
-        nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
+        nc_ <- forM (notifier q) $ \nc -> nc <$ removeNotifier st nc
         let !q' = q {notifier = Just ntfCreds}
         writeTVar qr $ Just q'
         TM.insert nId rId notifiers
-        pure $ Right nId_
+        pure $ Right nc_
 
-  deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
   deleteQueueNotifier st sq =
     withQueueRec qr delete
-      $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq)
+      $>>= \nc_ -> nc_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq)
     where
       qr = queueRec sq
-      delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do
-        TM.delete notifierId $ notifiers st
+      delete q = forM (notifier q) $ \nc -> do
+        removeNotifier st nc
         writeTVar qr $ Just q {notifier = Nothing}
-        pure notifierId
+        pure nc
 
   suspendQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
   suspendQueue st sq =
@@ -219,16 +267,98 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
   deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
   deleteStoreQueue st sq =
     withQueueRec qr delete
-      $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` recipientId sq)
+      $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
       >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing))
     where
+      rId = recipientId sq
       qr = queueRec sq
-      delete q = do
+      delete q@QueueRec {senderId, rcvServiceId} = do
         writeTVar qr Nothing
-        TM.delete (senderId q) $ senders st
-        forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st
+        TM.delete senderId $ senders st
+        mapM_ (removeServiceQueue st serviceRcvQueues rId) rcvServiceId
+        mapM_ (removeNotifier st) $ notifier q
         pure q
 
+  getCreateService :: STMQueueStore q -> ServiceRec -> IO (Either ErrorType ServiceId)
+  getCreateService st sr@ServiceRec {serviceId = newSrvId, serviceRole, serviceCertHash = XV.Fingerprint fp} =
+    TM.lookupIO fp serviceCerts
+      >>= maybe
+        (atomically $ TM.lookup fp serviceCerts >>= maybe newService checkService)
+        (atomically . checkService)
+      $>>= \(serviceId, new) ->
+        if new
+          then serviceId <$$ withLog "getCreateService" st (`logNewService` sr)
+          else pure $ Right serviceId
+    where
+      STMQueueStore {services, serviceCerts} = st
+      checkService sId =
+        TM.lookup sId services >>= \case
+          Just STMService {serviceRec = ServiceRec {serviceId, serviceRole = role}}
+            | role == serviceRole -> pure $ Right (serviceId, False)
+            | otherwise -> pure $ Left $ SERVICE
+          Nothing -> newService_
+      newService = ifM (TM.member newSrvId services) (pure $ Left DUPLICATE_) newService_
+      newService_ = do
+        TM.insertM newSrvId newSTMService services
+        TM.insert fp newSrvId serviceCerts
+        pure $ Right (newSrvId, True)
+      newSTMService = do
+        serviceRcvQueues <- newTVar S.empty
+        serviceNtfQueues <- newTVar S.empty
+        pure STMService {serviceRec = sr, serviceRcvQueues, serviceNtfQueues}
+
+  setQueueService :: (PartyI p, ServiceParty p) => STMQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
+  setQueueService st sq party serviceId =
+    atomically (readQueueRec qr $>>= setService)
+      $>> withLog "setQueueService" st (\sl -> logQueueService sl rId party serviceId)
+    where
+      qr = queueRec sq
+      rId = recipientId sq
+      setService :: QueueRec -> STM (Either ErrorType ())
+      setService q@QueueRec {rcvServiceId = prevSrvId} = case party of
+        SRecipientService
+          | prevSrvId == serviceId -> pure $ Right ()
+          | otherwise -> do
+              updateServiceQueues serviceRcvQueues rId prevSrvId
+              let !q' = Just q {rcvServiceId = serviceId}
+              writeTVar qr q' $> Right ()
+        SNotifierService -> case notifier q of
+          Nothing -> pure $ Left AUTH
+          Just nc@NtfCreds {notifierId = nId, ntfServiceId = prevNtfSrvId}
+            | prevNtfSrvId == serviceId -> pure $ Right ()
+            | otherwise -> do
+                let !q' = Just q {notifier = Just nc {ntfServiceId = serviceId}}
+                updateServiceQueues serviceNtfQueues nId prevNtfSrvId
+                writeTVar qr q' $> Right ()
+      updateServiceQueues :: (STMService -> TVar (Set QueueId)) -> QueueId -> Maybe ServiceId -> STM ()
+      updateServiceQueues serviceSel qId prevSrvId = do
+        mapM_ (removeServiceQueue st serviceSel qId) prevSrvId
+        mapM_ (addServiceQueue st serviceSel qId) serviceId
+
+  getQueueNtfServices :: STMQueueStore q -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
+  getQueueNtfServices st ntfs = do
+    ss <- readTVarIO (services st)
+    (ssNtfs, noServiceNtfs) <- if M.null ss then pure ([], ntfs) else foldM addService ([], ntfs) (M.assocs ss)
+    ns <- readTVarIO (notifiers st)
+    let (ntfs', deleteNtfs) = partition (\(nId, _) -> M.member nId ns) noServiceNtfs
+        ssNtfs' = (Nothing, ntfs') : ssNtfs
+    pure $ Right (ssNtfs', deleteNtfs)
+    where
+      addService (ssNtfs, ntfs') (serviceId, s) = do
+        snIds <- readTVarIO $ serviceNtfQueues s
+        let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
+        pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs)
+
+  getServiceQueueCount :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
+  getServiceQueueCount st party serviceId =
+    TM.lookupIO serviceId (services st) >>=
+      maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceSel)
+    where
+      serviceSel :: STMService -> TVar (Set QueueId)
+      serviceSel = case party of
+        SRecipientService -> serviceRcvQueues
+        SNotifierService -> serviceNtfQueues
+
 withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
 withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
 
@@ -238,6 +368,21 @@ setStatus qr status =
     Just q -> (Right (), Just q {status})
     Nothing -> (Left AUTH, Nothing)
 
+addServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId)) -> QueueId -> ServiceId -> STM ()
+addServiceQueue st serviceSel qId serviceId =
+  TM.lookup serviceId (services st) >>= mapM_ (\s -> modifyTVar' (serviceSel s) (S.insert qId))
+{-# INLINE addServiceQueue #-}
+
+removeServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId)) -> QueueId -> ServiceId -> STM ()
+removeServiceQueue st serviceSel qId serviceId =
+  TM.lookup serviceId (services st) >>= mapM_ (\s -> modifyTVar' (serviceSel s) (S.delete qId))
+{-# INLINE removeServiceQueue #-}
+
+removeNotifier :: STMQueueStore q -> NtfCreds -> STM ()
+removeNotifier st NtfCreds {notifierId = nId, ntfServiceId} = do
+  TM.delete nId $ notifiers st
+  mapM_ (removeServiceQueue st serviceNtfQueues nId) ntfServiceId
+
 readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
 readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr
 {-# INLINE readQueueRec #-}
@@ -246,16 +391,16 @@ readQueueRecIO :: TVar (Maybe QueueRec) -> IO (Either ErrorType QueueRec)
 readQueueRecIO qr = maybe (Left AUTH) Right <$> readTVarIO qr
 {-# INLINE readQueueRecIO #-}
 
-withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
+withLog' :: Text -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
 withLog' name sl action =
   readTVarIO sl
     >>= maybe (pure $ Right ()) (E.try . E.uninterruptibleMask_ . action >=> bimapM logErr pure)
   where
     logErr :: E.SomeException -> IO ErrorType
-    logErr e = logError ("STORE: " <> T.pack err) $> STORE err
+    logErr e = logError ("STORE: " <> err) $> STORE err
       where
-        err = name <> ", withLog, " <> show e
+        err = name <> ", withLog, " <> tshow e
 
-withLog :: String -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
+withLog :: Text -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
 withLog name = withLog' name . storeLog
 {-# INLINE withLog #-}

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

@@ -11,6 +11,7 @@ import Control.Concurrent.STM
 import Control.Monad
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.TMap (TMap)
@@ -20,33 +21,42 @@ class StoreQueueClass q where
   recipientId :: q -> RecipientId
   queueRec :: q -> TVar (Maybe QueueRec)
   msgQueue :: q -> TVar (Maybe (MsgQueue q))
-  withQueueLock :: q -> String -> IO a -> IO a
+  withQueueLock :: q -> Text -> IO a -> IO a
 
 class StoreQueueClass q => QueueStoreClass q s where
   type QueueStoreCfg s
   newQueueStore :: QueueStoreCfg s -> IO s
   closeQueueStore :: s -> IO ()
-  queueCounts :: s -> IO QueueCounts
+  getEntityCounts :: s -> IO EntityCounts
   loadedQueues :: s -> TMap RecipientId q
   compactQueues :: s -> IO Int64
   addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
-  getQueue_ :: DirectParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: QueueParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueues_ :: BatchParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
   getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
   addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
   deleteQueueLinkData :: s -> q -> IO (Either ErrorType ())
   secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
   updateKeys :: s -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ())
-  addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
-  deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
+  deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NtfCreds))
   suspendQueue :: s -> q -> IO (Either ErrorType ())
   blockQueue :: s -> q -> BlockingInfo -> IO (Either ErrorType ())
   unblockQueue :: s -> q -> IO (Either ErrorType ())
   updateQueueTime :: s -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
   deleteStoreQueue :: s -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  getCreateService :: s -> ServiceRec -> IO (Either ErrorType ServiceId)
+  setQueueService :: (PartyI p, ServiceParty p) => s -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
+  getQueueNtfServices :: s -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
+  getServiceQueueCount :: (PartyI p, ServiceParty p) => s -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
 
-data QueueCounts = QueueCounts
+data EntityCounts = EntityCounts
   { queueCount :: Int,
-    notifierCount :: Int
+    notifierCount :: Int,
+    rcvServiceCount :: Int,
+    ntfServiceCount :: Int,
+    rcvServiceQueuesCount :: Int,
+    ntfServiceQueuesCount :: Int
   }
 
 withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a

src/Simplex/Messaging/Server/Stats.hs

@@ -14,17 +14,21 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Hashable (hash)
 import Data.IORef
+import Data.Int (Int64)
+import qualified Data.IntMap.Strict as IM
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IS
 import Data.Set (Set)
 import qualified Data.Set as S
+import Data.Text (Text)
 import Data.Time.Calendar.Month (pattern MonthDay)
 import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..))
 import GHC.IORef (atomicSwapIORef)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (EntityId (..))
-import Simplex.Messaging.Util (atomicModifyIORef'_, unlessM)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
+import Simplex.Messaging.Util (atomicModifyIORef'_, tshow, unlessM)
 
 data ServerStats = ServerStats
   { fromTime :: IORef UTCTime,
@@ -44,6 +48,7 @@ data ServerStats = ServerStats
     qSubEnd :: IORef Int,
     qSubEndB :: IORef Int,
     ntfCreated :: IORef Int,
+    ntfNewCreated :: IORef Int, -- credentials created at the time of queue creation
     ntfDeleted :: IORef Int,
     ntfDeletedB :: IORef Int,
     ntfSub :: IORef Int,
@@ -56,6 +61,7 @@ data ServerStats = ServerStats
     msgSentLarge :: IORef Int,
     msgSentBlock :: IORef Int,
     msgRecv :: IORef Int,
+    msgRecvAckTimes :: IORef TimeBuckets,
     msgRecvGet :: IORef Int,
     msgGet :: IORef Int,
     msgGetNoMsg :: IORef Int,
@@ -78,6 +84,8 @@ data ServerStats = ServerStats
     pMsgFwds :: ProxyStats,
     pMsgFwdsOwn :: ProxyStats,
     pMsgFwdsRecv :: IORef Int,
+    rcvServices :: ServiceStats,
+    ntfServices :: ServiceStats,
     qCount :: IORef Int,
     msgCount :: IORef Int,
     ntfCount :: IORef Int
@@ -100,6 +108,7 @@ data ServerStatsData = ServerStatsData
     _qSubEnd :: Int,
     _qSubEndB :: Int,
     _ntfCreated :: Int,
+    _ntfNewCreated :: Int,
     _ntfDeleted :: Int,
     _ntfDeletedB :: Int,
     _ntfSub :: Int,
@@ -112,6 +121,7 @@ data ServerStatsData = ServerStatsData
     _msgSentLarge :: Int,
     _msgSentBlock :: Int,
     _msgRecv :: Int,
+    _msgRecvAckTimes :: TimeBuckets,
     _msgRecvGet :: Int,
     _msgGet :: Int,
     _msgGetNoMsg :: Int,
@@ -133,6 +143,8 @@ data ServerStatsData = ServerStatsData
     _pMsgFwds :: ProxyStatsData,
     _pMsgFwdsOwn :: ProxyStatsData,
     _pMsgFwdsRecv :: Int,
+    _ntfServices :: ServiceStatsData,
+    _rcvServices :: ServiceStatsData,
     _qCount :: Int,
     _msgCount :: Int,
     _ntfCount :: Int
@@ -157,6 +169,7 @@ newServerStats ts = do
   qSubEnd <- newIORef 0
   qSubEndB <- newIORef 0
   ntfCreated <- newIORef 0
+  ntfNewCreated <- newIORef 0
   ntfDeleted <- newIORef 0
   ntfDeletedB <- newIORef 0
   ntfSub <- newIORef 0
@@ -169,6 +182,7 @@ newServerStats ts = do
   msgSentLarge <- newIORef 0
   msgSentBlock <- newIORef 0
   msgRecv <- newIORef 0
+  msgRecvAckTimes <- newIORef $ TimeBuckets 0 0 IM.empty
   msgRecvGet <- newIORef 0
   msgGet <- newIORef 0
   msgGetNoMsg <- newIORef 0
@@ -190,6 +204,8 @@ newServerStats ts = do
   pMsgFwds <- newProxyStats
   pMsgFwdsOwn <- newProxyStats
   pMsgFwdsRecv <- newIORef 0
+  rcvServices <- newServiceStats
+  ntfServices <- newServiceStats
   qCount <- newIORef 0
   msgCount <- newIORef 0
   ntfCount <- newIORef 0
@@ -211,6 +227,7 @@ newServerStats ts = do
         qSubEnd,
         qSubEndB,
         ntfCreated,
+        ntfNewCreated,
         ntfDeleted,
         ntfDeletedB,
         ntfSub,
@@ -223,6 +240,7 @@ newServerStats ts = do
         msgSentLarge,
         msgSentBlock,
         msgRecv,
+        msgRecvAckTimes,
         msgRecvGet,
         msgGet,
         msgGetNoMsg,
@@ -244,6 +262,8 @@ newServerStats ts = do
         pMsgFwds,
         pMsgFwdsOwn,
         pMsgFwdsRecv,
+        rcvServices,
+        ntfServices,
         qCount,
         msgCount,
         ntfCount
@@ -267,6 +287,7 @@ getServerStatsData s = do
   _qSubEnd <- readIORef $ qSubEnd s
   _qSubEndB <- readIORef $ qSubEndB s
   _ntfCreated <- readIORef $ ntfCreated s
+  _ntfNewCreated <- readIORef $ ntfNewCreated s
   _ntfDeleted <- readIORef $ ntfDeleted s
   _ntfDeletedB <- readIORef $ ntfDeletedB s
   _ntfSub <- readIORef $ ntfSub s
@@ -279,6 +300,7 @@ getServerStatsData s = do
   _msgSentLarge <- readIORef $ msgSentLarge s
   _msgSentBlock <- readIORef $ msgSentBlock s
   _msgRecv <- readIORef $ msgRecv s
+  _msgRecvAckTimes <- readIORef $ msgRecvAckTimes s
   _msgRecvGet <- readIORef $ msgRecvGet s
   _msgGet <- readIORef $ msgGet s
   _msgGetNoMsg <- readIORef $ msgGetNoMsg s
@@ -300,6 +322,8 @@ getServerStatsData s = do
   _pMsgFwds <- getProxyStatsData $ pMsgFwds s
   _pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
   _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
+  _rcvServices <- getServiceStatsData $ rcvServices s
+  _ntfServices <- getServiceStatsData $ ntfServices s
   _qCount <- readIORef $ qCount s
   _msgCount <- readIORef $ msgCount s
   _ntfCount <- readIORef $ ntfCount s
@@ -321,6 +345,7 @@ getServerStatsData s = do
         _qSubEnd,
         _qSubEndB,
         _ntfCreated,
+        _ntfNewCreated,
         _ntfDeleted,
         _ntfDeletedB,
         _ntfSub,
@@ -333,6 +358,7 @@ getServerStatsData s = do
         _msgSentLarge,
         _msgSentBlock,
         _msgRecv,
+        _msgRecvAckTimes,
         _msgRecvGet,
         _msgGet,
         _msgGetNoMsg,
@@ -354,6 +380,8 @@ getServerStatsData s = do
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
+        _rcvServices,
+        _ntfServices,
         _qCount,
         _msgCount,
         _ntfCount
@@ -378,6 +406,7 @@ setServerStats s d = do
   writeIORef (qSubEnd s) $! _qSubEnd d
   writeIORef (qSubEndB s) $! _qSubEndB d
   writeIORef (ntfCreated s) $! _ntfCreated d
+  writeIORef (ntfNewCreated s) $! _ntfNewCreated d
   writeIORef (ntfDeleted s) $! _ntfDeleted d
   writeIORef (ntfDeletedB s) $! _ntfDeletedB d
   writeIORef (ntfSub s) $! _ntfSub d
@@ -390,6 +419,7 @@ setServerStats s d = do
   writeIORef (msgSentLarge s) $! _msgSentLarge d
   writeIORef (msgSentBlock s) $! _msgSentBlock d
   writeIORef (msgRecv s) $! _msgRecv d
+  writeIORef (msgRecvAckTimes s) $! _msgRecvAckTimes d
   writeIORef (msgRecvGet s) $! _msgRecvGet d
   writeIORef (msgGet s) $! _msgGet d
   writeIORef (msgGetNoMsg s) $! _msgGetNoMsg d
@@ -411,6 +441,8 @@ setServerStats s d = do
   setProxyStats (pMsgFwds s) $! _pMsgFwds d
   setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
   writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
+  setServiceStats (rcvServices s) $! _rcvServices d
+  setServiceStats (ntfServices s) $! _ntfServices d
   writeIORef (qCount s) $! _qCount d
   writeIORef (msgCount s) $! _msgCount d
   writeIORef (ntfCount s) $! _ntfCount d
@@ -435,6 +467,7 @@ instance StrEncoding ServerStatsData where
         "qSubEnd=" <> strEncode (_qSubEnd d),
         "qSubEndB=" <> strEncode (_qSubEndB d),
         "ntfCreated=" <> strEncode (_ntfCreated d),
+        "ntfNewCreated=" <> strEncode (_ntfNewCreated d),
         "ntfDeleted=" <> strEncode (_ntfDeleted d),
         "ntfDeletedB=" <> strEncode (_ntfDeletedB d),
         "ntfSub=" <> strEncode (_ntfSub d),
@@ -473,7 +506,11 @@ instance StrEncoding ServerStatsData where
         strEncode (_pMsgFwds d),
         "pMsgFwdsOwn:",
         strEncode (_pMsgFwdsOwn d),
-        "pMsgFwdsRecv=" <> strEncode (_pMsgFwdsRecv d)
+        "pMsgFwdsRecv=" <> strEncode (_pMsgFwdsRecv d),
+        "rcvServices:",
+        strEncode (_rcvServices d),
+        "ntfServices:",
+        strEncode (_ntfServices d)
       ]
   strP = do
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -494,6 +531,7 @@ instance StrEncoding ServerStatsData where
     _qSubEnd <- opt "qSubEnd="
     _qSubEndB <- opt "qSubEndB="
     _ntfCreated <- opt "ntfCreated="
+    _ntfNewCreated <- opt "ntfNewCreated="
     _ntfDeleted <- opt "ntfDeleted="
     _ntfDeletedB <- opt "ntfDeletedB="
     _ntfSub <- opt "ntfSub="
@@ -541,6 +579,8 @@ instance StrEncoding ServerStatsData where
     _pMsgFwds <- proxyStatsP "pMsgFwds:"
     _pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:"
     _pMsgFwdsRecv <- opt "pMsgFwdsRecv="
+    _rcvServices <- serviceStatsP "rcvServices:"
+    _ntfServices <- serviceStatsP "ntfServices:"
     pure
       ServerStatsData
         { _fromTime,
@@ -559,6 +599,7 @@ instance StrEncoding ServerStatsData where
           _qSubEnd,
           _qSubEndB,
           _ntfCreated,
+          _ntfNewCreated,
           _ntfDeleted,
           _ntfDeletedB,
           _ntfSub,
@@ -571,6 +612,7 @@ instance StrEncoding ServerStatsData where
           _msgSentLarge,
           _msgSentBlock,
           _msgRecv,
+          _msgRecvAckTimes = emptyTimeBuckets,
           _msgRecvGet,
           _msgGet,
           _msgGetNoMsg,
@@ -592,6 +634,8 @@ instance StrEncoding ServerStatsData where
           _pMsgFwds,
           _pMsgFwdsOwn,
           _pMsgFwdsRecv,
+          _rcvServices,
+          _ntfServices,
           _qCount,
           _msgCount = 0,
           _ntfCount = 0
@@ -603,6 +647,10 @@ instance StrEncoding ServerStatsData where
         optional (A.string key >> A.endOfLine) >>= \case
           Just _ -> strP <* optional A.endOfLine
           _ -> pure newProxyStatsData
+      serviceStatsP key =
+        optional (A.string key >> A.endOfLine) >>= \case
+          Just _ -> strP <* optional A.endOfLine
+          _ -> pure newServiceStatsData
 
 data PeriodStats = PeriodStats
   { day :: IORef IntSet,
@@ -653,17 +701,17 @@ instance StrEncoding PeriodStatsData where
       bsSetP = S.foldl' (\s -> (`IS.insert` s) . hash) IS.empty <$> strP @(Set ByteString)
 
 data PeriodStatCounts = PeriodStatCounts
-  { dayCount :: String,
-    weekCount :: String,
-    monthCount :: String
+  { dayCount :: Text,
+    weekCount :: Text,
+    monthCount :: Text
   }
 
 periodStatDataCounts :: PeriodStatsData -> PeriodStatCounts
 periodStatDataCounts PeriodStatsData {_day, _week, _month} =
   PeriodStatCounts
-    { dayCount = show $ IS.size _day,
-      weekCount = show $ IS.size _week,
-      monthCount = show $ IS.size _month
+    { dayCount = tshow $ IS.size _day,
+      weekCount = tshow $ IS.size _week,
+      monthCount = tshow $ IS.size _month
     }
 
 periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts
@@ -676,8 +724,8 @@ periodStatCounts ps ts = do
   monthCount <- periodCount mDay $ month ps
   pure PeriodStatCounts {dayCount, weekCount, monthCount}
   where
-    periodCount :: Int -> IORef IntSet -> IO String
-    periodCount 1 ref = show . IS.size <$> atomicSwapIORef ref IS.empty
+    periodCount :: Int -> IORef IntSet -> IO Text
+    periodCount 1 ref = tshow . IS.size <$> atomicSwapIORef ref IS.empty
     periodCount _ _ = pure ""
 
 updatePeriodStats :: PeriodStats -> EntityId -> IO ()
@@ -764,3 +812,186 @@ instance StrEncoding ProxyStatsData where
     _pErrorsCompat <- "errorsCompat=" *> strP <* A.endOfLine
     _pErrorsOther <- "errorsOther=" *> strP
     pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
+
+data ServiceStats = ServiceStats
+  { srvAssocNew :: IORef Int,
+    srvAssocDuplicate :: IORef Int,
+    srvAssocUpdated :: IORef Int,
+    srvAssocRemoved :: IORef Int,
+    srvSubCount :: IORef Int,
+    srvSubDuplicate :: IORef Int,
+    srvSubQueues :: IORef Int,
+    srvSubEnd :: IORef Int
+  }
+
+data ServiceStatsData = ServiceStatsData
+  { _srvAssocNew :: Int,
+    _srvAssocDuplicate :: Int,
+    _srvAssocUpdated :: Int,
+    _srvAssocRemoved :: Int,
+    _srvSubCount :: Int,
+    _srvSubDuplicate :: Int,
+    _srvSubQueues :: Int,
+    _srvSubEnd :: Int
+  }
+  deriving (Show)
+
+newServiceStatsData :: ServiceStatsData
+newServiceStatsData =
+  ServiceStatsData
+    { _srvAssocNew = 0,
+      _srvAssocDuplicate = 0,
+      _srvAssocUpdated = 0,
+      _srvAssocRemoved = 0,
+      _srvSubCount = 0,
+      _srvSubDuplicate = 0,
+      _srvSubQueues = 0,
+      _srvSubEnd = 0
+    }
+
+newServiceStats :: IO ServiceStats
+newServiceStats = do
+  srvAssocNew <- newIORef 0
+  srvAssocDuplicate <- newIORef 0
+  srvAssocUpdated <- newIORef 0
+  srvAssocRemoved <- newIORef 0
+  srvSubCount <- newIORef 0
+  srvSubDuplicate <- newIORef 0
+  srvSubQueues <- newIORef 0
+  srvSubEnd <- newIORef 0
+  pure
+    ServiceStats
+      { srvAssocNew,
+        srvAssocDuplicate,
+        srvAssocUpdated,
+        srvAssocRemoved,
+        srvSubCount,
+        srvSubDuplicate,
+        srvSubQueues,
+        srvSubEnd
+      }
+
+getServiceStatsData :: ServiceStats -> IO ServiceStatsData
+getServiceStatsData s = do
+  _srvAssocNew <- readIORef $ srvAssocNew s
+  _srvAssocDuplicate <- readIORef $ srvAssocDuplicate s
+  _srvAssocUpdated <- readIORef $ srvAssocUpdated s
+  _srvAssocRemoved <- readIORef $ srvAssocRemoved s
+  _srvSubCount <- readIORef $ srvSubCount s
+  _srvSubDuplicate <- readIORef $ srvSubDuplicate s
+  _srvSubQueues <- readIORef $ srvSubQueues s
+  _srvSubEnd <- readIORef $ srvSubEnd s
+  pure
+    ServiceStatsData
+      { _srvAssocNew,
+        _srvAssocDuplicate,
+        _srvAssocUpdated,
+        _srvAssocRemoved,
+        _srvSubCount,
+        _srvSubDuplicate,
+        _srvSubQueues,
+        _srvSubEnd
+      }
+
+getResetServiceStatsData :: ServiceStats -> IO ServiceStatsData
+getResetServiceStatsData s = do
+  _srvAssocNew <- atomicSwapIORef (srvAssocNew s) 0
+  _srvAssocDuplicate <- atomicSwapIORef (srvAssocDuplicate s) 0
+  _srvAssocUpdated <- atomicSwapIORef (srvAssocUpdated s) 0
+  _srvAssocRemoved <- atomicSwapIORef (srvAssocRemoved s) 0
+  _srvSubCount <- atomicSwapIORef (srvSubCount s) 0
+  _srvSubDuplicate <- atomicSwapIORef (srvSubDuplicate s) 0
+  _srvSubQueues <- atomicSwapIORef (srvSubQueues s) 0
+  _srvSubEnd <- atomicSwapIORef (srvSubEnd s) 0
+  pure
+    ServiceStatsData
+      { _srvAssocNew,
+        _srvAssocDuplicate,
+        _srvAssocUpdated,
+        _srvAssocRemoved,
+        _srvSubCount,
+        _srvSubDuplicate,
+        _srvSubQueues,
+        _srvSubEnd
+      }
+
+-- this function is not thread safe, it is used on server start only
+setServiceStats :: ServiceStats -> ServiceStatsData -> IO ()
+setServiceStats s d = do
+  writeIORef (srvAssocNew s) $! _srvAssocNew d
+  writeIORef (srvAssocDuplicate s) $! _srvAssocDuplicate d
+  writeIORef (srvAssocUpdated s) $! _srvAssocUpdated d
+  writeIORef (srvAssocRemoved s) $! _srvAssocRemoved d
+  writeIORef (srvSubCount s) $! _srvSubCount d
+  writeIORef (srvSubDuplicate s) $! _srvSubDuplicate d
+  writeIORef (srvSubQueues s) $! _srvSubQueues d
+  writeIORef (srvSubEnd s) $! _srvSubEnd d
+
+instance StrEncoding ServiceStatsData where
+  strEncode ServiceStatsData {_srvAssocNew, _srvAssocDuplicate, _srvAssocUpdated, _srvAssocRemoved, _srvSubCount, _srvSubDuplicate, _srvSubQueues, _srvSubEnd} =
+    "assocNew="
+      <> strEncode _srvAssocNew
+      <> "\nassocDuplicate="
+      <> strEncode _srvAssocDuplicate
+      <> "\nassocUpdatedt="
+      <> strEncode _srvAssocUpdated
+      <> "\nassocRemoved="
+      <> strEncode _srvAssocRemoved
+      <> "\nsubCount="
+      <> strEncode _srvSubCount
+      <> "\nsubDuplicate="
+      <> strEncode _srvSubDuplicate
+      <> "\nsubQueues="
+      <> strEncode _srvSubQueues
+      <> "\nsubEnd="
+      <> strEncode _srvSubEnd
+  strP = do
+    _srvAssocNew <- "assocNew=" *> strP <* A.endOfLine
+    _srvAssocDuplicate <- "assocDuplicate=" *> strP <* A.endOfLine
+    _srvAssocUpdated <- "assocUpdatedt=" *> strP <* A.endOfLine
+    _srvAssocRemoved <- "assocRemoved=" *> strP <* A.endOfLine
+    _srvSubCount <- "subCount=" *> strP <* A.endOfLine
+    _srvSubDuplicate <- "subDuplicate=" *> strP <* A.endOfLine
+    _srvSubQueues <- "subQueues=" *> strP <* A.endOfLine
+    _srvSubEnd <- "subEnd=" *> strP
+    pure
+      ServiceStatsData
+        { _srvAssocNew,
+          _srvAssocDuplicate,
+          _srvAssocUpdated,
+          _srvAssocRemoved,
+          _srvSubCount,
+          _srvSubDuplicate,
+          _srvSubQueues,
+          _srvSubEnd
+        }
+
+data TimeBuckets = TimeBuckets
+  { sumTime :: Int64,
+    maxTime :: Int64,
+    timeBuckets :: IM.IntMap Int
+  }
+  deriving (Show)
+
+emptyTimeBuckets :: TimeBuckets
+emptyTimeBuckets = TimeBuckets 0 0 IM.empty
+
+updateTimeBuckets :: RoundedSystemTime -> RoundedSystemTime -> TimeBuckets -> TimeBuckets
+updateTimeBuckets
+  (RoundedSystemTime deliveryTime)
+  (RoundedSystemTime currTime)
+  TimeBuckets {sumTime, maxTime, timeBuckets} =
+    TimeBuckets
+      { sumTime = sumTime + t,
+        maxTime = max maxTime t,
+        timeBuckets = IM.alter (Just . maybe 1 (+ 1)) seconds timeBuckets
+      }
+  where
+    t = currTime - deliveryTime
+    seconds
+      | t <= 5 = fromIntegral t
+      | t <= 30 = t `toBucket` 5
+      | t <= 60 = t `toBucket` 10
+      | t <= 180 = t `toBucket` 30
+      | otherwise = t `toBucket` 60
+    toBucket n m = - fromIntegral (((- n) `div` m) * m) -- round up

src/Simplex/Messaging/Server/StoreLog.hs

@@ -29,6 +29,8 @@ module Simplex.Messaging.Server.StoreLog
     logDeleteQueue,
     logDeleteNotifier,
     logUpdateQueueTime,
+    logNewService,
+    logQueueService,
     readWriteStoreLog,
     readLogLines,
     foldLogLines,
@@ -74,6 +76,8 @@ data StoreLogRecord
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
   | UpdateTime QueueId RoundedSystemTime
+  | NewService ServiceRec
+  | QueueService RecipientId ASubscriberParty (Maybe ServiceId)
   deriving (Show)
 
 data SLRTag
@@ -89,24 +93,29 @@ data SLRTag
   | DeleteQueue_
   | DeleteNotifier_
   | UpdateTime_
+  | NewService_
+  | QueueService_
 
 instance StrEncoding QueueRec where
-  strEncode QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} =
-    B.unwords
-      [ "rk=" <> strEncode recipientKeys,
-        "rdh=" <> strEncode rcvDhSecret,
-        "sid=" <> strEncode senderId,
-        "sk=" <> strEncode senderKey
+  strEncode QueueRec {recipientKeys, rcvDhSecret, rcvServiceId, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} =
+    B.concat
+      [ p "rk=" recipientKeys,
+        p " rdh=" rcvDhSecret,
+        p " sid=" senderId,
+        p " sk=" senderKey,
+        maybe "" ((" queue_mode=" <>) . smpEncode) queueMode,
+        opt " link_id=" (fst <$> queueData),
+        opt " queue_data=" (snd <$> queueData),
+        opt " notifier=" notifier,
+        opt " updated_at=" updatedAt,
+        statusStr,
+        opt " rsrv=" rcvServiceId
       ]
-      <> maybe "" ((" queue_mode=" <>) . smpEncode) queueMode
-      <> opt " link_id=" (fst <$> queueData)
-      <> opt " queue_data=" (snd <$> queueData)
-      <> opt " notifier=" notifier
-      <> opt " updated_at=" updatedAt
-      <> statusStr
     where
+      p :: StrEncoding a => ByteString -> a -> ByteString
+      p param = (param <>) . strEncode
       opt :: StrEncoding a => ByteString -> Maybe a -> ByteString
-      opt param = maybe "" ((param <>) . strEncode)
+      opt = maybe "" . p
       statusStr = case status of
         EntityActive -> ""
         _ -> " status=" <> strEncode status
@@ -124,7 +133,20 @@ instance StrEncoding QueueRec where
     notifier <- optional $ " notifier=" *> strP
     updatedAt <- optional $ " updated_at=" *> strP
     status <- (" status=" *> strP) <|> pure EntityActive
-    pure QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}
+    rcvServiceId <- optional $ " rsrv=" *> strP
+    pure
+      QueueRec
+        { recipientKeys,
+          rcvDhSecret,
+          senderId,
+          senderKey,
+          queueMode,
+          queueData,
+          notifier,
+          status,
+          updatedAt,
+          rcvServiceId
+        }
     where
       toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact
 
@@ -142,6 +164,8 @@ instance StrEncoding SLRTag where
     DeleteQueue_ -> "DELETE"
     DeleteNotifier_ -> "NDELETE"
     UpdateTime_ -> "TIME"
+    NewService_ -> "NEW_SERVICE"
+    QueueService_ -> "QUEUE_SERVICE"
 
   strP =
     A.choice
@@ -156,7 +180,9 @@ instance StrEncoding SLRTag where
         "UNBLOCK" $> UnblockQueue_,
         "DELETE" $> DeleteQueue_,
         "NDELETE" $> DeleteNotifier_,
-        "TIME" $> UpdateTime_
+        "TIME" $> UpdateTime_,
+        "NEW_SERVICE" $> NewService_,
+        "QUEUE_SERVICE" $> QueueService_
       ]
 
 instance StrEncoding StoreLogRecord where
@@ -173,6 +199,8 @@ instance StrEncoding StoreLogRecord where
     DeleteQueue rId -> strEncode (DeleteQueue_, rId)
     DeleteNotifier rId -> strEncode (DeleteNotifier_, rId)
     UpdateTime rId t ->  strEncode (UpdateTime_, rId, t)
+    NewService sr -> strEncode (NewService_, sr)
+    QueueService rId party serviceId -> strEncode (QueueService_, rId, party, serviceId)
 
   strP =
     strP_ >>= \case
@@ -188,6 +216,8 @@ instance StrEncoding StoreLogRecord where
       DeleteQueue_ -> DeleteQueue <$> strP
       DeleteNotifier_ -> DeleteNotifier <$> strP
       UpdateTime_ -> UpdateTime <$> strP_ <*> strP
+      NewService_ -> NewService <$> strP
+      QueueService_ -> QueueService <$> strP_ <*> strP_ <*> strP
 
 openWriteStoreLog :: Bool -> FilePath -> IO (StoreLog 'WriteMode)
 openWriteStoreLog append f = do
@@ -253,6 +283,12 @@ logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
 logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
 
+logNewService :: StoreLog 'WriteMode -> ServiceRec -> IO ()
+logNewService s  = writeStoreLogRecord s . NewService
+
+logQueueService :: (PartyI p, ServiceParty p) => StoreLog 'WriteMode -> RecipientId -> SParty p -> Maybe ServiceId -> IO ()
+logQueueService s rId party = writeStoreLogRecord s . QueueService rId (ASP party)
+
 readWriteStoreLog :: (FilePath -> s -> IO ()) -> (StoreLog 'WriteMode -> s -> IO ()) -> FilePath -> s -> IO (StoreLog 'WriteMode)
 readWriteStoreLog readStore writeStore f st =
   ifM
@@ -267,7 +303,7 @@ readWriteStoreLog readStore writeStore f st =
       logWarn $ "Server terminated abnormally on last start, restoring state from " <> T.pack tempBackup
       whenM (doesFileExist f) $ do
         renameFile f (f <> ".bak")
-        logInfo $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
+        logNote $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
       renameFile tempBackup f
     readWriteLog = do
       -- log backup is made in two steps to mitigate the crash during the compacting.
@@ -280,14 +316,14 @@ readWriteStoreLog readStore writeStore f st =
       pure s
     writeLog msg = do
       s <- openWriteStoreLog False f
-      logInfo msg
+      logNote msg
       writeStore s st
       pure s
     renameBackup = do
       ts <- getCurrentTime
       let timedBackup = f <> "." <> iso8601Show ts
       renameFile tempBackup timedBackup
-      logInfo $ "original state preserved as " <> T.pack timedBackup
+      logNote $ "original state preserved as " <> T.pack timedBackup
 
 removeStoreLogBackups :: FilePath -> IO ()
 removeStoreLogBackups f = do

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

@@ -2,8 +2,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Server.StoreLog.ReadWrite where
 
@@ -16,24 +18,23 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ErrorType, RecipientId, SParty (..))
-import Simplex.Messaging.Server.QueueStore (QueueRec)
+import Simplex.Messaging.Protocol (ASubscriberParty (..), ErrorType, RecipientId, SParty (..))
+import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..))
+import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..))
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (tshow)
 import System.IO
 
-writeQueueStore :: forall q s. QueueStoreClass q s => StoreLog 'WriteMode -> s -> IO ()
-writeQueueStore s st = withLoadedQueues st $ writeQueue
+writeQueueStore :: forall q. StoreQueueClass q => StoreLog 'WriteMode -> STMQueueStore q -> IO ()
+writeQueueStore s st = do
+  readTVarIO (services st) >>= mapM_ (logNewService s . serviceRec)
+  withLoadedQueues st $ writeQueue
   where
     writeQueue :: q -> IO ()
-    writeQueue q = do
-      let rId = recipientId q
-      readTVarIO (queueRec q) >>= \case
-        Just q' -> logCreateQueue s rId q'
-        Nothing -> pure ()
+    writeQueue q = readTVarIO (queueRec q) >>= mapM_ (logCreateQueue s $ recipientId q)
 
-readQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO ()
+readQueueStore :: forall q. StoreQueueClass q => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
 readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
   where
     processLine :: B.ByteString -> IO ()
@@ -53,6 +54,14 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
           DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteStoreQueue st
           DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st
           UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t
+          NewService sr@ServiceRec {serviceId} -> getCreateService @q st sr >>= \case
+            Right serviceId'
+              | serviceId == serviceId' -> pure ()
+              | otherwise -> logError $ errPfx <> "created with the wrong ID " <> decodeLatin1 (strEncode serviceId')
+            Left e -> logError $ errPfx <> tshow e
+            where
+              errPfx = "STORE: getCreateService, stored service " <> decodeLatin1 (strEncode serviceId) <> ", "
+          QueueService rId (ASP party) serviceId -> withQueue rId "QueueService" $ \q -> setQueueService st q party serviceId
         printError :: String -> IO ()
         printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
         withQueue :: forall a. RecipientId -> T.Text -> (q -> IO (Either ErrorType a)) -> IO ()

src/Simplex/Messaging/TMap.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 module Simplex.Messaging.TMap
   ( TMap,
     emptyIO,
@@ -72,11 +74,11 @@ delete k m = modifyTVar' m $ M.delete k
 {-# INLINE delete #-}
 
 lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a)
-lookupInsert k v m = stateTVar m $ \mv -> (M.lookup k mv, M.insert k v mv)
+lookupInsert k v m = stateTVar m $ M.alterF (,Just v) k
 {-# INLINE lookupInsert #-}
 
 lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
-lookupDelete k m = stateTVar m $ \mv -> (M.lookup k mv, M.delete k mv)
+lookupDelete k m = stateTVar m $ M.alterF (,Nothing) k
 {-# INLINE lookupDelete #-}
 
 adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM ()

src/Simplex/Messaging/Transport.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
@@ -35,16 +37,14 @@ module Simplex.Messaging.Transport
     VersionSMP,
     VersionRangeSMP,
     THandleSMP,
-    supportedSMPHandshakes,
+    alpnSupportedSMPHandshakes,
     supportedClientSMPRelayVRange,
     supportedServerSMPRelayVRange,
     supportedProxyClientSMPRelayVRange,
     proxiedSMPRelayVRange,
     minClientSMPRelayVersion,
     minServerSMPRelayVersion,
-    legacyServerSMPRelayVRange,
     currentClientSMPRelayVersion,
-    legacyServerSMPRelayVersion,
     currentServerSMPRelayVersion,
     authCmdsSMPVersion,
     sendingProxySMPVersion,
@@ -53,6 +53,8 @@ module Simplex.Messaging.Transport
     encryptedBlockSMPVersion,
     blockedEntitySMPVersion,
     shortLinksSMPVersion,
+    serviceCertsSMPVersion,
+    newNtfCredsSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -61,12 +63,18 @@ module Simplex.Messaging.Transport
     Transport (..),
     TProxy (..),
     ATransport (..),
+    ASrvTransport,
     TransportPeer (..),
+    STransportPeer (..),
+    TransportPeerI (..),
     getServerVerifyKey,
 
     -- * TLS Transport
     TLS (..),
     SessionId,
+    ServiceId,
+    EntityId (..),
+    pattern NoEntity,
     ALPN,
     connectTLS,
     closeTLS,
@@ -78,6 +86,12 @@ module Simplex.Messaging.Transport
     THandle (..),
     THandleParams (..),
     THandleAuth (..),
+    CertChainPubKey (..),
+    ServiceCredentials (..),
+    THClientService' (..),
+    THClientService,
+    THPeerClientService,
+    SMPServiceRole (..),
     TSbChainKeys (..),
     TransportError (..),
     HandshakeError (..),
@@ -93,20 +107,21 @@ where
 
 import Control.Applicative (optional)
 import Control.Concurrent.STM
-import Control.Monad (forM, when, (<$!>))
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except (throwE)
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (bimap, first)
+import Data.Bifunctor (first)
 import Data.Bitraversable (bimapM)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
+import Data.Kind (Type)
 import Data.Tuple (swap)
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
@@ -120,8 +135,10 @@ import qualified Network.TLS.Extra as TE
 import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
 import Simplex.Messaging.Transport.Buffer
+import Simplex.Messaging.Transport.Shared
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
@@ -149,6 +166,8 @@ smpBlockSize = 16384
 -- 12 - BLOCKED error for blocked queues (1/11/2025)
 -- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
 -- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
+-- 16 - service certificates (5/31/2025)
+-- 17 - create notification credentials with NEW (7/12/2025)
 
 data SMPVersion
 
@@ -188,6 +207,12 @@ proxyServerHandshakeSMPVersion = VersionSMP 14
 shortLinksSMPVersion :: VersionSMP
 shortLinksSMPVersion = VersionSMP 15
 
+serviceCertsSMPVersion :: VersionSMP
+serviceCertsSMPVersion = VersionSMP 16
+
+newNtfCredsSMPVersion :: VersionSMP
+newNtfCredsSMPVersion = VersionSMP 17
+
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 6
 
@@ -195,13 +220,13 @@ minServerSMPRelayVersion :: VersionSMP
 minServerSMPRelayVersion = VersionSMP 6
 
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 15
+currentClientSMPRelayVersion = VersionSMP 17
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 15
+currentServerSMPRelayVersion = VersionSMP 17
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -209,7 +234,7 @@ currentServerSMPRelayVersion = VersionSMP 15
 -- to prevent client version fingerprinting by the
 -- destination relays when clients upgrade at different times.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 15
+proxiedSMPRelayVersion = VersionSMP 16
 
 -- minimal supported protocol version is 6
 -- TODO remove code that supports sending commands without batching
@@ -228,8 +253,8 @@ supportedProxyClientSMPRelayVRange = mkVersionRange minServerSMPRelayVersion cur
 proxiedSMPRelayVRange :: VersionRangeSMP
 proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion
 
-supportedSMPHandshakes :: [ALPN]
-supportedSMPHandshakes = ["smp/1"]
+alpnSupportedSMPHandshakes :: [ALPN]
+alpnSupportedSMPHandshakes = ["smp/1"]
 
 simplexMQVersion :: String
 simplexMQVersion = showVersion SMQ.version
@@ -241,68 +266,84 @@ data TransportConfig = TransportConfig
     transportTimeout :: Maybe Int
   }
 
-class Typeable c => Transport c where
-  transport :: ATransport
-  transport = ATransport (TProxy @c)
+class Typeable c => Transport (c :: TransportPeer -> Type) where
+  transport :: forall p. ATransport p
+  transport = ATransport (TProxy @c @p)
 
-  transportName :: TProxy c -> String
+  transportName :: TProxy c p -> String
 
-  transportPeer :: c -> TransportPeer
+  transportConfig :: c p -> TransportConfig
 
-  transportConfig :: c -> TransportConfig
+  -- | Upgrade TLS context to connection
+  getTransportConnection :: TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (c p)
 
-  -- | Upgrade server TLS context to connection (used in the server)
-  getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
+  -- | Whether TLS certificate chain was provided to peer
+  -- It is always True for the server.
+  -- It is True for the client when server requested it AND non-empty chain is sent.
+  certificateSent :: c p -> Bool
 
-  -- | Upgrade client TLS context to connection (used in the client)
-  getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
-
-  getServerCerts :: c -> X.CertificateChain
+  -- | TLS certificate chain, server's in the client, client's in the server (empty chain for non-service clients)
+  getPeerCertChain :: c p -> X.CertificateChain
 
   -- | tls-unique channel binding per RFC5929
-  tlsUnique :: c -> SessionId
+  tlsUnique :: c p -> SessionId
 
   -- | ALPN value negotiated for the session
-  getSessionALPN :: c -> Maybe ALPN
+  getSessionALPN :: c p -> Maybe ALPN
 
   -- | Close connection
-  closeConnection :: c -> IO ()
+  closeConnection :: c p -> IO ()
 
   -- | Read fixed number of bytes from connection
-  cGet :: c -> Int -> IO ByteString
+  cGet :: c p -> Int -> IO ByteString
 
   -- | Write bytes to connection
-  cPut :: c -> ByteString -> IO ()
+  cPut :: c p -> ByteString -> IO ()
 
   -- | Receive ByteString from connection, allowing LF or CRLF termination.
-  getLn :: c -> IO ByteString
+  getLn :: c p -> IO ByteString
 
   -- | Send ByteString to connection terminating it with CRLF.
-  putLn :: c -> ByteString -> IO ()
+  putLn :: c p -> ByteString -> IO ()
   putLn c = cPut c . (<> "\r\n")
 
 data TransportPeer = TClient | TServer
   deriving (Eq, Show)
 
-data TProxy c = TProxy
+data STransportPeer (p :: TransportPeer) where
+  STClient :: STransportPeer 'TClient
+  STServer :: STransportPeer 'TServer
 
-data ATransport = forall c. Transport c => ATransport (TProxy c)
+class TransportPeerI p where sTransportPeer :: STransportPeer p
 
-getServerVerifyKey :: Transport c => c -> Either String C.APublicVerifyKey
+instance TransportPeerI 'TClient where sTransportPeer = STClient
+
+instance TransportPeerI 'TServer where sTransportPeer = STServer
+
+data TProxy (c :: TransportPeer -> Type) (p :: TransportPeer) = TProxy
+
+data ATransport p = forall c. Transport c => ATransport (TProxy c p)
+
+type ASrvTransport = ATransport 'TServer
+
+getServerVerifyKey :: Transport c => c 'TClient -> Either String C.APublicVerifyKey
 getServerVerifyKey c =
-  case getServerCerts c of
-    X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey
+  case getPeerCertChain c of
+    X.CertificateChain (server : _ca) -> getCertVerifyKey server
     _ -> Left "no certificate chain"
 
+getCertVerifyKey :: X.SignedCertificate -> Either String C.APublicVerifyKey
+getCertVerifyKey cert = C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned cert
+
 -- * TLS Transport
 
-data TLS = TLS
+data TLS (p :: TransportPeer) = TLS
   { tlsContext :: T.Context,
-    tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
     tlsBuffer :: TBuffer,
     tlsALPN :: Maybe ALPN,
-    tlsServerCerts :: X.CertificateChain,
+    tlsCertSent :: Bool, -- see comment for certificateSent
+    tlsPeerCert :: X.CertificateChain,
     tlsTransportConfig :: TransportConfig
   }
 
@@ -317,21 +358,22 @@ connectTLS host_ TransportConfig {logTLSErrors} params sock =
     logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
     host = maybe "" (\h -> " (" <> h <> ")") host_
 
-getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO TLS
-getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
+getTLS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (TLS p)
+getTLS cfg tlsCertSent tlsPeerCert cxt = withTlsUnique @TLS @p cxt newTLS
   where
     newTLS tlsUniq = do
       tlsBuffer <- newTBuffer
       tlsALPN <- T.getNegotiatedProtocol cxt
-      pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
+      pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsCertSent, tlsPeerCert, tlsUniq, tlsBuffer}
 
-withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
-withTlsUnique peer cxt f =
-  cxtFinished peer cxt
+withTlsUnique :: forall c p. TransportPeerI p => T.Context -> (ByteString -> IO (c p)) -> IO (c p)
+withTlsUnique cxt f =
+  cxtFinished cxt
     >>= maybe (closeTLS cxt >> ioe_EOF) f
   where
-    cxtFinished TServer = T.getPeerFinished
-    cxtFinished TClient = T.getFinished
+    cxtFinished = case sTransportPeer @p of
+      STServer -> T.getPeerFinished
+      STClient -> T.getFinished
 
 closeTLS :: T.Context -> IO ()
 closeTLS ctx =
@@ -375,26 +417,33 @@ defaultSupportedParamsHTTPS =
 
 instance Transport TLS where
   transportName _ = "TLS"
-  transportPeer = tlsPeer
+  {-# INLINE transportName #-}
   transportConfig = tlsTransportConfig
-  getServerConnection = getTLS TServer
-  getClientConnection = getTLS TClient
-  getServerCerts = tlsServerCerts
+  {-# INLINE transportConfig #-}
+  getTransportConnection = getTLS
+  {-# INLINE getTransportConnection #-}
+  certificateSent = tlsCertSent
+  {-# INLINE certificateSent #-}
+  getPeerCertChain = tlsPeerCert
+  {-# INLINE getPeerCertChain #-}
   getSessionALPN = tlsALPN
+  {-# INLINE getSessionALPN #-}
   tlsUnique = tlsUniq
+  {-# INLINE tlsUnique #-}
   closeConnection tls = closeTLS $ tlsContext tls
+  {-# INLINE closeConnection #-}
 
   -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
   -- this function may return less than requested number of bytes
-  cGet :: TLS -> Int -> IO ByteString
+  cGet :: TLS p -> Int -> IO ByteString
   cGet TLS {tlsContext, tlsBuffer, tlsTransportConfig = TransportConfig {transportTimeout = t_}} n =
     getBuffered tlsBuffer n t_ (T.recvData tlsContext)
 
-  cPut :: TLS -> ByteString -> IO ()
+  cPut :: TLS p -> ByteString -> IO ()
   cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} =
     withTimedErr t_ . T.sendData tlsContext . LB.fromStrict
 
-  getLn :: TLS -> IO ByteString
+  getLn :: TLS p -> IO ByteString
   getLn TLS {tlsContext, tlsBuffer} = do
     getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
     where
@@ -407,7 +456,7 @@ instance Transport TLS where
 
 -- | The handle for SMP encrypted transport connection over Transport.
 data THandle v c p = THandle
-  { connection :: c,
+  { connection :: c p,
     params :: THandleParams v p
   }
 
@@ -429,22 +478,37 @@ data THandleParams v p = THandleParams
     encryptBlock :: Maybe TSbChainKeys,
     -- | send multiple transmissions in a single block
     -- based on protocol version
-    batch :: Bool
+    batch :: Bool,
+    -- | include service signature (or '0' if it is absent), based on protocol version
+    serviceAuth :: Bool
   }
 
 data THandleAuth (p :: TransportPeer) where
   THAuthClient ::
-    { serverPeerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
-      serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is serverPeerPubKey signed with server certificate
+    { peerServerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
+      peerServerCertKey :: CertChainPubKey, -- the key here is peerServerCertKey signed with server certificate
+      clientService :: Maybe THClientService,
       sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
     } ->
     THandleAuth 'TClient
   THAuthServer ::
     { serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
+      peerClientService :: Maybe THPeerClientService,
       sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
     } ->
     THandleAuth 'TServer
 
+type THClientService = THClientService' C.PrivateKeyEd25519
+
+type THPeerClientService = THClientService' C.PublicKeyEd25519
+
+data THClientService' k = THClientService
+  { serviceId :: ServiceId,
+    serviceRole :: SMPServiceRole,
+    serviceCertHash :: XV.Fingerprint,
+    serviceKey :: k
+  }
+
 data TSbChainKeys = TSbChainKeys
   { sndKey :: TVar C.SbChainKey,
     rcvKey :: TVar C.SbChainKey
@@ -453,59 +517,136 @@ data TSbChainKeys = TSbChainKeys
 -- | TLS-unique channel binding
 type SessionId = ByteString
 
-data ServerHandshake = ServerHandshake
+type ServiceId = EntityId
+
+-- this type is used for server entities only
+newtype EntityId = EntityId {unEntityId :: ByteString}
+  deriving (Eq, Ord, Show)
+  deriving newtype (Encoding, StrEncoding)
+
+pattern NoEntity :: EntityId
+pattern NoEntity = EntityId ""
+
+data SMPServerHandshake = SMPServerHandshake
   { 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)
+    authPubKey :: Maybe CertChainPubKey
   }
 
-data ClientHandshake = ClientHandshake
+-- This is the third handshake message that SMP server sends to services
+-- in response to them sending `clientService` field.
+-- The client would wait for this message in case `clientService` was sent
+-- (and it can only be sent once client knows that service supports it.)
+data SMPServerHandshakeResponse
+  = SMPServerHandshakeResponse {serviceId :: ServiceId}
+  | SMPServerHandshakeError {handshakeError :: TransportError}
+
+data SMPClientHandshake = SMPClientHandshake
   { -- | 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,
+    -- TODO [certs] remove proxyServer, as serviceInfo includes it as clientRole
     -- | 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
+    proxyServer :: Bool,
+    -- | optional long-term service client certificate of a high-volume service using SMP server.
+    -- This certificate MUST be used both in TLS and in protocol handshake.
+    -- It signs the key that is used to authorize:
+    -- - queue creation commands (in addition to authorization by queue key) - it creates association of the queue with this certificate,
+    -- - "handover" subscription command (in addition to queue key) - it also creates association,
+    -- - bulk subscription command CSUB.
+    -- SHA512 hash of this certificate is stored to associate queues with this client.
+    -- These certificates are used by the servers and services connecting to SMP servers:
+    -- - chat relays,
+    -- - notification servers,
+    -- - high traffic chat bots,
+    -- - high traffic business support clients.
+    clientService :: Maybe SMPClientHandshakeService
   }
 
-instance Encoding ClientHandshake where
-  smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
+data SMPClientHandshakeService = SMPClientHandshakeService
+  { serviceRole :: SMPServiceRole,
+    serviceCertKey :: CertChainPubKey
+  }
+
+data ServiceCredentials = ServiceCredentials
+  { serviceRole :: SMPServiceRole,
+    serviceCreds :: T.Credential,
+    serviceCertHash :: XV.Fingerprint,
+    serviceSignKey :: C.APrivateSignKey
+  }
+
+data SMPServiceRole = SRMessaging | SRNotifier | SRProxy deriving (Eq, Show)
+
+instance Encoding SMPClientHandshake where
+  smpEncode SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService} =
     smpEncode (v, keyHash)
       <> encodeAuthEncryptCmds v authPubKey
       <> ifHasProxy v (smpEncode proxyServer) ""
+      <> ifHasService v (smpEncode clientService) ""
   smpP = do
     (v, keyHash) <- smpP
     -- TODO drop SMP v6: remove special parser and make key non-optional
     authPubKey <- authEncryptCmdsP v smpP
     proxyServer <- ifHasProxy v smpP (pure False)
-    pure ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
+    clientService <- ifHasService v smpP (pure Nothing)
+    pure SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService}
+
+instance Encoding SMPClientHandshakeService where
+  smpEncode SMPClientHandshakeService {serviceRole, serviceCertKey} =
+    smpEncode (serviceRole, serviceCertKey)
+  smpP = do
+    (serviceRole, serviceCertKey) <- smpP
+    pure SMPClientHandshakeService {serviceRole, serviceCertKey}
+
+instance Encoding SMPServiceRole where
+  smpEncode = \case
+    SRMessaging -> "M"
+    SRNotifier -> "N"
+    SRProxy -> "P"
+  smpP =
+    A.anyChar >>= \case
+      'M' -> pure SRMessaging
+      'N' -> pure SRNotifier
+      'P' -> pure SRProxy
+      _ -> fail "bad SMPServiceRole"
 
 ifHasProxy :: VersionSMP -> a -> a -> a
 ifHasProxy v a b = if v >= proxyServerHandshakeSMPVersion then a else b
 
-instance Encoding ServerHandshake where
-  smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
+ifHasService :: VersionSMP -> a -> a -> a
+ifHasService v a b = if v >= serviceCertsSMPVersion then a else b
+
+instance Encoding SMPServerHandshake where
+  smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey} =
     smpEncode (smpVersionRange, sessionId) <> auth
     where
-      auth =
-        encodeAuthEncryptCmds (maxVersion smpVersionRange) $
-          bimap C.encodeCertChain C.SignedObject <$> authPubKey
+      auth = encodeAuthEncryptCmds (maxVersion smpVersionRange) authPubKey
   smpP = do
     (smpVersionRange, sessionId) <- smpP
     -- TODO drop SMP v6: remove special parser and make key non-optional
-    authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) authP
-    pure ServerHandshake {smpVersionRange, sessionId, authPubKey}
-    where
-      authP = do
-        cert <- C.certChainP
-        C.SignedObject key <- smpP
-        pure (cert, key)
+    authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) smpP
+    pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey}
+
+-- newtype for CertificateChain and a session key signed with this certificate
+data CertChainPubKey = CertChainPubKey
+  { certChain :: X.CertificateChain,
+    signedPubKey :: X.SignedExact X.PubKey
+  }
+  deriving (Eq, Show)
+
+instance Encoding CertChainPubKey where
+  smpEncode CertChainPubKey {certChain, signedPubKey} = smpEncode (C.encodeCertChain certChain, C.SignedObject signedPubKey)
+  smpP = do
+    certChain <- C.certChainP
+    C.SignedObject signedPubKey <- smpP
+    pure CertChainPubKey {certChain, signedPubKey}
 
 encodeAuthEncryptCmds :: Encoding a => VersionSMP -> Maybe a -> ByteString
 encodeAuthEncryptCmds v k
@@ -515,6 +656,16 @@ encodeAuthEncryptCmds v k
 authEncryptCmdsP :: VersionSMP -> Parser a -> Parser (Maybe a)
 authEncryptCmdsP v p = if v >= authCmdsSMPVersion then optional p else pure Nothing
 
+instance Encoding SMPServerHandshakeResponse where
+  smpEncode = \case
+    SMPServerHandshakeResponse serviceId -> smpEncode ('R', serviceId)
+    SMPServerHandshakeError handshakeError -> smpEncode ('E', handshakeError)
+  smpP =
+    A.anyChar >>= \case
+      'R' -> SMPServerHandshakeResponse <$> smpP
+      'E' -> SMPServerHandshakeError <$> smpP
+      _ -> fail "bad SMPServerHandshakeResponse"
+
 -- | Error of SMP encrypted transport over TCP.
 data TransportError
   = -- | error parsing transport block
@@ -540,6 +691,8 @@ data HandshakeError
     IDENTITY
   | -- | v7 authentication failed
     BAD_AUTH
+  | -- | error reading/creating service record
+    BAD_SERVICE
   deriving (Eq, Read, Show, Exception)
 
 instance Encoding TransportError where
@@ -587,29 +740,53 @@ tGetBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlo
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
-smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
-  let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
-      sk = C.signX509 serverSignKey $ C.publicToX509 k
-      certChain = getServerCerts c
+smpServerHandshake ::
+  forall c. Transport c =>
+  X.CertificateChain ->
+  C.APrivateSignKey ->
+  c 'TServer ->
+  C.KeyPairX25519 ->
+  C.KeyHash ->
+  VersionRangeSMP ->
+  (SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId) ->
+  ExceptT TransportError IO (THandleSMP c 'TServer)
+smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange getService = do
+  let sk = C.signX509 srvSignKey $ C.publicToX509 k
       smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
-  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
-  getHandshake th >>= \case
-    ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
-      | keyHash /= kh ->
-          throwE $ TEHandshake IDENTITY
-      | otherwise ->
-          case compatibleVRange' smpVersionRange v of
-            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k' proxyServer
-            Nothing -> throwE TEVersion
+  sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = Just (CertChainPubKey srvCert sk)}
+  SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer, clientService} <- getHandshake th
+  when (keyHash /= kh) $ throwE $ TEHandshake IDENTITY
+  case compatibleVRange' smpVersionRange v of
+    Just (Compatible vr) -> do
+      service <- mapM getClientService clientService
+      liftIO $ smpTHandleServer th v vr pk k' proxyServer service
+    Nothing -> throwE TEVersion
+  where
+    th@THandle {params = THandleParams {sessionId}} = smpTHandle c
+    getClientService :: SMPClientHandshakeService -> ExceptT TransportError IO THPeerClientService
+    getClientService SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey cc exact} = handleError sendErr $ do
+      unless (getPeerCertChain c == cc) $ throwE $ TEHandshake BAD_AUTH
+      (idCert, serviceKey) <- liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+        (leafCert, idCert) <- case chainIdCaCerts cc of
+          CCSelf cert -> pure (cert, cert)
+          CCValid {leafCert, idCert} -> pure (leafCert, idCert)
+          _ -> throwError "bad certificate"
+        serviceCertKey <- getCertVerifyKey leafCert
+        (idCert,) <$> (C.x509ToPublic' =<< C.verifyX509 serviceCertKey exact)
+      let fp = XV.getFingerprint idCert X.HashSHA256
+      serviceId <- getService serviceRole cc fp
+      sendHandshake th $ SMPServerHandshakeResponse {serviceId}
+      pure THClientService {serviceId, serviceRole, serviceCertHash = fp, serviceKey}
+    sendErr err = do
+      sendHandshake th $ SMPServerHandshakeError {handshakeError = err}
+      throwError err
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
-smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
-  let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
-  ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
+smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleSMP c 'TClient)
+smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_ = do
+  SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
   when (sessionId /= sessId) $ throwE TEBadSession
   -- Below logic downgrades version range in case the "client" is SMP proxy server and it is
   -- connected to the destination server of the version 11 or older.
@@ -630,31 +807,55 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
           else vRange
   case smpVersionRange `compatibleVRange` smpVRange of
     Just (Compatible vr) -> do
-      ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
+      ck_ <- forM authPubKey $ \certKey@(CertChainPubKey chain exact) ->
         liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
-          case cert of
-            [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
+          case chainIdCaCerts chain of
+            CCValid {idCert} | XV.Fingerprint kh == XV.getFingerprint idCert X.HashSHA256 -> pure ()
             _ -> throwError "bad certificate"
           serverKey <- getServerVerifyKey c
-          pubKey <- C.verifyX509 serverKey exact
-          (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
+          (,certKey) <$> (C.x509ToPublic' =<< C.verifyX509 serverKey exact)
       let v = maxVersion vr
-      sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
-      liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer
+          serviceKeys = case serviceKeys_ of
+            Just sks | v >= serviceCertsSMPVersion && certificateSent c -> Just sks
+            _ -> Nothing
+          clientService = mkClientService <$> serviceKeys
+          hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService}
+      sendHandshake th hs
+      service <- mapM getClientService serviceKeys
+      liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer service
     Nothing -> throwE TEVersion
+  where
+    th@THandle {params = THandleParams {sessionId}} = smpTHandle c
+    mkClientService :: (ServiceCredentials, C.KeyPairEd25519) -> SMPClientHandshakeService
+    mkClientService (ServiceCredentials {serviceRole, serviceCreds, serviceSignKey}, (k, _)) =
+      let sk = C.signX509 serviceSignKey $ C.publicToX509 k
+       in SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey (fst serviceCreds) sk}
+    getClientService :: (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO THClientService
+    getClientService (ServiceCredentials {serviceRole, serviceCertHash}, (_, pk)) =
+      getHandshake th >>= \case
+        SMPServerHandshakeResponse {serviceId} -> pure THClientService {serviceId, serviceRole, serviceCertHash, serviceKey = pk}
+        SMPServerHandshakeError {handshakeError} -> throwE handshakeError
 
-smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> IO (THandleSMP c 'TServer)
-smpTHandleServer th v vr pk k_ proxyServer = do
-  let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
+smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer)
+smpTHandleServer th v vr pk k_ proxyServer peerClientService = do
+  let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_}
   be <- blockEncryption th v proxyServer thAuth
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
 
-smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> Bool -> IO (THandleSMP c 'TClient)
-smpTHandleClient th v vr pk_ ck_ proxyServer = do
-  let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
+smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> IO (THandleSMP c 'TClient)
+smpTHandleClient th v vr pk_ ck_ proxyServer clientService = do
+  let thAuth = clientTHParams <$!> ck_
   be <- blockEncryption th v proxyServer thAuth
   -- swap is needed to use client's sndKey as server's rcvKey and vice versa
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
+  where
+    clientTHParams (k, ck) =
+      THAuthClient
+        { peerServerPubKey = k,
+          peerServerCertKey = forceCertChain ck,
+          clientService,
+          sessSecret = C.dh' k <$!> pk_
+        }
 
 blockEncryption :: THandleSMP c p -> VersionSMP -> Bool -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
 blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \case
@@ -669,17 +870,30 @@ blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \ca
 smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
 smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
   -- TODO drop SMP v6: make thAuth non-optional
-  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion, encryptBlock}
+  -- * Note: update version-based parameters in smpTHParamsSetVersion as well.
+  let params' =
+        params
+          { thVersion = v,
+            thServerVRange = vr,
+            thAuth,
+            implySessId = v >= authCmdsSMPVersion,
+            encryptBlock,
+            serviceAuth = v >= serviceCertsSMPVersion -- optional service signature will be encoded for all commands and responses
+          }
    in (th :: THandleSMP c p) {params = params'}
 
+forceCertChain :: CertChainPubKey -> CertChainPubKey
+forceCertChain cert@(CertChainPubKey (X.CertificateChain cc) signedKey) = length (show cc) `seq` show signedKey `seq` cert
 {-# INLINE forceCertChain #-}
-forceCertChain :: (X.CertificateChain, X.SignedExact T.PubKey) -> (X.CertificateChain, X.SignedExact T.PubKey)
-forceCertChain cert@(X.CertificateChain cc, signedKey) = length (show cc) `seq` show signedKey `seq` cert
 
 -- This function is only used with v >= 8, so currently it's a simple record update.
--- It may require some parameters update in the future, to be consistent with smpTHandle_.
+-- * Note: it requires updating version-based parameters, to be consistent with smpTHandle_.
 smpTHParamsSetVersion :: VersionSMP -> THandleParams SMPVersion p -> THandleParams SMPVersion p
-smpTHParamsSetVersion v params = params {thVersion = v}
+smpTHParamsSetVersion v params =
+  params
+    { thVersion = v,
+      serviceAuth = v >= serviceCertsSMPVersion
+    }
 {-# INLINE smpTHParamsSetVersion #-}
 
 sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO ()
@@ -689,7 +903,7 @@ sendHandshake th = ExceptT . tPutBlock th . smpEncode
 getHandshake :: (Transport c, Encoding smp) => THandle v c p -> ExceptT TransportError IO smp
 getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
 
-smpTHandle :: Transport c => c -> THandleSMP c p
+smpTHandle :: Transport c => c p -> THandleSMP c p
 smpTHandle c = THandle {connection = c, params}
   where
     v = VersionSMP 0
@@ -702,7 +916,8 @@ smpTHandle c = THandle {connection = c, params}
           thAuth = Nothing,
           implySessId = False,
           encryptBlock = Nothing,
-          batch = True
+          batch = True,
+          serviceAuth = False
         }
 
 $(J.deriveJSON (sumTypeJSON id) ''HandshakeError)

src/Simplex/Messaging/Transport/Client.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -29,13 +30,15 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Logger.Simple (logError)
-import Control.Monad (when)
+import Control.Monad
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAsciiLower, isDigit, isHexDigit)
 import Data.Default (def)
+import Data.Functor (($>))
+import Data.IORef
 import Data.IP
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
@@ -56,7 +59,8 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util (bshow, catchAll, tshow, (<$?>))
+import Simplex.Messaging.Transport.Shared
+import Simplex.Messaging.Util (bshow, catchAll, catchAll_, tshow, (<$?>))
 import System.IO.Error
 import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
@@ -124,8 +128,8 @@ data TransportClientConfig = TransportClientConfig
     tcpConnectTimeout :: Int,
     tcpKeepAlive :: Maybe KeepAliveOpts,
     logTLSErrors :: Bool,
-    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
-    alpn :: Maybe [ALPN],
+    clientCredentials :: Maybe T.Credential,
+    clientALPN :: Maybe [ALPN],
     useSNI :: Bool
   }
   deriving (Eq, Show)
@@ -135,39 +139,55 @@ defaultTcpConnectTimeout :: Int
 defaultTcpConnectTimeout = 25_000_000
 
 defaultTransportClientConfig :: TransportClientConfig
-defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing True
+defaultTransportClientConfig =
+  TransportClientConfig
+    { socksProxy = Nothing,
+      tcpConnectTimeout = defaultTcpConnectTimeout,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      logTLSErrors = True,
+      clientCredentials = Nothing,
+      clientALPN = Nothing,
+      useSNI = True
+    }
 
 clientTransportConfig :: TransportClientConfig -> TransportConfig
 clientTransportConfig TransportClientConfig {logTLSErrors} =
   TransportConfig {logTLSErrors, transportTimeout = Nothing}
 
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
+runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
 runTransportClient = runTLSTransportClient defaultSupportedParams Nothing
 
-runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
-runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do
+data ConnectionHandle c
+  = CHSocket Socket
+  | CHContext T.Context
+  | CHTransport (c 'TClient)
+
+runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, clientALPN, useSNI} socksCreds host port keyHash client = do
   serverCert <- newEmptyTMVarIO
+  clientCredsSent <- newIORef False
   let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn useSNI serverCert
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials clientCredsSent clientALPN useSNI serverCert
       connectTCP = case socksProxy of
         Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
         _ -> connectTCPClient hostName
-  c <- do
-    sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
+  h <- newIORef Nothing
+  let set hc = (>>= \c -> writeIORef h (Just $ hc c) $> c)
+  E.bracket (set CHSocket $ connectTCP port) (\_ -> closeConn h) $ \sock -> do
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive " <> tshow e)
     let tCfg = clientTransportConfig cfg
     -- No TLS timeout to avoid failing connections via SOCKS
-    tls <- connectTLS (Just hostName) tCfg clientParams sock
-    chain <-
-      atomically (tryTakeTMVar serverCert) >>= \case
-        Nothing -> do
-          logError "onServerCertificate didn't fire or failed to get cert chain"
-          closeTLS tls >> error "onServerCertificate failed"
-        Just c -> pure c
-    getClientConnection tCfg chain tls
-  client c `E.finally` closeConnection c
+    tls <- set CHContext $ connectTLS (Just hostName) tCfg clientParams sock
+    chain <- takePeerCertChain serverCert
+    sent <- readIORef clientCredsSent
+    client =<< set CHTransport (getTransportConnection tCfg sent chain tls)
   where
+    closeConn = readIORef >=> mapM_ (\c -> E.uninterruptibleMask_ $ closeConn_ c `catchAll_` pure ())
+    closeConn_ = \case
+      CHSocket sock -> close sock
+      CHContext tls -> closeTLS tls
+      CHTransport c -> closeConnection c
     hostAddr = \case
       THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
       THIPv6 addr -> SocksAddrIPV6 addr
@@ -191,10 +211,11 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
       E.try (open addr) >>= either (`tryOpen` as) pure
 
     open :: AddrInfo -> IO Socket
-    open addr = do
-      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-      connect sock $ addrAddress addr
-      pure sock
+    open addr =
+      E.bracketOnError
+        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+        close
+        (\sock -> connect sock (addrAddress addr) $> sock)
 
 defaultSMPPort :: PortNumber
 defaultSMPPort = 5223
@@ -264,41 +285,36 @@ instance StrEncoding SocksAuth where
         password <- A.takeTill (== '@') <* A.char '@'
         pure SocksAuthUsername {username, password}
 
-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
-mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ sni serverCerts =
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe T.Credential -> IORef Bool -> Maybe [ALPN] -> Bool -> TMVar (Maybe X.CertificateChain) -> T.ClientParams
+mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ clientCredsSent alpn_ sni serverCerts =
   (T.defaultParamsClient host p)
     { T.clientUseServerNameIndication = sni,
       T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
       T.clientHooks =
         def
           { T.onServerCertificate = onServerCert,
-            T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_,
+            T.onCertificateRequest = onCertRequest,
             T.onSuggestALPN = pure alpn_
           },
       T.clientSupported = supported
     }
   where
     p = B.pack port
-    onServerCert _ _ _ c = do
-      errs <- maybe def (\ca -> validateCertificateChain ca host p c) cafp_
-      when (null errs) $
-        atomically (putTMVar serverCerts c)
+    onServerCert _ _ _ cc = do
+      errs <- maybe def (\ca -> validateCertificateChain ca host p cc) cafp_
+      atomically $ putTMVar serverCerts $ if null errs then Just cc else Nothing
       pure errs
+    onCertRequest = case clientCreds_ of
+      Just _ -> \_ -> clientCreds_ <$ writeIORef clientCredsSent True
+      Nothing -> \_ -> pure Nothing
 
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
-validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
-validateCertificateChain _ _ _ (X.CertificateChain [_]) = pure [XV.EmptyChain]
-validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain [_, caCert]) =
-  if Fingerprint kh == XV.getFingerprint caCert X.HashSHA256
-    then x509validate
-    else pure [XV.UnknownCA]
+validateCertificateChain (C.KeyHash kh) host port cc = case chainIdCaCerts cc of
+  CCEmpty -> pure [XV.EmptyChain]
+  CCSelf _ -> pure [XV.EmptyChain]
+  CCValid {idCert, caCert} -> validate idCert caCert
+  CCLong -> pure [XV.AuthorityTooDeep]
   where
-    x509validate :: IO [XV.FailedReason]
-    x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
-      where
-        hooks = XV.defaultHooks
-        checks = XV.defaultChecks {XV.checkFQHN = False}
-        certStore = XS.makeCertificateStore [caCert]
-        cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
-        serviceID = (host, port)
-validateCertificateChain _ _ _ _ = pure [XV.AuthorityTooDeep]
+    validate idCert caCert
+      | Fingerprint kh == XV.getFingerprint idCert X.HashSHA256 = x509validate caCert (host, port) cc
+      | otherwise = pure [XV.UnknownCA]

src/Simplex/Messaging/Transport/Credentials.hs

@@ -23,15 +23,8 @@ import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import qualified Network.TLS as TLS
 import qualified Simplex.Messaging.Crypto as C
 import qualified Time.System as Hourglass
+import qualified Time.Types as HT
 
--- | Generate a certificate chain to be used with TLS fingerprint-pinning
---
--- @
--- genTlsCredentials = do
---   ca <- genCredentials Nothing (-25, 365 * 24) "Root" -- long-lived root cert
---   leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert
---   pure $ tlsCredentials (leaf :| [ca])
--- @
 tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
 tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
   where
@@ -54,7 +47,9 @@ genCredentials g parent (before, after) subjectName = do
         Nothing -> (subjectKeys, subject) -- self-signed
         Just (keys, cert) -> (keys, X509.certSubjectDN . X509.signedObject $ X509.getSigned cert)
   today <- Hourglass.dateCurrent
-  let signed =
+  -- remove nanoseconds from time - certificate encoding/decoding removes them.
+  let today' = today {HT.dtTime = (HT.dtTime today) {HT.todNSec = 0}}
+      signed =
         C.signCertificate
           (snd issuerKeys)
           X509.Certificate
@@ -62,7 +57,7 @@ genCredentials g parent (before, after) subjectName = do
               certSerial = 1,
               certSignatureAlg = C.signatureAlgorithmX509 issuerKeys,
               certIssuerDN = issuer,
-              certValidity = (timeAdd today (-before), timeAdd today after),
+              certValidity = (timeAdd today' (-before), timeAdd today' after),
               certSubjectDN = subject,
               certPubKey = C.toPubKey C.publicToX509 $ fst subjectKeys,
               certExtensions = X509.Extensions Nothing

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Transport.HTTP2 where
 
@@ -15,17 +16,17 @@ import qualified Network.HTTP2.Server as HS
 import Network.Socket (SockAddr (..))
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
+import Simplex.Messaging.Transport (ALPN, TLS, Transport (cGet, cPut))
 import Simplex.Messaging.Transport.Buffer
 import qualified System.TimeManager as TI
 
 defaultHTTP2BufferSize :: BufferSize
 defaultHTTP2BufferSize = 32768
 
-withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS -> IO a
+withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS p -> IO a
 withHTTP2 sz run fin c = E.bracket (allocHTTP2Config c sz) (\cfg -> freeSimpleConfig cfg `E.finally` fin) run
 
-allocHTTP2Config :: TLS -> BufferSize -> IO Config
+allocHTTP2Config :: TLS p -> BufferSize -> IO Config
 allocHTTP2Config c sz = do
   buf <- mallocBytes sz
   tm <- TI.initialize $ 30 * 1000000
@@ -81,3 +82,9 @@ getHTTP2Body r n = do
       -- TODO check bodySize once it is set
       bodyPart = if B.length bodyHead == n then Just getPart else Nothing
   pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}
+
+httpALPN :: [ALPN]
+httpALPN = ["h2", "http/1.1"]
+
+httpALPN11 :: ALPN
+httpALPN11 = "http/1.1"

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

@@ -1,9 +1,12 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Transport.HTTP2.Client where
 
@@ -24,7 +27,8 @@ import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
+import Simplex.Messaging.Protocol (NetworkError (..), toNetworkError)
+import Simplex.Messaging.Transport (ALPN, STransportPeer (..), SessionId, TLS (tlsALPN, tlsPeerCert, tlsUniq), TransportPeer (..), TransportPeerI (..), getServerVerifyKey)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Util (eitherToMaybe)
@@ -78,7 +82,7 @@ defaultHTTP2ClientConfig =
             tcpKeepAlive = Nothing,
             logTLSErrors = True,
             clientCredentials = Nothing,
-            alpn = Nothing,
+            clientALPN = Nothing,
             useSNI = False
           },
       bufferSize = defaultHTTP2BufferSize,
@@ -86,7 +90,7 @@ defaultHTTP2ClientConfig =
       suportedTLSParams = http2TLSParams
     }
 
-data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOException
+data HTTP2ClientError = HCResponseTimeout | HCNetworkError NetworkError | HCIOError IOException
   deriving (Show)
 
 getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
@@ -97,13 +101,14 @@ getVerifiedHTTP2Client socksCreds host port keyHash caStore config disconnected
   where
     setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) socksCreds host port keyHash
 
-attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
+-- HTTP2 client can be run on both client and server TLS connections.
+attachHTTP2Client :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS p -> IO (Either HTTP2ClientError HTTP2Client)
 attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
   where
-    setup :: (TLS -> H.Client HTTP2Response) -> IO HTTP2Response
+    setup :: (TLS p -> H.Client HTTP2Response) -> IO HTTP2Response
     setup = runHTTP2ClientWith bufferSize host ($ tls)
 
-getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
+getVerifiedHTTP2ClientWith :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS p -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
 getVerifiedHTTP2ClientWith config host port disconnected setup =
   (mkHTTPS2Client >>= runClient)
     `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
@@ -117,22 +122,27 @@ getVerifiedHTTP2ClientWith config host port disconnected setup =
     runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
       cVar <- newEmptyTMVarIO
-      action <- async $ setup (client c cVar) `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
+      action <-
+        async $ setup (client c cVar) `E.catch` \e -> do
+          atomically $ putTMVar cVar $ Left $ HCNetworkError $ toNetworkError e
+          E.throwIO e
       c_ <- connTimeout config `timeout` atomically (takeTMVar cVar)
       case c_ of
         Just (Right c') -> pure $ Right c' {action = Just action}
         Just (Left e) -> pure $ Left e
-        Nothing -> cancel action $> Left HCNetworkError
+        Nothing -> cancel action $> Left (HCNetworkError NETimeoutError)
 
-    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS -> H.Client HTTP2Response
+    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS p -> H.Client HTTP2Response
     client c cVar tls sendReq = do
       sessionTs <- getCurrentTime
       let c' =
             HTTP2Client
               { action = Nothing,
                 client_ = c,
-                serverKey = eitherToMaybe $ getServerVerifyKey tls,
-                serverCerts = getServerCerts tls,
+                serverKey = case sTransportPeer @p of
+                  STClient -> eitherToMaybe $ getServerVerifyKey tls
+                  STServer -> Nothing,
+                serverCerts = tlsPeerCert tls,
                 sendReq,
                 sessionTs,
                 sessionId = tlsUniq tls,
@@ -170,7 +180,7 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
   reqTimeout `timeout` try (sendReq req process) >>= \case
     Just (Right r) -> pure $ Right r
     Just (Left e) -> disconnected $> Left (HCIOError e)
-    Nothing -> pure $ Left HCNetworkError
+    Nothing -> pure $ Left HCResponseTimeout
   where
     process r = do
       respBody <- getHTTP2Body r $ bodyHeadSize config
@@ -179,14 +189,15 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
 http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
 http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
 
-runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
+runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS 'TClient -> H.Client a) -> IO a
 runHTTP2Client tlsParams caStore tcConfig bufferSize socksCreds host port keyHash = runHTTP2ClientWith bufferSize host setup
   where
-    setup :: (TLS -> IO a) -> IO a
+    setup :: (TLS 'TClient -> IO a) -> IO a
     setup = runTLSTransportClient tlsParams caStore tcConfig socksCreds host port keyHash
 
-runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a
+-- HTTP2 client can be run on both client and server TLS connections.
+runHTTP2ClientWith :: forall a p. BufferSize -> TransportHost -> ((TLS p -> IO a) -> IO a) -> (TLS p -> H.Client a) -> IO a
 runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls
   where
-    run :: TLS -> H.Config -> IO a
+    run :: TLS p -> H.Config -> IO a
     run tls cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client tls

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Transport.HTTP2.Server where
@@ -47,13 +48,13 @@ data HTTP2Server = HTTP2Server
   }
 
 -- This server is for testing only, it processes all requests in a single queue.
-getHTTP2Server :: HTTP2ServerConfig -> Maybe [ALPN] -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} alpn_ = do
+getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} = do
   srvCreds <- loadServerCredential https2Credentials
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize serverSupported srvCreds alpn_ transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize serverSupported srvCreds transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -62,15 +63,16 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize srvSupported srvCreds alpn_ transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize srvSupported srvCreds transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
   where
-    setup = runTransportServer started port srvSupported srvCreds alpn_ transportConfig
+    setup = runTransportServer started port srvSupported srvCreds transportConfig
 
-runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
+-- HTTP2 server can be run on both client and server TLS connections.
+runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
 runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ())
 
-runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
+runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
 runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \tls -> do
   activeAt <- newTVarIO =<< getSystemTime
   tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_

src/Simplex/Messaging/Transport/Server.hs

@@ -1,14 +1,18 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Transport.Server
   ( TransportServerConfig (..),
     ServerCredentials (..),
+    TLSServerCredential (..),
     AddHTTP,
-    defaultTransportServerConfig,
+    mkTransportServerConfig,
     runTransportServerState,
     runTransportServerState_,
     SocketState,
@@ -18,11 +22,8 @@ module Simplex.Messaging.Transport.Server
     runTransportServer,
     runTransportServerSocket,
     runLocalTCPServer,
-    runTCPServerSocket,
     startTCPServer,
     loadServerCredential,
-    supportedTLSServerParams,
-    supportedTLSServerParams_,
     loadFingerprint,
     loadFileFingerprint,
     smpServerHandshake,
@@ -33,6 +34,7 @@ import Control.Applicative ((<|>))
 import Control.Logger.Simple
 import Control.Monad
 import qualified Crypto.Store.X509 as SX
+import qualified Data.ByteString as B
 import Data.Default (def)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
@@ -46,7 +48,8 @@ import GHC.IO.Exception (ioe_errno)
 import Network.Socket
 import qualified Network.TLS as T
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
+import Simplex.Messaging.Transport.Shared
+import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow, unlessM)
 import System.Exit (exitFailure)
 import System.IO.Error (tryIOError)
 import System.Mem.Weak (Weak, deRefWeak)
@@ -57,6 +60,8 @@ import UnliftIO.STM
 
 data TransportServerConfig = TransportServerConfig
   { logTLSErrors :: Bool,
+    serverALPN :: Maybe [ALPN],
+    askClientCert :: Bool,
     tlsSetupTimeout :: Int,
     transportTimeout :: Int
   }
@@ -71,10 +76,21 @@ data ServerCredentials = ServerCredentials
 
 type AddHTTP = Bool
 
-defaultTransportServerConfig :: TransportServerConfig
-defaultTransportServerConfig =
+data TLSServerCredential = TLSServerCredential
+  { credential :: T.Credential,
+    -- `sniCredential` is used when SNI is sent by the client.
+    --  It is needed to provide different credential when the server is accessed from the browser.
+    sniCredential :: Maybe T.Credential
+  }
+
+type SNICredentialUsed = Bool
+
+mkTransportServerConfig :: Bool -> Maybe [ALPN] -> Bool -> TransportServerConfig
+mkTransportServerConfig logTLSErrors serverALPN askClientCert =
   TransportServerConfig
-    { logTLSErrors = True,
+    { logTLSErrors,
+      serverALPN,
+      askClientCert,
       tlsSetupTimeout = 60000000,
       transportTimeout = 40000000
     }
@@ -87,41 +103,62 @@ serverTransportConfig TransportServerConfig {logTLSErrors} =
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
-runTransportServer started port srvSupported srvCreds alpn_ cfg server = do
+runTransportServer :: Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
+runTransportServer started port srvSupported srvCreds cfg server = do
   ss <- newSocketState
-  runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server
+  runTransportServerState ss started port srvSupported srvCreds cfg server
 
-runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
-runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) alpn_ cfg (const server)
-
-runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c -> IO ()) -> IO ()
-runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
-
--- | Run a transport server with provided connection setup and handler.
-runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
-runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg server = do
-  ss <- newSocketState
-  runTransportServerSocketState_ ss started getSocket threadLabel (const srvCreds) srvParams cfg (const server)
-
-runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
-runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ =
-  runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams
+runTransportServerState :: Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
+runTransportServerState ss started port srvSupported credential cfg server = runTransportServerState_ ss started port srvSupported srvCreds cfg (\_ -> server . snd)
   where
-    srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_
+    srvCreds = TLSServerCredential {credential, sniCredential = Nothing}
+
+runTransportServerState_ :: forall c. Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> TLSServerCredential -> TransportServerConfig -> (Socket -> (SNICredentialUsed, c 'TServer) -> IO ()) -> IO ()
+runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c 'TServer))
 
 -- | Run a transport server with provided connection setup and handler.
-runTransportServerSocketState_ :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
-runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do
-  labelMyThread $ "transport server for " <> threadLabel
-  runTCPServerSocket ss started getSocket $ \conn ->
-    E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection (server conn)
+runTransportServerSocket :: Transport c => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
+runTransportServerSocket started getSocket threadLabel srvParams cfg server = do
+  ss <- newSocketState
+  runTransportServerSocketState_ ss started getSocket threadLabel (tlsSetupTimeout cfg) setupTLS (\_ -> server . snd)
   where
     tCfg = serverTransportConfig cfg
-    setup conn = timeout (tlsSetupTimeout cfg) $ do
-      labelMyThread $ threadLabel <> "/setup"
+    setupTLS conn = do
       tls <- connectTLS Nothing tCfg srvParams conn
-      getServerConnection tCfg (fst $ srvCreds Nothing) tls
+      (False,) <$> getTransportConnection tCfg True (X.CertificateChain []) tls
+
+runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> TLSServerCredential -> TransportServerConfig -> (Socket -> (SNICredentialUsed, c 'TServer) -> IO ()) -> IO ()
+runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds cfg server =
+  runTransportServerSocketState_ ss started getSocket threadLabel (tlsSetupTimeout cfg) setupTLS server
+  where
+    tCfg = serverTransportConfig cfg
+    setupTLS conn = do
+      sniUsed <- newTVarIO False
+      let srvParams = supportedTLSServerParams srvSupported srvCreds sniUsed $ serverALPN cfg
+      h <- setupTLS_ srvParams
+      sni <- readTVarIO sniUsed
+      pure (sni, h)
+      where
+        setupTLS_ srvParams
+          | askClientCert cfg = do
+              clientCert <- newEmptyTMVarIO
+              tls <- connectTLS Nothing tCfg (paramsAskClientCert clientCert srvParams) conn
+              chain <- takePeerCertChain clientCert `E.onException` closeTLS tls
+              getTransportConnection tCfg True chain tls
+          | otherwise = do
+              tls <- connectTLS Nothing tCfg srvParams conn
+              getTransportConnection tCfg True (X.CertificateChain []) tls
+
+-- | Run a transport server with provided connection setup and handler.
+runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> Int -> (Socket -> IO (SNICredentialUsed, c 'TServer)) -> (Socket -> (SNICredentialUsed, c 'TServer) -> IO ()) -> IO ()
+runTransportServerSocketState_ ss started getSocket threadLabel tlsSetupTimeout setupTLS server = do
+  labelMyThread $ "transport server for " <> threadLabel
+  runTCPServerSocket ss started getSocket $ \conn -> do
+    labelMyThread $ threadLabel <> "/setup"
+    E.bracket
+      (timeout tlsSetupTimeout (setupTLS conn) >>= maybe (fail "tls setup timeout") pure)
+      (closeConnection . snd)
+      (server conn)
 
 -- | Run TCP server without TLS
 runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
@@ -135,12 +172,13 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve
   E.bracket getSocket (closeServer started clients) $ \sock ->
     forever . E.bracketOnError (safeAccept sock) (close . fst) $ \(conn, _peer) -> do
       cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId' `seq` (cId', cId')
+      closed <- newTVarIO False
       let closeConn _ = do
-            atomically $ modifyTVar' clients $ IM.delete cId
+            atomically $ writeTVar closed True >> modifyTVar' clients (IM.delete cId)
             gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
             atomically $ modifyTVar' gracefullyClosed (+ 1)
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
-      atomically $ modifyTVar' clients $ IM.insert cId tId
+      atomically $ unlessM (readTVar closed) $ modifyTVar' clients $ IM.insert cId tId
 
 -- | Recover from errors in `accept` whenever it is safe.
 -- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop.
@@ -202,7 +240,7 @@ startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStart
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       setSocketOption sock ReuseAddr 1
       withFdSocket sock setCloseOnExecIfNeeded
-      logInfo $ "binding to " <> tshow (addrAddress addr)
+      logNote $ "binding to " <> tshow (addrAddress addr)
       bind sock $ addrAddress addr
       listen sock 1024
       pure sock
@@ -214,21 +252,50 @@ loadServerCredential ServerCredentials {caCertificateFile, certificateFile, priv
     Right credential -> pure credential
     Left _ -> putStrLn "invalid credential" >> exitFailure
 
-supportedTLSServerParams :: T.Credential -> Maybe [ALPN] -> T.ServerParams
-supportedTLSServerParams = supportedTLSServerParams_ defaultSupportedParams . const
-
-supportedTLSServerParams_ :: T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> T.ServerParams
-supportedTLSServerParams_ serverSupported creds alpn_ =
+supportedTLSServerParams :: T.Supported -> TLSServerCredential -> TVar SNICredentialUsed -> Maybe [ALPN] -> T.ServerParams
+supportedTLSServerParams serverSupported TLSServerCredential {credential, sniCredential} sniCredUsed alpn_ =
   def
     { T.serverWantClientCert = False,
       T.serverHooks =
         def
-          { T.onServerNameIndication = \host_ -> pure $ T.Credentials [creds host_],
+          { T.onServerNameIndication = case sniCredential of
+              Nothing -> \_ -> pure $ T.Credentials [credential]
+              Just sniCred -> \case
+                Nothing -> pure $ T.Credentials [credential]
+                Just _host -> T.Credentials [sniCred] <$ atomically (writeTVar sniCredUsed True),
             T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_
           },
       T.serverSupported = serverSupported
     }
 
+paramsAskClientCert :: TMVar (Maybe X.CertificateChain) -> T.ServerParams -> T.ServerParams
+paramsAskClientCert clientCert params =
+  params
+    { T.serverWantClientCert = True,
+      T.serverHooks =
+        (T.serverHooks params)
+          { T.onClientCertificate = \cc -> validateClientCertificate cc >>= \case
+              Just reason -> T.CertificateUsageReject reason <$ atomically (tryPutTMVar clientCert Nothing)
+              Nothing -> T.CertificateUsageAccept <$ atomically (tryPutTMVar clientCert $ Just cc)
+          }
+    }
+
+validateClientCertificate :: X.CertificateChain -> IO (Maybe T.CertificateRejectReason)
+validateClientCertificate cc = case chainIdCaCerts cc of
+  CCEmpty -> pure Nothing -- client certificates are only used for services
+  CCSelf cert -> validate cert
+  CCValid {caCert} -> validate caCert
+  CCLong -> pure $ Just $ T.CertificateRejectOther "chain too long"
+  where
+    validate caCert = usage <$> x509validate caCert ("", B.empty) cc
+    usage [] = Nothing
+    usage r =
+      Just $
+        if
+          | XV.Expired `elem` r || XV.InFuture `elem` r -> T.CertificateRejectExpired
+          | XV.UnknownCA `elem` r -> T.CertificateRejectUnknownCA
+          | otherwise -> T.CertificateRejectOther (show r)
+
 loadFingerprint :: ServerCredentials -> IO Fingerprint
 loadFingerprint ServerCredentials {caCertificateFile} = case caCertificateFile of
   Just certificateFile -> loadFileFingerprint certificateFile

src/Simplex/Messaging/Transport/Shared.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Transport.Shared where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Logger.Simple (logError)
+import Data.ByteString (ByteString)
+import qualified Data.X509 as X
+import qualified Data.X509.CertificateStore as XS
+import qualified Data.X509.Validation as XV
+import Network.Socket (HostName)
+
+data ChainCertificates
+  = CCEmpty
+  | CCSelf X.SignedCertificate
+  | CCValid {leafCert :: X.SignedCertificate, idCert :: X.SignedCertificate, caCert :: X.SignedCertificate}
+  | CCLong
+
+chainIdCaCerts :: X.CertificateChain -> ChainCertificates
+chainIdCaCerts (X.CertificateChain chain) = case chain of
+  [] -> CCEmpty
+  [cert] -> CCSelf cert
+  [leafCert, cert] -> CCValid {leafCert, idCert = cert, caCert = cert} -- current long-term online/offline certificates chain
+  [leafCert, idCert, caCert] -> CCValid {leafCert, idCert, caCert} -- with additional operator certificate (preset in the client)
+  [leafCert, idCert, _, caCert] -> CCValid {leafCert, idCert, caCert} -- with network certificate
+  _ -> CCLong
+
+x509validate :: X.SignedCertificate -> (HostName, ByteString) -> X.CertificateChain -> IO [XV.FailedReason]
+x509validate caCert serviceID = XV.validate X.HashSHA256 XV.defaultHooks checks certStore noCache serviceID
+  where
+    checks = XV.defaultChecks {XV.checkFQHN = False}
+    certStore = XS.makeCertificateStore [caCert]
+    noCache = XV.ValidationCache (\_ _ _ -> pure XV.ValidationCacheUnknown) (\_ _ _ -> pure ())
+
+takePeerCertChain :: TMVar (Maybe X.CertificateChain) -> IO (X.CertificateChain)
+takePeerCertChain peerCert =
+  atomically (tryTakeTMVar peerCert) >>= \case
+    Just (Just cc) -> pure cc
+    Just Nothing -> logError "peer certificate invalid" >> E.throwIO (userError "peer certificate invalid")
+    Nothing -> logError "certificate hook not called" >> E.throwIO (userError "certificate hook not called") -- onServerCertificate / onClientCertificate

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -1,6 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Transport.WebSockets (WS (..)) where
 
@@ -15,11 +20,12 @@ import Network.WebSockets.Stream (Stream)
 import qualified Network.WebSockets.Stream as S
 import Simplex.Messaging.Transport
   ( ALPN,
-    TProxy,
     Transport (..),
     TransportConfig (..),
     TransportError (..),
     TransportPeer (..),
+    STransportPeer (..),
+    TransportPeerI (..),
     closeTLS,
     smpBlockSize,
     withTlsUnique,
@@ -27,14 +33,14 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import System.IO.Error (isEOFError)
 
-data WS = WS
-  { wsPeer :: TransportPeer,
-    tlsUniq :: ByteString,
+data WS (p :: TransportPeer) = WS
+  { tlsUniq :: ByteString,
     wsALPN :: Maybe ALPN,
     wsStream :: Stream,
     wsConnection :: Connection,
     wsTransportConfig :: TransportConfig,
-    wsServerCerts :: X.CertificateChain
+    wsCertSent :: Bool,
+    wsPeerCert :: X.CertificateChain
   }
 
 websocketsOpts :: ConnectionOptions
@@ -46,61 +52,52 @@ websocketsOpts =
     }
 
 instance Transport WS where
-  transportName :: TProxy WS -> String
   transportName _ = "WebSockets"
-
-  transportPeer :: WS -> TransportPeer
-  transportPeer = wsPeer
-
-  transportConfig :: WS -> TransportConfig
+  {-# INLINE transportName #-}
   transportConfig = wsTransportConfig
-
-  getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
-  getServerConnection = getWS TServer
-
-  getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
-  getClientConnection = getWS TClient
-
-  getServerCerts :: WS -> X.CertificateChain
-  getServerCerts = wsServerCerts
-
-  getSessionALPN :: WS -> Maybe ALPN
+  {-# INLINE transportConfig #-}
+  getTransportConnection = getWS
+  {-# INLINE getTransportConnection #-}
+  certificateSent = wsCertSent
+  {-# INLINE certificateSent #-}
+  getPeerCertChain = wsPeerCert
+  {-# INLINE getPeerCertChain #-}
   getSessionALPN = wsALPN
-
-  tlsUnique :: WS -> ByteString
+  {-# INLINE getSessionALPN #-}
   tlsUnique = tlsUniq
-
-  closeConnection :: WS -> IO ()
+  {-# INLINE tlsUnique #-}
   closeConnection = S.close . wsStream
+  {-# INLINE closeConnection #-}
 
-  cGet :: WS -> Int -> IO ByteString
+  cGet :: WS p -> Int -> IO ByteString
   cGet c n = do
     s <- receiveData (wsConnection c)
     if B.length s == n
       then pure s
       else E.throwIO TEBadBlock
 
-  cPut :: WS -> ByteString -> IO ()
+  cPut :: WS p -> ByteString -> IO ()
   cPut = sendBinaryData . wsConnection
 
-  getLn :: WS -> IO ByteString
+  getLn :: WS p -> IO ByteString
   getLn c = do
     s <- trimCR <$> receiveData (wsConnection c)
     if B.null s || B.last s /= '\n'
       then E.throwIO TEBadBlock
       else pure $ B.init s
 
-getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS
-getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
+getWS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (WS p)
+getWS cfg wsCertSent wsPeerCert cxt = withTlsUnique @WS @p cxt connectWS
   where
     connectWS tlsUniq = do
       s <- makeTLSContextStream cxt
-      wsConnection <- connectPeer wsPeer s
+      wsConnection <- connectPeer s
       wsALPN <- T.getNegotiatedProtocol cxt
-      pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
-    connectPeer :: TransportPeer -> Stream -> IO Connection
-    connectPeer TServer = acceptClientRequest
-    connectPeer TClient = sendClientRequest
+      pure $ WS {tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsCertSent, wsPeerCert}
+    connectPeer :: Stream -> IO Connection
+    connectPeer = case sTransportPeer @p of
+      STServer -> acceptClientRequest
+      STClient -> sendClientRequest
     acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
     sendClientRequest s = newClientConnection s "" "/" websocketsOpts []
 

src/Simplex/Messaging/Util.hs

@@ -171,28 +171,30 @@ catchAll_ :: IO a -> IO a -> IO a
 catchAll_ a = catchAll a . const
 {-# INLINE catchAll_ #-}
 
-tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a)
-tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err)
+class Show e => AnyError e where fromSomeException :: E.SomeException -> e
+
+tryAllErrors :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> ExceptT e m (Either e a)
+tryAllErrors action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . fromSomeException)
 {-# INLINE tryAllErrors #-}
 
-tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a)
-tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err)
+tryAllErrors' :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> m (Either e a)
+tryAllErrors' action = runExceptT action `UE.catch` (pure . Left . fromSomeException)
 {-# INLINE tryAllErrors' #-}
 
-catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
-catchAllErrors err action handler = tryAllErrors err action >>= either handler pure
+catchAllErrors :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
+catchAllErrors action handler = tryAllErrors action >>= either handler pure
 {-# INLINE catchAllErrors #-}
 
-catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> m a) -> m a
-catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure
+catchAllErrors' :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> (e -> m a) -> m a
+catchAllErrors' action handler = tryAllErrors' action >>= either handler pure
 {-# INLINE catchAllErrors' #-}
 
-catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a
-catchThrow action err = catchAllErrors err action throwE
+catchThrow :: MonadUnliftIO m => ExceptT e m a -> (SomeException -> e) -> ExceptT e m a
+action `catchThrow` err = ExceptT $ runExceptT action `UE.catch` (pure . Left . err)
 {-# INLINE catchThrow #-}
 
-allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a
-allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwE pure r
+allFinally :: (AnyError e, MonadUnliftIO m) => ExceptT e m a -> ExceptT e m b -> ExceptT e m a
+allFinally action final = tryAllErrors action >>= \r -> final >> except r
 {-# INLINE allFinally #-}
 
 eitherToMaybe :: Either a b -> Maybe b
@@ -224,6 +226,7 @@ groupOn = groupBy . eqOn
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f
 
+-- n must be > 0
 toChunks :: Int -> [a] -> [NonEmpty a]
 toChunks _ [] = []
 toChunks n xs =
@@ -264,9 +267,11 @@ atomicModifyIORef'_ r f = atomicModifyIORef' r (\v -> (f v, ()))
 
 encodeJSON :: ToJSON a => a -> Text
 encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
+{-# INLINE encodeJSON #-}
 
 decodeJSON :: FromJSON a => Text -> Maybe a
-decodeJSON = J.decode . LB.fromStrict . encodeUtf8
+decodeJSON = J.decodeStrict . encodeUtf8
+{-# INLINE decodeJSON #-}
 
 traverseWithKey_ :: Monad m => (k -> v -> m ()) -> Map k v -> m ()
 traverseWithKey_ f = M.foldrWithKey (\k v -> (f k v >>)) (pure ())

src/Simplex/RemoteControl/Client.hs

@@ -49,7 +49,7 @@ import qualified Data.Text as T
 import Data.Time.Clock.System (getSystemTime)
 import Data.Tuple (swap)
 import Data.Word (Word16)
-import qualified Data.X509 as X509
+import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import Network.Socket (PortNumber, SockAddr (..), hostAddressToTuple)
 import qualified Network.TLS as TLS
@@ -62,7 +62,7 @@ import Simplex.Messaging.Crypto.SNTRUP761
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), cGet, cPut)
+import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), TransportPeer (..), cGet, cPut)
 import Simplex.Messaging.Transport.Buffer (peekBuffered)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -85,7 +85,7 @@ encInvitationSize = 900
 
 newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
 newRCHostPairing drg = do
-  ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca"
+  ((_, caKey), caCert) <- genCredentials drg Nothing (25, 24 * 999999) "ca"
   (_, idPrivKey) <- atomically $ C.generateKeyPair drg
   pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
 
@@ -101,7 +101,7 @@ data RCHClient_ = RCHClient_
     endSession :: TMVar ()
   }
 
-type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
+type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
 
 connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection
 connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast rcAddrPrefs_ port_ = do
@@ -131,7 +131,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
       endSession <- newEmptyTMVarIO
       hostCAHash <- newEmptyTMVarIO
       pure RCHClient_ {startedPort, announcer, hostCAHash, endSession}
-    runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
+    runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
     runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do
       tlsCreds <- genTLSCredentials drg caKey caCert
       startTLSServer port_ startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls ->
@@ -157,7 +157,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
     tlsHooks r knownHost_ hostCAHash =
       def
         { TLS.onNewHandshake = \_ -> atomically $ isNothing <$> tryReadTMVar r,
-          TLS.onClientCertificate = \(X509.CertificateChain chain) ->
+          TLS.onClientCertificate = \(X.CertificateChain chain) ->
             case chain of
               [_leaf, ca] -> do
                 let kh = certFingerprint ca
@@ -190,16 +190,16 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
               }
       pure $ signInvitation (snd sessKeys) idPrivKey inv
 
-genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credential
+genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> X.SignedCertificate -> IO TLS.Credential
 genTLSCredentials drg caKey caCert = do
   let caCreds = (C.signatureKeyPair caKey, caCert)
-  leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
+  leaf <- genCredentials drg (Just caCreds) (1, 24 * 999999) "localhost" -- session-signing cert
   pure . snd $ tlsCredentials (leaf :| [caCreds])
 
-certFingerprint :: X509.SignedCertificate -> C.KeyHash
+certFingerprint :: X.SignedCertificate -> C.KeyHash
 certFingerprint caCert = C.KeyHash fp
   where
-    Fingerprint fp = getFingerprint caCert X509.HashSHA256
+    Fingerprint fp = getFingerprint caCert X.HashSHA256
 
 cancelHostClient :: RCHostClient -> IO ()
 cancelHostClient RCHostClient {action, client_ = RCHClient_ {announcer, endSession}} = do
@@ -249,7 +249,7 @@ data RCCClient_ = RCCClient_
     endSession :: TMVar ()
   }
 
-type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
+type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
 
 -- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
 connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
@@ -259,7 +259,7 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h
   where
     newCtrlPairing :: IO RCCtrlPairing
     newCtrlPairing = do
-      ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca"
+      ((_, caKey), caCert) <- genCredentials drg Nothing (1, 24 * 999999) "ca"
       (_, dhPrivKey) <- atomically $ C.generateKeyPair drg
       pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing}
     updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
@@ -280,7 +280,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
       confirmSession <- newEmptyTMVarIO
       endSession <- newEmptyTMVarIO
       pure RCCClient_ {confirmSession, endSession}
-    runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
+    runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
     runClient RCCClient_ {confirmSession, endSession} r = do
       clientCredentials <- liftIO $ Just <$> genTLSCredentials drg caKey caCert
       let clientConfig = defaultTransportClientConfig {clientCredentials}
@@ -306,21 +306,15 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
             atomically $ takeTMVar endSession
             logDebug "Session ended"
 
-catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a
-catchRCError = catchAllErrors $ \e -> case fromException e of
-  Just (TLS.Terminated _ _ (TLS.Error_Protocol _ TLS.UnknownCa)) -> RCEIdentity
-  _ -> RCEException $ show e
-{-# INLINE catchRCError #-}
-
 putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
-a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
+a `putRCError` r = a `catchAllErrors` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
 
-sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO ()
+sendRCPacket :: Encoding a => TLS p -> a -> ExceptT RCErrorType IO ()
 sendRCPacket tls pkt = do
   b <- liftEitherWith (const RCEBlockSize) $ C.pad (smpEncode pkt) xrcpBlockSize
   liftIO $ cPut tls b
 
-receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a
+receiveRCPacket :: Encoding a => TLS p -> ExceptT RCErrorType IO a
 receiveRCPacket tls = do
   b <- liftIO $ cGet tls xrcpBlockSize
   when (B.length b /= xrcpBlockSize) $ throwE RCEBlockSize
@@ -395,7 +389,7 @@ discoverRCCtrl subscribers pairings =
       pure r
   where
     loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
-    loop action = action `catchRCError` \e -> logError (tshow e) >> loop action
+    loop action = action `catchAllErrors` \e -> logError (tshow e) >> loop action
 
 findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do