6.4.0.10.1

* time buckets

* split max time metric

* histogram

* histogram for confirmed delivery times

* gaugehistogram

* fix created, _ in gauge_histogram

* remove comments

* fix metrics

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

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.

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.4.0.4
+version:        6.4.0.10.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
@@ -308,6 +310,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.*
@@ -519,6 +522,7 @@ test-suite simplexmq-test
     , generic-random ==1.5.*
     , hashable
     , hspec ==2.11.*
+    , hspec-core ==2.11.*
     , http-client
     , http-types
     , http2

src/Simplex/FileTransfer/Client.hs

@@ -56,8 +56,8 @@ import Simplex.Messaging.Protocol
     SenderId,
     pattern NoEntity,
   )
-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,7 +99,7 @@ defaultXFTPClientConfig =
   XFTPClientConfig
     { xftpNetworkConfig = defaultNetworkConfig,
       serverVRange = supportedFileServerVRange,
-      clientALPN = Just supportedXFTPhandshakes
+      clientALPN = Just alpnSupportedXFTPhandshakes
     }
 
 getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
@@ -107,7 +107,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
+  let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -116,7 +116,7 @@ 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
@@ -132,7 +132,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 +148,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
@@ -203,7 +204,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

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)
@@ -53,7 +53,7 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
+import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
@@ -61,7 +61,7 @@ import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatu
 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)
@@ -92,17 +92,17 @@ 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
@@ -110,17 +110,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     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
@@ -142,7 +142,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (B.null bodyHead) $ throwE HANDSHAKE
           (k, pk) <- atomically . C.generateKeyPair =<< asks random
           atomically $ TM.insert sessionId (HandshakeSent pk) sessions
-          let authPubKey = (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 +158,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (keyHash == kh) $ throwE HANDSHAKE
           case compatibleVRange' xftpServerVRange v of
             Just (Compatible vr) -> do
-              let auth = THAuthServer {serverPrivKey = pk, 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
@@ -221,22 +221,22 @@ 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
 
@@ -317,22 +317,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 +359,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 +379,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

src/Simplex/FileTransfer/Server/Main.hs

@@ -21,7 +21,7 @@ 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)
@@ -29,7 +29,7 @@ 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.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
@@ -189,9 +189,10 @@ xftpServerCLI cfgPath logPath = do
               serverStatsLogFile = combine logPath "file-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
               transportConfig =
-                defaultTransportServerConfig
-                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  },
+                mkTransportServerConfig
+                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
+                  (Just alpnSupportedXFTPhandshakes)
+                  False,
               responseDelay = 0
             }
 

src/Simplex/FileTransfer/Transport.hs

@@ -13,7 +13,7 @@ module Simplex.FileTransfer.Transport
     authCmdsXFTPVersion,
     blockedFilesXFTPVersion,
     xftpClientHandshakeStub,
-    supportedXFTPhandshakes,
+    alpnSupportedXFTPhandshakes,
     XFTPClientHandshake (..),
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
@@ -42,7 +42,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (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 +50,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 +57,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 +101,17 @@ 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 = ["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 +131,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.hs

@@ -56,8 +56,8 @@ module Simplex.Messaging.Agent
     deleteConnectionAsync,
     deleteConnectionsAsync,
     createConnection,
-    setContactShortLink,
-    deleteContactShortLink,
+    setConnShortLink,
+    deleteConnShortLink,
     getConnShortLink,
     deleteLocalInvShortLink,
     changeConnectionUser,
@@ -73,6 +73,7 @@ module Simplex.Messaging.Agent
     getNotificationConns,
     resubscribeConnection,
     resubscribeConnections,
+    subscribeClientService,
     sendMessage,
     sendMessages,
     sendMessagesB,
@@ -216,6 +217,7 @@ import Simplex.Messaging.Protocol
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
+import Simplex.Messaging.Agent.Store.Entity
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Util
@@ -366,18 +368,18 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
 {-# INLINE deleteConnectionsAsync #-}
 
 -- | Create SMP agent connection (NEW command)
-createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, CreatedConnLink c)
+createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
 createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs
 {-# INLINE createConnection #-}
 
 -- | Create or update user's contact connection short link
-setContactShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact)
-setContactShortLink c = withAgentEnv c .: setContactShortLink' c
-{-# INLINE setContactShortLink #-}
+setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
+setConnShortLink c = withAgentEnv c .:: setConnShortLink' c
+{-# INLINE setConnShortLink #-}
 
-deleteContactShortLink :: AgentClient -> ConnId -> AE ()
-deleteContactShortLink c = withAgentEnv c . deleteContactShortLink' c
-{-# INLINE deleteContactShortLink #-}
+deleteConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> AE ()
+deleteConnShortLink c = withAgentEnv c .: deleteConnShortLink' c
+{-# INLINE deleteConnShortLink #-}
 
 -- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries
 getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
@@ -409,7 +411,7 @@ prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c ""
 {-# INLINE prepareConnectionToAccept #-}
 
 -- | Join SMP agent connection (JOIN command).
-joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
+joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
 joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs
 {-# INLINE joinConnection #-}
 
@@ -419,7 +421,7 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
 {-# INLINE allowConnection #-}
 
 -- | Accept contact after REQ notification (ACPT command)
-acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
+acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
 acceptContact c connId enableNtfs = withAgentEnv c .:: acceptContact' c connId enableNtfs
 {-# INLINE acceptContact #-}
 
@@ -429,12 +431,12 @@ rejectContact c = withAgentEnv c .: rejectContact' c
 {-# INLINE rejectContact #-}
 
 -- | Subscribe to receive connection messages (SUB command)
-subscribeConnection :: AgentClient -> ConnId -> AE ()
+subscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
 subscribeConnection c = withAgentEnv c . subscribeConnection' c
 {-# INLINE subscribeConnection #-}
 
 -- | Subscribe to receive connection messages from multiple connections, batching commands when possible
-subscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ()))
+subscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 subscribeConnections c = withAgentEnv c . subscribeConnections' c
 {-# INLINE subscribeConnections #-}
 
@@ -448,14 +450,19 @@ getNotificationConns :: AgentClient -> C.CbNonce -> ByteString -> AE (NonEmpty N
 getNotificationConns c = withAgentEnv c .: getNotificationConns' c
 {-# INLINE getNotificationConns #-}
 
-resubscribeConnection :: AgentClient -> ConnId -> AE ()
+resubscribeConnection :: AgentClient -> ConnId -> AE (Maybe ClientServiceId)
 resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
 {-# INLINE resubscribeConnection #-}
 
-resubscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ()))
+resubscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
 {-# INLINE resubscribeConnections #-}
 
+-- TODO [certs rcv] how to communicate that service ID changed - as error or as result?
+subscribeClientService :: AgentClient -> ClientServiceId -> AE Int
+subscribeClientService c = withAgentEnv c . subscribeClientService' c
+{-# INLINE subscribeClientService #-}
+
 -- | Send message to the connection (SEND command)
 sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AE (AgentMsgId, PQEncryption)
 sendMessage c = withAgentEnv c .:: sendMessage' c
@@ -825,50 +832,64 @@ switchConnectionAsync' c corrId connId =
             pure . connectionStats $ DuplexConnection cData rqs' sqs
       _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
 
-newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, CreatedConnLink c)
+newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
 newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
   srv <- getSMPServer c userId
   connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
   (connId,) <$> newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv
     `catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e
 
-setContactShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact)
-setContactShortLink' c connId userData = 
-  withConnLock c connId "setContactShortLink" $
-    withStore c (`getConn` connId) >>= \case
-      SomeConn _ (ContactConnection _ rq) -> do
-        (lnkId, linkKey, d) <- prepareLinkData rq
-        addQueueLink c rq lnkId d
-        pure $ CSLContact SLSServer CCTContact (qServer rq) linkKey
-      _ -> throwE $ CMD PROHIBITED "setContactShortLink: not contact address"
+setConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c)
+setConnShortLink' c connId cMode userData clientData =
+  withConnLock c connId "setConnShortLink" $ do
+    SomeConn _ conn <- withStore c (`getConn` connId)
+    (rq, lnkId, sl, d) <- case (conn, cMode) of
+      (ContactConnection _ rq, SCMContact) -> prepareContactLinkData rq
+      (RcvConnection _ rq, SCMInvitation) -> prepareInvLinkData rq
+      _ -> throwE $ CMD PROHIBITED "setConnShortLink: invalid connection or mode"
+    addQueueLink c rq lnkId d
+    pure sl
   where
-    prepareLinkData :: RcvQueue -> AM (SMP.LinkId, LinkKey, QueueLinkData)
-    prepareLinkData rq@RcvQueue {server, sndId, e2ePrivKey, shortLink} = do
+    prepareContactLinkData :: RcvQueue -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMContact, QueueLinkData)
+    prepareContactLinkData rq@RcvQueue {server, sndId, e2ePrivKey, shortLink} = do
       g <- asks random
       AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config
+      let cslContact = CSLContact SLSServer CCTContact (qServer rq)
       case shortLink of
         Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} -> do
           let (linkId, k) = SL.contactShortLinkKdf shortLinkKey
-          unless (shortLinkId == linkId) $ throwE $ INTERNAL "setContactShortLink: link ID is not derived from link"
-          d <- liftError id $ SL.encryptUserData g k $ SL.encodeSignUserData linkPrivSigKey smpAgentVRange userData
-          pure (linkId, shortLinkKey, (linkEncFixedData, d))
+          unless (shortLinkId == linkId) $ throwE $ INTERNAL "setConnShortLink: link ID is not derived from link"
+          d <- liftError id $ SL.encryptUserData g k $ SL.encodeSignUserData SCMContact linkPrivSigKey smpAgentVRange userData
+          pure (rq, linkId, cslContact shortLinkKey, (linkEncFixedData, d))
         Nothing -> do
           sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g
           let qUri = SMPQueueUri vr $ SMPQueueAddress server sndId (C.publicKey e2ePrivKey) (Just QMContact)
-              connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] Nothing
+              connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
               (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData
               (linkId, k) = SL.contactShortLinkKdf linkKey
           srvData <- liftError id $ SL.encryptLinkData g k linkData
           let slCreds = ShortLinkCreds linkId linkKey privSigKey (fst srvData)
           withStore' c $ \db -> updateShortLinkCreds db rq slCreds
-          pure (linkId, linkKey, srvData)
+          pure (rq, linkId, cslContact linkKey, srvData)
+    prepareInvLinkData :: RcvQueue -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMInvitation, QueueLinkData)
+    prepareInvLinkData rq@RcvQueue {shortLink} = case shortLink of
+      Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} -> do
+        g <- asks random
+        AgentConfig {smpAgentVRange} <- asks config
+        let k = SL.invShortLinkKdf shortLinkKey
+        d <- liftError id $ SL.encryptUserData g k $ SL.encodeSignUserData SCMInvitation linkPrivSigKey smpAgentVRange userData
+        let sl = CSLInvitation SLSServer (qServer rq) shortLinkId shortLinkKey
+        pure (rq, shortLinkId, sl, (linkEncFixedData, d))
+      Nothing -> throwE $ CMD PROHIBITED "setConnShortLink: no ShortLinkCreds in invitation"
 
-deleteContactShortLink' :: AgentClient -> ConnId -> AM ()
-deleteContactShortLink' c connId =
-  withConnLock c connId "deleteContactShortLink" $
-    withStore c (`getConn` connId) >>= \case
-      SomeConn _ (ContactConnection _ rq) -> deleteQueueLink c rq
-      _ -> throwE $ CMD PROHIBITED "deleteContactShortLink: not contact address"
+deleteConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> AM ()
+deleteConnShortLink' c connId cMode =
+  withConnLock c connId "deleteConnShortLink" $ do
+    SomeConn _ conn <- withStore c (`getConn` connId)
+    case (conn, cMode) of
+      (ContactConnection _ rq, SCMContact) -> deleteQueueLink c rq
+      (RcvConnection _ rq, SCMInvitation) -> deleteQueueLink c rq
+      _ -> throwE $ CMD PROHIBITED "deleteConnShortLink: not contact address"
 
 -- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent.
 getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c)
@@ -914,7 +935,7 @@ changeConnectionUser' c oldUserId connId newUserId = do
   where
     updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
 
-newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c)
+newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId)
 newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
   case (cMode, pqInitKeys) of
     (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
@@ -924,17 +945,19 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
     Just d -> do
       (nonce, qUri, cReq, qd) <- prepareLinkData d $ fst e2eKeys
       (rq, qUri') <- createRcvQueue (Just nonce) qd e2eKeys
-      connReqWithShortLink qUri cReq qUri' (shortLink rq)
+      ccLink <- connReqWithShortLink qUri cReq qUri' (shortLink rq)
+      pure (ccLink, clientServiceId rq)
     Nothing -> do
       let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing
-      (_, qUri) <- createRcvQueue Nothing qd e2eKeys
-      (`CCLink` Nothing) <$> createConnReq qUri
+      (rq, qUri) <- createRcvQueue Nothing qd e2eKeys
+      cReq <- createConnReq qUri
+      pure (CCLink cReq Nothing, clientServiceId rq)
   where
     createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
     createRcvQueue nonce_ qd e2eKeys = do
       AgentConfig {smpClientVRange = vr} <- asks config
       -- TODO [notifications] send correct NTF credentials here
-      -- let ntfCreds_ = Nothing 
+      -- let ntfCreds_ = Nothing
       (rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
       atomically $ incSMPServerStat c userId srv connCreated
       rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
@@ -951,10 +974,11 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
         SCMContact -> pure $ CRContactUri crData
         SCMInvitation -> do
           g <- asks random
-          (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
+          let pqEnc = CR.initialPQEncryption (isJust userData_) pqInitKeys
+          (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
           withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
           pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
-    prepareLinkData :: ConnInfo -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
+    prepareLinkData :: UserLinkData -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
     prepareLinkData userData e2eDhKey = do
       g <- asks random
       nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
@@ -979,11 +1003,13 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
     connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (CreatedConnLink c)
     connReqWithShortLink qUri cReq qUri' shortLink = case shortLink of
       Just ShortLinkCreds {shortLinkId, shortLinkKey}
-        | qUri == qUri'  ->
-            let link = case cReq of
-                  CRContactUri _ -> CSLContact SLSServer CCTContact srv shortLinkKey
-                  CRInvitationUri {} -> CSLInvitation SLSServer srv shortLinkId shortLinkKey
-             in pure $ CCLink cReq (Just link)
+        | qUri == qUri'  -> pure $ case cReq of
+            CRContactUri _ -> CCLink cReq $ Just $ CSLContact SLSServer CCTContact srv shortLinkKey
+            CRInvitationUri crData (CR.E2ERatchetParamsUri vr k1 k2 _) ->
+              let cReq' = case pqInitKeys of
+                    CR.IKPQOn -> CRInvitationUri crData $ CR.E2ERatchetParamsUri vr k1 k2 Nothing -- remove PQ keys
+                    _ -> cReq -- either PQ is disabled, or disabled for initial request because there is no short link
+               in CCLink cReq' $ Just $ CSLInvitation SLSServer srv shortLinkId shortLinkKey
         | otherwise -> throwE $ INTERNAL "different rcv queue address"
       Nothing ->
         let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri'] clientData)
@@ -1018,7 +1044,7 @@ newConnToAccept c connId enableNtfs invId pqSup = do
       newConnToJoin c userId connId enableNtfs connReq pqSup
     _ -> throwE $ CMD PROHIBITED "newConnToAccept"
 
-joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
+joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
 joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
   srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq]
   joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
@@ -1098,7 +1124,7 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
 versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
 {-# INLINE versionPQSupport_ #-}
 
-joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
+joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
 joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
   withInvLock c (strEncode inv) "joinConnSrv" $ do
     SomeConn cType conn <- withStore c (`getConn` connId)
@@ -1108,25 +1134,26 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod
       DuplexConnection _ (RcvQueue {status = New} :| _) (sq@SndQueue {status = New} :| _) -> doJoin $ Just sq
       _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
   where
-    doJoin :: Maybe SndQueue -> AM SndQueueSecured
+    doJoin :: Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId)
     doJoin sq_ = do
       (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
       secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode
         >>= (mapM_ (delInvSL c connId srv) lnkId_ $>)
 joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
   lift (compatibleContactUri cReqUri) >>= \case
-    Just (qInfo, vrsn) -> do
-      CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv
+    Just (qInfo, vrsn@(Compatible v)) -> do
+      let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup
+      (CCLink cReq _, service) <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv
       void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
-      pure False
+      pure (False, service)
     Nothing -> throwE $ AGENT A_VERSION
 
 delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SMP.LinkId -> AM ()
-delInvSL c connId srv lnkId = 
+delInvSL c connId srv lnkId =
   withStore' c (\db -> deleteInvShortLink db (protoServer srv) lnkId) `catchE` \e ->
     liftIO $ nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e))
 
-joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
+joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
 joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do
   SomeConn cType conn <- withStore c (`getConn` connId)
   case conn of
@@ -1134,7 +1161,7 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
     SndConnection _ sq -> doJoin $ Just sq
     _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType
   where
-    doJoin :: Maybe SndQueue -> AM SndQueueSecured
+    doJoin :: Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId)
     doJoin sq_ = do
       (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport
       secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode
@@ -1142,7 +1169,7 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
 joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
   throwE $ CMD PROHIBITED "joinConnSrvAsync"
 
-createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo
+createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId)
 createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
   -- TODO [notifications] send correct NTF credentials here
   (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing
@@ -1153,7 +1180,7 @@ createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVers
   when enableNtfs $ do
     ns <- asks ntfSupervisor
     atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
-  pure qInfo
+  pure (qInfo, clientServiceId rq')
 
 -- | Approve confirmation (LET command) in Reader monad
 allowConnection' :: AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
@@ -1166,14 +1193,14 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
     _ -> throwE $ CMD PROHIBITED "allowConnection"
 
 -- | Accept contact (ACPT command) in Reader monad
-acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
+acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
 acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
   Invitation {contactConnId, connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
-      sqSecured <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode
+      r <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      pure sqSecured
+      pure r
     _ -> throwE $ CMD PROHIBITED "acceptContact"
 
 -- | Reject contact (RJCT command) in Reader monad
@@ -1183,19 +1210,23 @@ rejectContact' c contactConnId invId =
 {-# INLINE rejectContact' #-}
 
 -- | Subscribe to receive connection messages (SUB command) in Reader monad
-subscribeConnection' :: AgentClient -> ConnId -> AM ()
+subscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
 subscribeConnection' c connId = toConnResult connId =<< subscribeConnections' c [connId]
 {-# INLINE subscribeConnection' #-}
 
-toConnResult :: ConnId -> Map ConnId (Either AgentErrorType ()) -> AM ()
+toConnResult :: ConnId -> Map ConnId (Either AgentErrorType a) -> AM a
 toConnResult connId rs = case M.lookup connId rs of
-  Just (Right ()) -> when (M.size rs > 1) $ logError $ T.pack $ "too many results " <> show (M.size rs)
+  Just (Right r) -> r <$ when (M.size rs > 1) (logError $ T.pack $ "too many results " <> show (M.size rs))
   Just (Left e) -> throwE e
   _ -> throwE $ INTERNAL $ "no result for connection " <> B.unpack connId
 
-type QCmdResult = (QueueStatus, Either AgentErrorType ())
+type QCmdResult a = (QueueStatus, Either AgentErrorType a)
 
-subscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
+type QDelResult = QCmdResult ()
+
+type QSubResult = QCmdResult (Maybe SMP.ServiceId)
+
+subscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 subscribeConnections' _ [] = pure M.empty
 subscribeConnections' c connIds = do
   conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConns` connIds)
@@ -1205,41 +1236,45 @@ subscribeConnections' c connIds = do
   resumeDelivery cs
   lift $ resumeConnCmds c $ M.keys cs
   rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs)
+  rcvRs' <- storeClientServiceAssocs rcvRs
   ns <- asks ntfSupervisor
   tkn <- readTVarIO (ntfTkn ns)
-  lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs cs
-  let rs = M.unions ([errs', subRs, rcvRs] :: [Map ConnId (Either AgentErrorType ())])
+  lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs' cs
+  let rs = M.unions ([errs', subRs, rcvRs'] :: [Map ConnId (Either AgentErrorType (Maybe ClientServiceId))])
   notifyResultError rs
   pure rs
   where
-    rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue]
+    rcvQueueOrResult :: SomeConn -> Either (Either AgentErrorType (Maybe ClientServiceId)) [RcvQueue]
     rcvQueueOrResult (SomeConn _ conn) = case conn of
       DuplexConnection _ rqs _ -> Right $ L.toList rqs
       SndConnection _ sq -> Left $ sndSubResult sq
       RcvConnection _ rq -> Right [rq]
       ContactConnection _ rq -> Right [rq]
-      NewConnection _ -> Left (Right ())
-    sndSubResult :: SndQueue -> Either AgentErrorType ()
+      NewConnection _ -> Left (Right Nothing)
+    sndSubResult :: SndQueue -> Either AgentErrorType (Maybe ClientServiceId)
     sndSubResult SndQueue {status} = case status of
-      Confirmed -> Right ()
+      Confirmed -> Right Nothing
       Active -> Left $ CONN SIMPLEX
       _ -> Left $ INTERNAL "unexpected queue status"
-    connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
+    connResults :: [(RcvQueue, Either AgentErrorType (Maybe SMP.ServiceId))] -> Map ConnId (Either AgentErrorType (Maybe SMP.ServiceId))
     connResults = M.map snd . foldl' addResult M.empty
       where
         -- collects results by connection ID
-        addResult :: Map ConnId QCmdResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QCmdResult
+        addResult :: Map ConnId QSubResult -> (RcvQueue, Either AgentErrorType (Maybe SMP.ServiceId)) -> Map ConnId QSubResult
         addResult rs (RcvQueue {connId, status}, r) = M.alter (combineRes (status, r)) connId rs
         -- combines two results for one connection, by using only Active queues (if there is at least one Active queue)
-        combineRes :: QCmdResult -> Maybe QCmdResult -> Maybe QCmdResult
+        combineRes :: QSubResult -> Maybe QSubResult -> Maybe QSubResult
         combineRes r' (Just r) = Just $ if order r <= order r' then r else r'
         combineRes r' _ = Just r'
-        order :: QCmdResult -> Int
+        order :: QSubResult -> Int
         order (Active, Right _) = 1
         order (Active, _) = 2
         order (_, Right _) = 3
         order _ = 4
-    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId SomeConn -> AM' ()
+    -- TODO [certs rcv] store associations of queues with client service ID
+    storeClientServiceAssocs :: Map ConnId (Either AgentErrorType (Maybe SMP.ServiceId)) -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
+    storeClientServiceAssocs = pure . M.map (Nothing <$)
+    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> Map ConnId SomeConn -> AM' ()
     sendNtfCreate ns rcvRs cs = do
       let oks = M.keysSet $ M.filter (either temporaryAgentError $ const True) rcvRs
           cs' = M.restrictKeys cs oks
@@ -1257,25 +1292,29 @@ subscribeConnections' c connIds = do
       DuplexConnection cData _ sqs -> Just (cData, sqs)
       SndConnection cData sq -> Just (cData, [sq])
       _ -> Nothing
-    notifyResultError :: Map ConnId (Either AgentErrorType ()) -> AM ()
+    notifyResultError :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> AM ()
     notifyResultError rs = do
       let actual = M.size rs
           expected = length connIds
       when (actual /= expected) . atomically $
         writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
 
-resubscribeConnection' :: AgentClient -> ConnId -> AM ()
+resubscribeConnection' :: AgentClient -> ConnId -> AM (Maybe ClientServiceId)
 resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId]
 {-# INLINE resubscribeConnection' #-}
 
-resubscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
+resubscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
 resubscribeConnections' _ [] = pure M.empty
 resubscribeConnections' c connIds = do
-  let r = M.fromList . zip connIds . repeat $ Right ()
+  let r = M.fromList . zip connIds . repeat $ Right Nothing
   connIds' <- filterM (fmap not . atomically . hasActiveSubscription c) connIds
   -- union is left-biased, so results returned by subscribeConnections' take precedence
   (`M.union` r) <$> subscribeConnections' c connIds'
 
+-- TODO [certs rcv]
+subscribeClientService' :: AgentClient -> ClientServiceId -> AM Int
+subscribeClientService' = undefined
+
 -- requesting messages sequentially, to reduce memory usage
 getConnectionMessages' :: AgentClient -> NonEmpty ConnMsgReq -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
 getConnectionMessages' c = mapM $ tryAgentError' . getConnectionMessage
@@ -1293,7 +1332,7 @@ getConnectionMessages' c = mapM $ tryAgentError' . getConnectionMessage
       msg_ <- getQueueMessage c rq `catchAgentError` \e -> atomically (releaseGetLock c rq) >> throwError e
       when (isNothing msg_) $ do
         atomically $ releaseGetLock c rq
-        forM_ msgTs_ $ \msgTs -> withStore' c $ \db -> setLastBrokerTs db connId (DBQueueId dbQueueId) msgTs
+        forM_ msgTs_ $ \msgTs -> withStore' c $ \db -> setLastBrokerTs db connId (DBEntityId dbQueueId) msgTs
       pure msg_
 {-# INLINE getConnectionMessages' #-}
 
@@ -1429,13 +1468,13 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
           triedHosts <- newTVarIO S.empty
           tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
-            CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
-            notify $ INV (ACR cMode cReq)
+            (CCLink cReq _, service) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
+            notify $ INV (ACR cMode cReq) service
         JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
           triedHosts <- newTVarIO S.empty
           tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do
-            sqSecured <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
-            notify $ JOINED sqSecured
+            (sqSecured, service) <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
+            notify $ JOINED sqSecured service
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
         ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK
         SWCH ->
@@ -1910,7 +1949,7 @@ switchConnection' c connId =
       _ -> throwE $ CMD PROHIBITED "switchConnection: not duplex"
 
 switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats
-switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do
+switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBEntityId dbQueueId, sndId} = do
   checkRQSwchStatus rq RSSwitchStarted
   clientVRange <- asks $ smpClientVRange . config
   -- try to get the server that is different from all queues, or at least from the primary rcv queue
@@ -2099,13 +2138,13 @@ deleteConnQueues c waitDelivery ntf rqs = do
     connResults = M.map snd . foldl' addResult M.empty
       where
         -- collects results by connection ID
-        addResult :: Map ConnId QCmdResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QCmdResult
+        addResult :: Map ConnId QDelResult -> (RcvQueue, Either AgentErrorType ()) -> Map ConnId QDelResult
         addResult rs (RcvQueue {connId, status}, r) = M.alter (combineRes (status, r)) connId rs
         -- combines two results for one connection, by prioritizing errors in Active queues
-        combineRes :: QCmdResult -> Maybe QCmdResult -> Maybe QCmdResult
+        combineRes :: QDelResult -> Maybe QDelResult -> Maybe QDelResult
         combineRes r' (Just r) = Just $ if order r <= order r' then r else r'
         combineRes r' _ = Just r'
-        order :: QCmdResult -> Int
+        order :: QDelResult -> Int
         order (Active, Left _) = 1
         order (_, Left _) = 2
         order _ = 3
@@ -2433,7 +2472,7 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
   delLock <- atomically $ tryReadTMVar d
   pure AgentLocks {connLocks, invLocks, delLock}
   where
-    getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
+    getLocks ls = atomically $ M.mapKeys (safeDecodeUtf8 . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
 
 getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
 getSMPServer c userId = getNextSMPServer c userId []
@@ -2538,6 +2577,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
       withRcvConn entId $ \rq conn -> case cmd of
         SMP.SUB -> case respOrErr of
           Right SMP.OK -> processSubOk rq upConnIds
+          -- TODO [certs rcv] associate queue with the service
+          Right (SMP.SOK serviceId_) -> processSubOk rq upConnIds
           Right msg@SMP.MSG {} -> do
             processSubOk rq upConnIds -- the connection is UP even when processing this particular message fails
             runProcessSMP rq conn (toConnData conn) msg
@@ -2940,7 +2981,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
               Just qInfo@(Compatible sqInfo@SMPQueueInfo {queueAddress}) ->
                 case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of
                   (Just _, _) -> qError "QADD: queue address is already used in connection"
-                  (_, Just sq@SndQueue {dbQueueId = DBQueueId dbQueueId}) -> do
+                  (_, Just sq@SndQueue {dbQueueId = DBEntityId dbQueueId}) -> do
                     let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs
                     case L.nonEmpty keepSqs of
                       Just sqs' -> do
@@ -3139,20 +3180,22 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _
           (sq, _) <- lift $ newSndQueue userId connId qInfo' Nothing
           withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
 
-secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured
+secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
 secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do
   sqSecured <- agentSecureSndQueue c cData sq
-  storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode
+  (qInfo, service) <- mkAgentConfirmation c cData sq srv connInfo subMode
+  storeConfirmation c cData sq e2eEncryption_ qInfo
   lift $ submitPendingMsg c cData sq
-  pure sqSecured
+  pure (sqSecured, service)
 
-secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured
+secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
 secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do
   sqSecured <- agentSecureSndQueue c cData sq
-  msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode
+  (qInfo, service) <- mkAgentConfirmation c cData sq srv connInfo subMode
+  msg <- mkConfirmation qInfo
   void $ sendConfirmation c sq msg
   withStore' c $ \db -> setSndQueueStatus db sq Confirmed
-  pure sqSecured
+  pure (sqSecured, service)
   where
     mkConfirmation :: AgentMessage -> AM MsgBody
     mkConfirmation aMessage = do
@@ -3178,10 +3221,10 @@ agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status
     sndSecure = senderCanSecure queueMode
     initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion
 
-mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage
+mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId)
 mkAgentConfirmation c cData sq srv connInfo subMode = do
-  qInfo <- createReplyQueue c cData sq subMode srv
-  pure $ AgentConnInfoReply (qInfo :| []) connInfo
+  (qInfo, service) <- createReplyQueue c cData sq subMode srv
+  pure (AgentConnInfoReply (qInfo :| []) connInfo, service)
 
 enqueueConfirmation :: AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AM ()
 enqueueConfirmation c cData sq connInfo e2eEncryption_ = do
@@ -3278,7 +3321,7 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd
             e2ePubKey = Just e2ePubKey,
             -- setting status to Secured prevents SKEY when queue was already secured with LKEY
             status = if isJust sndKeys_ then Secured else New,
-            dbQueueId = DBNewQueue,
+            dbQueueId = DBNewEntity,
             primary = True,
             dbReplaceQueueId = Nothing,
             sndSwchStatus = Nothing,

src/Simplex/Messaging/Agent/Client.hs

@@ -33,6 +33,7 @@ module Simplex.Messaging.Agent.Client
     withConnLocks,
     withInvLock,
     withLockMap,
+    withLocksMap,
     getMapLock,
     ipAddressProtected,
     closeAgentClient,
@@ -246,6 +247,7 @@ import Simplex.Messaging.Protocol
   ( AProtocolType (..),
     BrokerMsg,
     EntityId (..),
+    ServiceId,
     ErrorType,
     MsgFlags (..),
     MsgId,
@@ -278,6 +280,7 @@ import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Session
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion)
@@ -456,9 +459,9 @@ data AgentState = ASForeground | ASSuspending | ASSuspended
   deriving (Eq, Show)
 
 data AgentLocks = AgentLocks
-  { connLocks :: Map String String,
-    invLocks :: Map String String,
-    delLock :: Maybe String
+  { connLocks :: Map Text Text,
+    invLocks :: Map Text Text,
+    delLock :: Maybe Text
   }
   deriving (Show)
 
@@ -984,34 +987,34 @@ closeXFTPServerClient :: AgentClient -> UserId -> XFTPServer -> FileDigest -> IO
 closeXFTPServerClient c userId server (FileDigest chunkDigest) =
   mkTransportSession c userId server chunkDigest >>= closeClient c xftpClients
 
-withConnLock :: AgentClient -> ConnId -> String -> AM a -> AM a
+withConnLock :: AgentClient -> ConnId -> Text -> AM a -> AM a
 withConnLock c connId name = ExceptT . withConnLock' c connId name . runExceptT
 {-# INLINE withConnLock #-}
 
-withConnLock' :: AgentClient -> ConnId -> String -> AM' a -> AM' a
+withConnLock' :: AgentClient -> ConnId -> Text -> AM' a -> AM' a
 withConnLock' _ "" _ = id
 withConnLock' AgentClient {connLocks} connId name = withLockMap connLocks connId name
 {-# INLINE withConnLock' #-}
 
-withInvLock :: AgentClient -> ByteString -> String -> AM a -> AM a
+withInvLock :: AgentClient -> ByteString -> Text -> AM a -> AM a
 withInvLock c key name = ExceptT . withInvLock' c key name . runExceptT
 {-# INLINE withInvLock #-}
 
-withInvLock' :: AgentClient -> ByteString -> String -> AM' a -> AM' a
+withInvLock' :: AgentClient -> ByteString -> Text -> AM' a -> AM' a
 withInvLock' AgentClient {invLocks} = withLockMap invLocks
 {-# INLINE withInvLock' #-}
 
-withConnLocks :: AgentClient -> Set ConnId -> String -> AM' a -> AM' a
-withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks
+withConnLocks :: AgentClient -> Set ConnId -> Text -> AM' a -> AM' a
+withConnLocks AgentClient {connLocks} = withLocksMap connLocks
 {-# INLINE withConnLocks #-}
 
-withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
+withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a
 withLockMap = withGetLock . getMapLock
 {-# INLINE withLockMap #-}
 
-withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> String -> m a -> m a
-withLocksMap_ = withGetLocks . getMapLock
-{-# INLINE withLocksMap_ #-}
+withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a
+withLocksMap = withGetLocks . getMapLock
+{-# INLINE withLocksMap #-}
 
 getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
 getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
@@ -1083,7 +1086,7 @@ sendOrProxySMPCommand ::
   UserId ->
   SMPServer ->
   ConnId -> -- session entity ID, for short links LinkId is used
-  ByteString -> 
+  ByteString ->
   SMP.EntityId -> -- sender or link ID
   (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) ->
   (SMPClient -> ExceptT SMPClientError IO a) ->
@@ -1195,6 +1198,7 @@ protocolClientError protocolError_ host = \case
   PCEIncompatibleHost -> BROKER host HOST
   PCETransportError e -> BROKER host $ TRANSPORT e
   e@PCECryptoError {} -> INTERNAL $ show e
+  PCEServiceUnavailable {} -> BROKER host NO_SERVICE
   PCEIOError {} -> BROKER host NETWORK
 
 data ProtocolTestStep
@@ -1376,9 +1380,10 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
   logServer "-->" c srv NoEntity "NEW"
   tSess <- mkTransportSession c userId srv connId
   -- TODO [notifications]
-  r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode}) <-
+  r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId}) <-
     withClient c tSess $ \(SMPConnectedClient smp _) ->
       (thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd)
+  -- TODO [certs rcv] validate that serviceId is the same as in the client session
   liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   shortLink <- mkShortLinkCreds r
   let rq =
@@ -1394,8 +1399,9 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
             sndId,
             queueMode,
             shortLink,
+            clientService = ClientService DBNewEntity <$> serviceId,
             status = New,
-            dbQueueId = DBNewQueue,
+            dbQueueId = DBNewEntity,
             primary = True,
             dbReplaceQueueId = Nothing,
             rcvSwchStatus = Nothing,
@@ -1408,7 +1414,7 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
   where
     mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds)
     mkShortLinkCreds (thParams', QIK {sndId, queueMode, linkId}) = case (cqrd, queueMode) of
-      (CQRMessaging ld, Just QMMessaging) -> 
+      (CQRMessaging ld, Just QMMessaging) ->
         withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
           if sndId == sndId'
             then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d)
@@ -1433,13 +1439,13 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
         newErr :: String -> AM (Maybe ShortLinkCreds)
         newErr = throwE . BROKER (B.unpack $ strEncode srv) . UNEXPECTED . ("Create queue: " <>)
 
-processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError () -> STM ()
+processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError (Maybe ServiceId) -> STM ()
 processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
   Left e ->
     unless (temporaryClientError e) $ do
       incSMPServerStat c userId server connSubErrs
       failSubscription c rq e
-  Right () ->
+  Right _serviceId -> -- TODO [certs rcv] store association with the service
     ifM
       (hasPendingSubscription c connId)
       (incSMPServerStat c userId server connSubscribed >> addSubscription c sessId rq)
@@ -1478,7 +1484,7 @@ serverHostError = \case
       _ -> False
 
 -- | Subscribe to queues. The list of results can have a different order.
-subscribeQueues :: AgentClient -> [RcvQueue] -> AM' ([(RcvQueue, Either AgentErrorType ())], Maybe SessionId)
+subscribeQueues :: AgentClient -> [RcvQueue] -> AM' ([(RcvQueue, Either AgentErrorType (Maybe ServiceId))], Maybe SessionId)
 subscribeQueues c qs = do
   (errs, qs') <- partitionEithers <$> mapM checkQueue qs
   atomically $ do
@@ -1493,7 +1499,7 @@ subscribeQueues c qs = do
     checkQueue rq = do
       prohibited <- liftIO $ hasGetLock c rq
       pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
-    subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
+    subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError (Maybe ServiceId))
     subscribeQueues_ env session smp qs' = do
       let (userId, srv, _) = transportSession' smp
       atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
@@ -1513,7 +1519,7 @@ subscribeQueues c qs = do
         tSess = transportSession' smp
         sessId = sessionId $ thParams smp
         hasTempErrors = any (either temporaryClientError (const False) . snd)
-        processSubResults :: NonEmpty (RcvQueue, Either SMPClientError ()) -> STM ()
+        processSubResults :: NonEmpty (RcvQueue, Either SMPClientError (Maybe ServiceId)) -> STM ()
         processSubResults = mapM_ $ uncurry $ processSubResult c sessId
         resubscribe = resubscribeSMPSession c tSess `runReaderT` env
 
@@ -1550,10 +1556,10 @@ sendTSessionBatches statCmd toRQ action c qs =
           where
             agentError = second . first $ protocolClientError SMP $ clientServer smp
 
-sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
+sendBatch :: (SMPClient -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
 sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
   where
-    queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
+    queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvId, rcvPrivateKey)
 
 addSubscription :: AgentClient -> SessionId -> RcvQueue -> STM ()
 addSubscription c sessId rq@RcvQueue {connId} = do
@@ -1714,12 +1720,12 @@ enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
   where
     enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
     enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
-    queueCreds :: EnableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
+    queueCreds :: EnableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
     queueCreds EnableQueueNtfReq {eqnrRq, eqnrAuthKeyPair, eqnrRcvKeyPair} =
       let RcvQueue {rcvPrivateKey, rcvId} = eqnrRq
           (ntfPublicKey, _) = eqnrAuthKeyPair
           (rcvNtfPubDhKey, _) = eqnrRcvKeyPair
-       in (rcvPrivateKey, rcvId, ntfPublicKey, rcvNtfPubDhKey)
+       in (rcvId, rcvPrivateKey, ntfPublicKey, rcvNtfPubDhKey)
 
 disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
 disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
@@ -1733,8 +1739,8 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
   where
     disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
     disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
-    queueCreds :: DisableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId)
-    queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
+    queueCreds :: DisableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey)
+    queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvId, rcvPrivateKey)
 
 sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =

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/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,
@@ -164,11 +168,14 @@ module Simplex.Messaging.Agent.Protocol
     shortenShortLink,
     restoreShortLink,
     linkUserData,
+    linkUserData',
   )
 where
 
 import Control.Applicative (optional, (<|>))
 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)
@@ -187,18 +194,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
@@ -367,7 +376,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
@@ -393,7 +402,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
@@ -493,7 +502,7 @@ aCommandTag = \case
 
 aEventTag :: AEvent e -> AEventTag e
 aEventTag = \case
-  INV _ -> INV_
+  INV {} -> INV_
   CONF {} -> CONF_
   REQ {} -> REQ_
   INFO {} -> INFO_
@@ -519,7 +528,7 @@ aEventTag = \case
   DEL_USER _ -> DEL_USER_
   STAT _ -> STAT_
   OK -> OK_
-  JOINED _ -> JOINED_
+  JOINED {} -> JOINED_
   ERR _ -> ERR_
   ERRS _ -> ERRS_
   SUSPENDED -> SUSPENDED_
@@ -1187,6 +1196,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
@@ -1413,6 +1432,10 @@ data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
 
 data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
 
+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)
 
@@ -1421,6 +1444,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)
@@ -1503,7 +1531,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_ =
@@ -1540,7 +1568,7 @@ ctTypeP :: Char -> Parser ContactConnType
 ctTypeP = \case
   'A' -> pure CCTContact
   'C' -> pure CCTChannel
-  'G' -> pure CCTGroup 
+  'G' -> pure CCTGroup
   _ -> fail "unknown contact address type"
 {-# INLINE ctTypeP #-}
 
@@ -1620,7 +1648,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.
@@ -1629,15 +1657,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
 
@@ -1684,15 +1719,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
@@ -1896,7 +1947,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

@@ -52,30 +52,19 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Agent.Store.Entity
 
 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 +84,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,6 +111,10 @@ 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}
@@ -160,12 +155,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 +179,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 +252,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 +262,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 #-}

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

@@ -283,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
@@ -380,6 +381,7 @@ 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
@@ -472,6 +474,7 @@ upgradeRcvConnToDuplex db connId sq =
     (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
     (SomeConn c _) -> pure . Left . SEBadConnType $ 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
@@ -479,6 +482,7 @@ upgradeSndConnToDuplex db connId rq =
     Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
+-- TODO [certs rcv] store clientServiceId from NewRcvQueue
 addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 addConnRcvQueue db connId rq =
   getConn db connId >>= \case
@@ -858,7 +862,7 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta =
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
   setLastBrokerTs db connId dbQueueId brokerTs
 
-setLastBrokerTs :: DB.Connection -> ConnId -> DBQueueId 'QSStored -> UTCTime -> IO ()
+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)
 
@@ -1212,7 +1216,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))
@@ -1811,15 +1815,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
@@ -1984,7 +1979,8 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
         :. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
         :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
     )
-  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
+  -- TODO [certs rcv] save client service
+  pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
 
 -- * createSndConn helpers
 
@@ -2018,13 +2014,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
 
@@ -2160,7 +2156,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
@@ -2178,7 +2174,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 =
@@ -2210,7 +2207,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/SQLite/Migrations/M20250517_service_certs.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+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/Client.hs

@@ -46,6 +46,8 @@ module Simplex.Messaging.Client
     getSMPMessage,
     subscribeSMPQueueNotifications,
     subscribeSMPQueuesNtfs,
+    subscribeService,
+    smpClientService,
     secureSMPQueue,
     secureSndSMPQueue,
     proxySecureSndSMPQueue,
@@ -92,6 +94,7 @@ module Simplex.Messaging.Client
     clientSocksCredentials,
     chooseTransportHost,
     temporaryClientError,
+    smpClientServiceError,
     smpProxyError,
     textToHostMode,
     ServerTransmissionBatch,
@@ -153,7 +156,7 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tryWriteTBQueue, tshow, whenM)
+import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Mem.Weak (Weak, deRefWeak)
 import System.Timeout (timeout)
@@ -180,7 +183,7 @@ data PClient v err msg = PClient
     clientCorrId :: TVar ChaChaDRG,
     sentCommands :: TMap CorrId (Request err msg),
     sndQ :: TBQueue (Maybe (Request err msg), ByteString),
-    rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
+    rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg))),
     msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
   }
 
@@ -207,7 +210,8 @@ smpClientStub g sessionId thVersion thAuth = do
               blockSize = smpBlockSize,
               implySessId = thVersion >= authCmdsSMPVersion,
               encryptBlock = Nothing,
-              batch = True
+              batch = True,
+              serviceAuth = thVersion >= serviceCertsSMPVersion
             },
         sessionTs = ts,
         client_ =
@@ -231,7 +235,7 @@ smpClientStub g sessionId thVersion thAuth = do
 type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
 
 -- | Type for client command data
-type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
+type ClientCommand msg = (EntityId, Maybe C.APrivateAuthKey, ProtoCommand msg)
 
 -- | Type synonym for transmission from SPM servers.
 -- Batch response is presented as a single `ServerTransmissionBatch` tuple.
@@ -393,9 +397,9 @@ defaultNetworkConfig =
       logTLSErrors = False
     }
 
-transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig
-transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI =
-  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI}
+transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN =
+  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
   where
     socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
     useSocksProxy SMAlways = socksProxy'
@@ -424,10 +428,11 @@ data ProtocolClientConfig v = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
-    defaultTransport :: (ServiceName, ATransport),
+    defaultTransport :: (ServiceName, ATransport 'TClient),
     -- | network configuration
     networkConfig :: NetworkConfig,
     clientALPN :: Maybe [ALPN],
+    serviceCredentials :: Maybe ServiceCredentials,
     -- | client-server protocol version range
     serverVRange :: VersionRange v,
     -- | agree shared session secret (used in SMP proxy for additional encryption layer)
@@ -446,6 +451,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
       defaultTransport = ("443", transport @TLS),
       networkConfig = defaultNetworkConfig,
       clientALPN,
+      serviceCredentials = Nothing,
       serverVRange,
       agreeSecret = False,
       proxyServer = False,
@@ -455,7 +461,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
 
 defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
 defaultSMPClientConfig =
-  (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
+  (defaultClientConfig (Just alpnSupportedSMPHandshakes) False supportedClientSMPRelayVRange)
     { defaultTransport = (show defaultSMPPort, transport @TLS),
       agreeSecret = True
     }
@@ -518,7 +524,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -553,10 +559,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+    runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
     runClient (port', ATransport t) useHost c = do
       cVar <- newEmptyTMVarIO
-      let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
+      let tcConfig = (transportClientConfig networkConfig useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
           socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
       tId <-
         runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
@@ -567,7 +573,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
         Just (Left e) -> pure $ Left e
         Nothing -> killThread tId $> Left PCENetworkError
 
-    useTransport :: (ServiceName, ATransport)
+    useTransport :: (ServiceName, ATransport 'TClient)
     useTransport = case port srv of
       "" -> case protocolTypeI @(ProtoType msg) of
         SPSMP | smpWebPort -> ("443", transport @TLS)
@@ -581,10 +587,11 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
             _ -> False
           SWPOff -> False
 
-    client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
+    client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
     client _ c cVar h = do
       ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
-      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case
+      serviceKeys_ <- mapM (\creds -> (creds,) <$> atomically (C.generateKeyPair g)) serviceCredentials
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer serviceKeys_) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {params} -> do
           sessionTs <- getCurrentTime
@@ -608,7 +615,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
 
     receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
-      tGet h >>= atomically . writeTBQueue rcvQ
+      tGetClient h >>= atomically . writeTBQueue rcvQ
       getCurrentTime >>= atomically . writeTVar lastReceived
       atomically $ writeTVar timeoutErrorCount 0
 
@@ -635,14 +642,14 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     process :: ProtocolClient v err msg -> IO ()
     process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c
 
-    processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO ()
+    processMsgs :: ProtocolClient v err msg -> NonEmpty (Transmission (Either err msg)) -> IO ()
     processMsgs c ts = do
       ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts)
       forM_ msgQ $ \q ->
         mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts')
 
-    processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
-    processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
+    processMsg :: ProtocolClient v err msg -> Transmission (Either err msg) -> IO (Maybe (EntityId, ServerTransmission err msg))
+    processMsg ProtocolClient {client_ = PClient {sentCommands}} (corrId, entId, respOrErr)
       | B.null $ bs corrId = sendMsg $ STEvent clientResp
       | otherwise =
           TM.lookupIO corrId sentCommands >>= \case
@@ -702,6 +709,8 @@ data ProtocolClientError err
     PCENetworkError
   | -- | No host compatible with network configuration
     PCEIncompatibleHost
+  | -- | Service is unavailable for command that requires service connection
+    PCEServiceUnavailable
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
@@ -721,6 +730,14 @@ temporaryClientError = \case
   _ -> False
 {-# INLINE temporaryClientError #-}
 
+smpClientServiceError :: SMPClientError -> Bool
+smpClientServiceError = \case
+  PCEServiceUnavailable -> True
+  PCETransportError (TEHandshake BAD_SERVICE) -> True -- TODO [certs] this error may be temporary, so we should possibly resubscribe.
+  PCEProtocolError SERVICE -> True
+  PCEProtocolError (PROXY (BROKER NO_SERVICE)) -> True -- for completeness, it cannot happen.
+  _ -> False
+
 -- converts error of client running on proxy to the error sent to client connected to proxy
 smpProxyError :: SMPClientError -> ErrorType
 smpProxyError = \case
@@ -730,6 +747,7 @@ smpProxyError = \case
   PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
   PCENetworkError -> PROXY $ BROKER NETWORK
   PCEIncompatibleHost -> PROXY $ BROKER HOST
+  PCEServiceUnavailable -> PROXY $ BROKER $ NO_SERVICE -- for completeness, it cannot happen.
   PCETransportError t -> PROXY $ BROKER $ TRANSPORT t
   PCECryptoError _ -> CRYPTO
   PCEIOError _ -> INTERNAL
@@ -749,41 +767,41 @@ createSMPQueue ::
   -- Maybe NewNtfCreds ->
   ExceptT SMPClientError IO QueueIdsKeys
 createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd =
-  sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
+  sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
     IDS qik -> pure qik
     r -> throwE $ unexpectedResponse r
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
+subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
 subscribeSMPQueue c rpKey rId = do
   liftIO $ enablePings c
-  sendSMPCommand c (Just rpKey) rId SUB >>= \case
-    OK -> pure ()
-    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
-    r -> throwE $ unexpectedResponse r
+  sendSMPCommand c (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
 
 -- | Subscribe to multiple SMP queues batching commands if supported.
-subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
 subscribeSMPQueues c qs = do
   liftIO $ enablePings c
   sendProtocolCommands c cs >>= mapM (processSUBResponse c)
   where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
+    cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
 
-streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO ()
+streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
 streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
   where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
+    cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
     process r@(Response rId _) = (rId,) <$> processSUBResponse c r
 
-processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError ())
-processSUBResponse c (Response rId r) = case r of
-  Right OK -> pure $ Right ()
-  Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
-  Right r' -> pure . Left $ unexpectedResponse r'
-  Left e -> pure $ Left e
+processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
+processSUBResponse c (Response rId r) = pure r $>>= processSUBResponse_ c rId
+
+processSUBResponse_ :: SMPClient -> RecipientId -> BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
+processSUBResponse_ c rId = \case
+  OK -> pure $ Right Nothing
+  SOK serviceId_ -> pure $ Right serviceId_
+  cmd@MSG {} -> writeSMPMessage c rId cmd $> Right Nothing
+  r' -> pure . Left $ unexpectedResponse r'
 
 writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
 writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c)
@@ -806,18 +824,47 @@ getSMPMessage c rpKey rId =
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
 subscribeSMPQueueNotifications c npKey nId = do
   liftIO $ enablePings c
-  okSMPCommand NSUB c npKey nId
-{-# INLINE subscribeSMPQueueNotifications #-}
+  sendSMPCommand c (Just npKey) nId NSUB >>= except . nsubResponse_
 
 -- | Subscribe to multiple SMP queues notifications batching commands if supported.
-subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
+subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
 subscribeSMPQueuesNtfs c qs = do
   liftIO $ enablePings c
-  okSMPCommands NSUB c qs
-{-# INLINE subscribeSMPQueuesNtfs #-}
+  L.map nsubResponse <$> sendProtocolCommands c cs
+  where
+    cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
+
+nsubResponse :: Response ErrorType BrokerMsg -> Either SMPClientError (Maybe ServiceId)
+nsubResponse (Response _ r) = r >>= nsubResponse_
+{-# INLINE nsubResponse #-}
+
+nsubResponse_ :: BrokerMsg -> Either SMPClientError (Maybe ServiceId)
+nsubResponse_ = \case
+  OK -> Right Nothing
+  SOK serviceId_ -> Right serviceId_
+  r' -> Left $ unexpectedResponse r'
+{-# INLINE nsubResponse_ #-}
+
+subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
+subscribeService c party = case smpClientService c of
+  Just THClientService {serviceId, serviceKey} -> do
+    liftIO $ enablePings c
+    sendSMPCommand c (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
+      SOKS n -> pure n
+      r -> throwE $ unexpectedResponse r
+    where
+      subCmd :: Command p
+      subCmd = case party of
+        SRecipientService -> SUBS
+        SNotifierService -> NSUBS
+  Nothing -> throwE PCEServiceUnavailable
+
+smpClientService :: SMPClient -> Maybe THClientService
+smpClientService = thAuth . thParams >=> clientService
+{-# INLINE smpClientService #-}
 
 enablePings :: SMPClient -> IO ()
 enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeTVar sendPings True
@@ -887,10 +934,10 @@ enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
     r -> throwE $ unexpectedResponse r
 
 -- | Enable notifications for the multiple queues for push notifications server.
-enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
+enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
 enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
   where
-    cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
+    cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
     process (Response _ r) = case r of
       Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
       Right r' -> Left $ unexpectedResponse r'
@@ -904,7 +951,7 @@ disableSMPQueueNotifications = okSMPCommand NDEL
 {-# INLINE disableSMPQueueNotifications #-}
 
 -- | Disable notifications for multiple queues for push notifications server.
-disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
 disableSMPQueuesNtfs = okSMPCommands NDEL
 {-# INLINE disableSMPQueuesNtfs #-}
 
@@ -946,7 +993,7 @@ deleteSMPQueue = okSMPCommand DEL
 {-# INLINE deleteSMPQueue #-}
 
 -- | Delete multiple SMP queues batching commands if supported.
-deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+deleteSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
 deleteSMPQueues = okSMPCommands DEL
 {-# INLINE deleteSMPQueues #-}
 
@@ -956,7 +1003,7 @@ connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT S
 connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
   | thVersion (thParams c) >= sendingProxySMPVersion =
       sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
-        PKEY sId vr (chain, key) ->
+        PKEY sId vr (CertChainPubKey chain key) ->
           case supportedClientSMPRelayVRange `compatibleVersion` vr of
             Nothing -> throwE $ transportErr TEVersion
             Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key
@@ -970,10 +1017,9 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
       serverKey <- case cert of
         [leaf, ca]
           | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 ->
-              C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned leaf, []) >>= C.pubKey
+              C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned leaf
         _ -> throwError "bad certificate"
-      pubKey <- C.verifyX509 serverKey exact
-      C.x509ToPublic (pubKey, []) >>= C.pubKey
+      C.x509ToPublic' =<< C.verifyX509 serverKey exact
 
 data ProxiedRelay = ProxiedRelay
   { prSessionId :: SessionId,
@@ -1050,15 +1096,16 @@ proxySMPCommand ::
   ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
 proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
   -- prepare params
-  let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
+  let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
       serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
   (cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
   let cmdSecret = C.dh' serverKey cmdPrivKey
   nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
   -- encode
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
-  auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
-  b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
+  -- serviceAuth is False here – proxied commands are not used with service certificates
+  auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey nonce tForAuth
+  b <- case batchTransmissions serverThParams [Right (auth, tToSend)] of
     [] -> throwE $ PCETransportError TELargeMsg
     TBError e _ : _ -> throwE $ PCETransportError e
     TBTransmission s _ : _ -> pure s
@@ -1072,8 +1119,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
         -- server interaction errors are thrown directly
         t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
         case tParse serverThParams t' of
-          t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
-            (_auth, _signed, (_c, _e, cmd)) -> case cmd of
+          t'' :| [] -> case tDecodeClient serverThParams t'' of
+            (_, _, cmd) -> case cmd of
               Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
               Right r' -> pure $ Right r'
               Left e -> throwE $ PCEResponseError e
@@ -1101,7 +1148,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
   let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
       eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
   -- send
-  sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case
+  sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
     RRES (EncFwdResponse efr) -> do
       -- unwrap
       r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -1121,11 +1168,11 @@ okSMPCommand cmd c pKey qId =
     OK -> return ()
     r -> throwE $ unexpectedResponse r
 
-okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
 okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
   where
     aCmd = Cmd sParty cmd
-    cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
+    cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
     process (Response _ r) = case r of
       Right OK -> Right ()
       Right r' -> Left $ unexpectedResponse r'
@@ -1140,8 +1187,8 @@ type PCTransmission err msg = (Either TransportError SentRawTransmission, Reques
 
 -- | Send multiple commands with batching and collect responses
 sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
-sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
-  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+sendProtocolCommands c@ProtocolClient {thParams} cs = do
+  bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
   validate . concat =<< mapM (sendBatch c) bs
   where
     validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
@@ -1157,8 +1204,8 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz
         diff = L.length cs - length rs
 
 streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
-streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
-  bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+streamProtocolCommands c@ProtocolClient {thParams} cs cb = do
+  bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
   mapM_ (cb <=< sendBatch c) bs
 
 sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
@@ -1187,8 +1234,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
 --
 -- Please note: if nonce is passed it is also used as a correlation ID
 sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
-sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd =
-  ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
+sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nonce_ tOut pKey entId cmd =
+  ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd)
   where
     -- two separate "atomically" needed to avoid blocking
     sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
@@ -1201,8 +1248,8 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
             response <$> getResponse c tOut r
         where
           s
-            | batch = tEncodeBatch1 t
-            | otherwise = tEncode t
+            | batch = tEncodeBatch1 serviceAuth t
+            | otherwise = tEncode serviceAuth t
 
 nonBlockingWriteTBQueue :: TBQueue a -> a -> IO ()
 nonBlockingWriteTBQueue q x = do
@@ -1222,14 +1269,14 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} t
       Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout
   pure Response {entityId, response}
 
-mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
+mkTransmission :: Protocol v err msg => ProtocolClient v err msg ->  ClientCommand msg -> IO (PCTransmission err msg)
 mkTransmission c = mkTransmission_ c Nothing
 
 mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
-mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, command) = do
+mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (entityId, pKey_, command) = do
   nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command)
-      auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth
+      auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ nonce tForAuth
   r <- mkRequest (CorrId corrId)
   pure ((,tToSend) <$> auth, r)
   where
@@ -1248,18 +1295,25 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC
       atomically $ TM.insert corrId r sentCommands
       pure r
 
-authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TransmissionAuth)
-authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_
+authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations)
+authTransmission thAuth serviceAuth pKey_ nonce t = traverse authenticate pKey_
   where
-    authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
-    authenticate (C.APrivateAuthKey a pk) = case a of
+    authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations
+    authenticate (C.APrivateAuthKey a pk) = (,serviceSig) <$> case a of
       C.SX25519 -> case thAuth of
-        Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t
+        Just THAuthClient {peerServerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t'
         Nothing -> Left TENoServerAuth
       C.SEd25519 -> sign pk
       C.SEd448 -> sign pk
+    -- When command is signed by both entity key and service key,
+    -- entity key must sign over both transmission and service certificate hash,
+    -- to prevent any service substitution via MITM inside TLS.
+    (t', serviceSig) = case clientService =<< thAuth of
+      Just THClientService {serviceCertHash = XV.Fingerprint fp, serviceKey} | serviceAuth ->
+        (fp <> t, Just $ C.sign' serviceKey t) -- service key only needs to sign transmission itself
+      _ -> (t, Nothing)
     sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
-    sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
+    sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t')
 
 data TBQueueInfo = TBQueueInfo
   { qLength :: Int,

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,24 +42,38 @@ 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
@@ -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
@@ -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
   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 $ tcpConnectTimeout `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,7 +386,7 @@ 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
@@ -324,22 +394,22 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE
       logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host 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,87 +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 #-}
 
-removePendingSub :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removePendingSub = removeSub_ . pendingSrvSubs
+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 SMPSub s) -> SMPServer -> SMPSub -> STM ()
+removeSub_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> QueueId -> STM ()
 removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
 
-removeSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
-removeSubscriptions = removeSubs_ . srvSubs
-{-# INLINE removeSubscriptions #-}
+removeActiveSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
+removeActiveSubs = removeSubs_ . activeQueueSubs
+{-# INLINE removeActiveSubs #-}
 
-removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
-removePendingSubs = removeSubs_ . pendingSrvSubs
+removePendingSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
+removePendingSubs = removeSubs_ . pendingQueueSubs
 {-# INLINE removePendingSubs #-}
 
-removeSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
-removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss))
-  where
-    ss = S.fromList $ map (party,) qs
+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

@@ -57,6 +57,7 @@ module Simplex.Messaging.Crypto.Ratchet
     generateSndE2EParams,
     initialPQEncryption,
     connPQEncryption,
+    joinContactInitialKeys,
     replyKEM_,
     pqSupportToEnc,
     pqEncToSupport,
@@ -308,7 +309,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
@@ -851,32 +852,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 +1195,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/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
@@ -146,6 +152,18 @@ instance StrEncoding UTCTime where
   strEncode = B.pack . iso8601Show
   strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n' || c == ',' || c == ';')
 
+instance StrEncoding X.CertificateChain where
+  strEncode = (\(X.CertificateChainRaw blobs) -> strEncodeList blobs) . X.encodeCertificateChain
+  {-# INLINE strEncode #-}
+  strP = either (fail . show) pure . X.decodeCertificateChain . X.CertificateChainRaw =<< strListP
+  {-# INLINE strP #-}
+
+instance StrEncoding XV.Fingerprint where
+  strEncode (XV.Fingerprint s) = strEncode s
+  {-# INLINE strEncode #-}
+  strP = XV.Fingerprint <$> strP
+  {-# INLINE strP #-}
+
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
 strEncodeList = B.intercalate "," . map strEncode

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,7 +24,7 @@ type NtfClientError = ProtocolClientError ErrorType
 
 defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
 defaultNTFClientConfig =
-  (defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange)
+  (defaultClientConfig (Just alpnSupportedNTFHandshakes) False supportedClientNTFVRange)
     {defaultTransport = ("443", transport @TLS)}
 {-# INLINE defaultNTFClientConfig #-}
 
@@ -62,7 +62,7 @@ ntfCreateSubscription c pKey newSub =
 ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
 ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c 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'
@@ -77,7 +77,7 @@ ntfCheckSubscription c pKey subId =
 ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
 ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c 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'

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,6 +521,7 @@ instance Encoding NtfSubStatus where
       "END" -> pure NSEnd
       "DELETED" -> pure NSDeleted
       "AUTH" -> pure NSAuth
+      "SERVICE" -> pure NSService
       "ERR" -> NSErr <$> (A.space *> A.takeByteString)
       _ -> fail "bad NtfSubStatus"
 

src/Simplex/Messaging/Notifications/Server.hs

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

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

@@ -17,10 +17,11 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
-import Data.X509.Validation (Fingerprint (..))
+import qualified Data.X509.Validation as XV
 import Network.Socket
 import qualified Network.TLS as TLS
 import Numeric.Natural
+import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
@@ -31,7 +32,7 @@ import Simplex.Messaging.Notifications.Server.Store.Postgres
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
 import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
-import Simplex.Messaging.Protocol (BasicAuth, CorrId, 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 (..))
@@ -39,21 +40,20 @@ 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.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,
@@ -61,6 +61,8 @@ data NtfServerConfig = NtfServerConfig
     inactiveClientExpiration :: Maybe ExpirationConfig,
     dbStoreConfig :: PostgresStoreCfg,
     ntfCredentials :: ServerCredentials,
+    -- send service credentials and use service subscriptions when SMP server supports them
+    useServiceCreds :: Bool,
     periodicNtfsInterval :: Int, -- seconds
     -- stats config - see SMP server config
     logStatsInterval :: Maybe Int64,
@@ -94,14 +96,23 @@ data NtfEnv = NtfEnv
   }
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, startOptions} = do
+newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
   when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
   random <- C.newRandom
   store <- newNtfDbStore dbStoreConfig
-  subscriber <- newNtfSubscriber subQSize smpAgentCfg random
-  pushServer <- newNtfPushServer pushQSize apnsConfig
   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, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
   where
@@ -116,26 +127,26 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriberVar,
     subscriberSeq :: TVar Int,
-    smpAgent :: SMPClientAgent
+    smpAgent :: SMPClientAgent 'NotifierService
   }
 
 type SMPSubscriberVar = SessionVar SMPSubscriber
 
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
-newNtfSubscriber qSize smpAgentCfg random = do
+newNtfSubscriber :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
+newNtfSubscriber smpAgentCfg random = do
   smpSubscribers <- TM.emptyIO
   subscriberSeq <- newTVarIO 0
-  smpAgent <- newSMPClientAgent smpAgentCfg random
+  smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg random
   pure NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent}
 
 data SMPSubscriber = SMPSubscriber
   { smpServer :: SMPServer,
-    subscriberSubQ :: TQueue (NonEmpty ServerNtfSub),
+    subscriberSubQ :: TQueue ServerNtfSub,
     subThreadId :: Weak ThreadId
   }
 
 data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (NtfTknRec, PushNotification),
+  { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
     pushClients :: TMap PushProvider PushProviderClient,
     apnsConfig :: APNSPushClientConfig
   }

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

@@ -27,7 +27,7 @@ import Options.Applicative
 import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
-import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), 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.Notifications.Protocol (NtfTokenId)
@@ -37,7 +37,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientCo
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
-import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
+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 (..))
@@ -46,9 +46,9 @@ import Simplex.Messaging.Server.Main (strParse)
 import Simplex.Messaging.Server.Main.Init (iniDbOpts)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Server.StoreLog (closeStoreLog)
-import Simplex.Messaging.Transport (ATransport, simplexMQVersion)
+import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
+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)
@@ -99,9 +99,9 @@ ntfServerCLI cfgPath logPath =
               restoreServerLastNtfs stmStore defaultLastNtfsFile
               let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
               ps <- newNtfDbStore storeCfg
-              (tCnt, sCnt, nCnt) <- importNtfSTMStore ps stmStore skipTokens
+              (tCnt, sCnt, nCnt, serviceCnt) <- importNtfSTMStore ps stmStore skipTokens
               renameFile storeLogFile $ storeLogFile <> ".bak"
-              putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications."
+              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
@@ -195,6 +195,8 @@ 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"
@@ -233,7 +235,6 @@ ntfServerCLI cfgPath logPath =
               subIdBytes = 24,
               regCodeBytes = 32,
               clientQSize = 64,
-              subQSize = 2048,
               pushQSize = 32768,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
@@ -245,6 +246,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
                               }
                         },
@@ -266,6 +268,7 @@ ntfServerCLI cfgPath logPath =
                     privateKeyFile = c serverKeyFile,
                     certificateFile = c serverCrtFile
                   },
+              useServiceCreds = fromMaybe False $ iniOnOff "SUBSCRIBER" "use_service_credentials" ini,
               periodicNtfsInterval = 5 * 60, -- 5 minutes
               logStatsInterval = logStats $> 86400, -- seconds
               logStatsStartTime = 0, -- seconds from 00:00 UTC
@@ -275,9 +278,10 @@ ntfServerCLI cfgPath logPath =
               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)
+                  False,
               startOptions
             }
     iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
@@ -287,7 +291,7 @@ ntfServerCLI cfgPath logPath =
       putStrLn "Configure notification server storage."
       exitFailure
 
-printNtfServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
+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

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

@@ -17,6 +17,7 @@ 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,
@@ -36,8 +37,10 @@ data NtfRealTimeMetrics = NtfRealTimeMetrics
     srvSubscribers :: NtfSMPWorkerMetrics,
     srvClients :: NtfSMPWorkerMetrics,
     srvSubWorkers :: NtfSMPWorkerMetrics,
-    ntfActiveSubs :: NtfSMPSubMetrics,
-    ntfPendingSubs :: NtfSMPSubMetrics,
+    ntfActiveServiceSubs :: NtfSMPSubMetrics,
+    ntfActiveQueueSubs :: NtfSMPSubMetrics,
+    ntfPendingServiceSubs :: NtfSMPSubMetrics,
+    ntfPendingQueueSubs :: NtfSMPSubMetrics,
     smpSessionCount :: Int,
     apnsPushQLength :: Natural
   }
@@ -57,8 +60,10 @@ ntfPrometheusMetrics sm rtm ts =
         srvSubscribers,
         srvClients,
         srvSubWorkers,
-        ntfActiveSubs,
-        ntfPendingSubs,
+        ntfActiveServiceSubs,
+        ntfActiveQueueSubs,
+        ntfPendingServiceSubs,
+        ntfPendingQueueSubs,
         smpSessionCount,
         apnsPushQLength
       } = rtm
@@ -71,8 +76,13 @@ ntfPrometheusMetrics sm rtm ts =
         _subCreated,
         _subDeleted,
         _ntfReceived,
+        _ntfReceivedAuth,
         _ntfDelivered,
         _ntfFailed,
+        _ntfReceivedOwn,
+        _ntfReceivedAuthOwn,
+        _ntfDeliveredOwn,
+        _ntfFailedOwn,
         _ntfCronDelivered,
         _ntfCronFailed,
         _ntfVrfQueued,
@@ -148,8 +158,10 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_subscriptions_approx_total gauge\n\
       \simplex_ntf_subscriptions_approx_total " <> mshow approxSubCount <> "\n# approxSubCount\n\
       \\n"
-      <> showSubMetric ntfActiveSubs "simplex_ntf_smp_subscription_active_" "Active"
-      <> showSubMetric ntfPendingSubs "simplex_ntf_smp_subscription_pending_" "Pending"
+      <> 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\
@@ -158,6 +170,10 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_notifications_received counter\n\
       \simplex_ntf_notifications_received " <> mshow _ntfReceived <> "\n# ntfReceived\n\
       \\n\
+      \# HELP simplex_ntf_notifications_received_auth Received notifications without token or subscription (AUTH error)\n\
+      \# TYPE simplex_ntf_notifications_received_auth counter\n\
+      \simplex_ntf_notifications_received_auth " <> mshow _ntfReceivedAuth <> "\n# ntfReceivedAuth\n\
+      \\n\
       \# HELP simplex_ntf_notifications_delivered Delivered notifications\n\
       \# TYPE simplex_ntf_notifications_delivered counter\n\
       \simplex_ntf_notifications_delivered " <> mshow _ntfDelivered <> "\n# ntfDelivered\n\
@@ -194,6 +210,10 @@ ntfPrometheusMetrics sm rtm ts =
       \# TYPE simplex_ntf_notifications_total gauge\n\
       \simplex_ntf_notifications_total " <> mshow lastNtfCount <> "\n# lastNtfCount\n\
       \\n"
+      <> showNtfsByServer _ntfReceivedOwn "simplex_ntf_notifications_received_own" "Received notifications" "ntfReceivedOwn"
+      <> showNtfsByServer _ntfReceivedAuthOwn "simplex_ntf_notifications_received_auth_own" "Received notifications without token or subscription (AUTH error)" "ntfReceivedAuthOwn"
+      <> showNtfsByServer _ntfDeliveredOwn "simplex_ntf_notifications_delivered_own" "Delivered notifications" "ntfDeliveredOwn"
+      <> showNtfsByServer _ntfFailedOwn "simplex_ntf_notifications_failed_own" "Failed notifications" "ntfFailedOwn"
     info =
       "# Info\n\
       \# ----\n\
@@ -221,32 +241,45 @@ ntfPrometheusMetrics sm rtm ts =
       showOwnSrvSubs <> showOtherSrvSubs
       where
         showOwnSrvSubs
-          | M.null ownSrvSubs = showOwn_ "" 0 0
-          | otherwise = T.concat $ map (\(host, cnt) -> showOwn_ (metricHost host) 1 cnt) $ M.assocs ownSrvSubs
-        showOwn_ param srvCnt subCnt =
-          gaugeMetric (mPfx <> "server_count_own") param srvCnt (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server"
-            <> gaugeMetric (mPfx <> "sub_count_own") param subCnt (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count"
+          | 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 =
-          gaugeMetric (mPfx <> "server_count_other") "" otherServers (descrPfx <> " SMP subscriptions, other server count") "otherServers"
-            <> gaugeMetric (mPfx <> "sub_count_other") "" otherSrvSubCount (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount"
+          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 = showOwn_ "" 0
-          | otherwise = T.concat $ map (\host -> showOwn_ (metricHost host) 1) ownServers
-        showOwn_ param cnt = gaugeMetric (mPfx <> "count_own") param cnt (descrPfx <> " count for own servers") "ownServers"
-        showOtherServers = gaugeMetric (mPfx <> "count_other") "" otherServers (descrPfx <> " count for other servers") "otherServers"
-    gaugeMetric :: Text -> Text -> Int -> Text -> Text -> Text
-    gaugeMetric name param value descr codeRef =
+          | 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\
-      \" <> name <> param <> " " <> mshow value <> "\n# " <> codeRef <> "\n\
-      \\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 = T.pack a <> " " <> tsEpoch
+    mstr a = a <> " " <> tsEpoch
     mshow :: Show a => a -> Text
-    mshow = mstr . show
-    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    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/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,7 +24,7 @@ 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
@@ -37,7 +37,8 @@ data NtfSTMStore = NtfSTMStore
     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
   }
 
 newNtfSTMStore :: IO NtfSTMStore
@@ -48,21 +49,22 @@ newNtfSTMStore = do
   tokenSubscriptions <- TM.emptyIO
   subscriptionLookup <- TM.emptyIO
   tokenLastNtfs <- TM.emptyIO
-  pure NtfSTMStore {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,7 +76,8 @@ data NtfSubData = NtfSubData
     smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
-    subStatus :: TVar NtfSubStatus
+    subStatus :: TVar NtfSubStatus,
+    ntfServiceAssoc :: TVar Bool
   }
 
 ntfSubServer :: NtfSubData -> SMPServer
@@ -183,6 +186,10 @@ stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
       whenM (TM.member tknId tokens) $
         TM.insertM tknId (newTVar [ntf]) tokenLastNtfs
 
+stmSetNtfService :: NtfSTMStore -> SMPServer -> Maybe ServiceId -> STM ()
+stmSetNtfService (NtfSTMStore {ntfServices}) srv serviceId =
+  maybe (TM.delete srv) (TM.insert srv) serviceId ntfServices
+
 data TokenNtfMessageRecord = TNMRv1 NtfTokenId PNMessageData
 
 instance StrEncoding TokenNtfMessageRecord where

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

@@ -11,7 +11,8 @@ import Text.RawString.QQ (r)
 
 ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
 ntfServerSchemaMigrations =
-  [ ("20250417_initial", m20250417_initial, Nothing)
+  [ ("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
@@ -79,3 +80,27 @@ CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscr
 
 CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
     |]
+
+m20250517_service_cert :: Text
+m20250517_service_cert =
+  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

@@ -37,7 +37,7 @@ import Data.List (findIndex, foldl')
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -63,7 +63,7 @@ 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, pattern SMPServer)
+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 (..))
@@ -237,32 +237,43 @@ updateTknCronInterval st tknId cronInt =
 
 -- Reads servers that have subscriptions that need subscribing.
 -- It is executed on server start, and it is supposed to crash on database error
-getUsedSMPServers :: NtfPostgresStore -> IO [SMPServer]
-getUsedSMPServers st = 
+getUsedSMPServers :: NtfPostgresStore -> IO [(SMPServer, Int64, Maybe (ServiceId, Int64))]
+getUsedSMPServers st =
   withTransaction (dbStore st) $ \db ->
-    map rowToSrv <$>
+    map rowToSrvSubs <$>
       DB.query
         db
         [sql|
-          SELECT p.smp_host, p.smp_port, p.smp_keyhash
+          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
-          WHERE EXISTS (
-            SELECT 1 FROM subscriptions s
-            WHERE s.smp_server_id = p.smp_server_id
-              AND s.status IN ?
-          )
+          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 -> SMPServer -> Maybe NtfSubscriptionId -> Int -> IO (Either ErrorType [ServerNtfSub])
-getServerNtfSubscriptions st srv afterSubId_ count =
+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) (srvToRow srv :. (statusIn, count))
+          DB.query db (query <> orderLimit) (srvId, statusIn, count)
         Just afterSubId ->
-          DB.query db (query <> " AND s.subscription_id > ?" <> orderLimit) (srvToRow srv :. (statusIn, afterSubId, count))
+          DB.query db (query <> " AND subscription_id > ?" <> orderLimit) (srvId, statusIn, afterSubId, count)
     void $
       DB.executeMany
         db
@@ -278,13 +289,11 @@ getServerNtfSubscriptions st srv afterSubId_ count =
   where
     query =
       [sql|
-        SELECT s.subscription_id, s.smp_notifier_id, s.smp_notifier_key
-        FROM subscriptions s
-        JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
-        WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ?
-          AND s.status IN ?
+        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 s.subscription_id LIMIT ?"
+    orderLimit = " ORDER BY subscription_id LIMIT ?"
     statusIn = In [NSNew, NSPending, NSActive, NSInactive]
     toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey))
 
@@ -301,7 +310,7 @@ findNtfSubscription st tknId q =
         DB.query
           db
           [sql|
-            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status
+            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 = ?
@@ -320,33 +329,33 @@ getNtfSubscription st subId =
           db
           [sql|
             SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at,
-              s.subscription_id, s.smp_notifier_key, s.status,
+              s.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)
+type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus, NtfAssociatedService)
 
 rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec)
-rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus) :. qRow)  =
+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})
+   in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc})
 
 rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec
-rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus)) =
-  NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}
+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}
+  NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey, ntfServiceAssoc = False}
 
 updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ())
 updateTknStatus st tkn status =
@@ -408,14 +417,14 @@ addNtfSubscription st sub =
         getServer =
           maybeFirstRow fromOnly $
             DB.query
-              db 
+              db
               [sql|
                 SELECT smp_server_id
                 FROM smp_servers
                 WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
               |]
               (srvToRow srv)
-        insertServer = 
+        insertServer =
           firstRow fromOnly (STORE "error inserting SMP server when adding subscription") $
             DB.query
               db
@@ -430,13 +439,13 @@ addNtfSubscription st sub =
 insertNtfSubQuery :: Query
 insertNtfSubQuery =
   [sql|
-    INSERT INTO subscriptions (token_id, smp_server_id, smp_notifier_id, subscription_id, smp_notifier_key, status)
-    VALUES (?,?,?,?,?,?)
+    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} =
-  (tokenId, srvId, nId) :. (ntfSubId, notifierKey, subStatus)
+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 =
@@ -445,11 +454,27 @@ deleteNtfSubscription st subId =
       DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId)
     withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId)
 
+updateSubStatus :: NtfPostgresStore -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
+updateSubStatus st nId status =
+  withFastDB' "updateSubStatus" st $ \db -> do
+    sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
+      maybeFirstRow id $
+        DB.query
+          db
+          [sql|
+            UPDATE subscriptions SET status = ?
+            WHERE smp_notifier_id = ? AND status != ?
+            RETURNING subscription_id, ntf_service_assoc
+          |]
+          (status, 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
-    subId_ :: Maybe NtfSubscriptionId <-
-      maybeFirstRow fromOnly $
+    sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
+      maybeFirstRow id $
         DB.query
           db
           [sql|
@@ -459,57 +484,41 @@ updateSrvSubStatus st q status =
             WHERE p.smp_server_id = s.smp_server_id
               AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ?
               AND s.status != ?
-            RETURNING s.subscription_id
+            RETURNING s.subscription_id, s.ntf_service_assoc
           |]
           (Only status :. smpQueueToRow q :. Only status)
-    forM_ subId_ $ \subId -> 
-      withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl subId status
+    forM_ sub_ $ \(subId, serviceAssoc) ->
+      withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
 
-batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> NonEmpty NotifierId -> NtfSubStatus -> IO Int64
-batchUpdateSrvSubStatus st srv nIds status =
-  batchUpdateStatus_ st srv $ \srvId ->
-    -- without executeMany
-    -- L.toList $ L.map (status,srvId,,status) nIds
-    L.toList $ L.map (status,srvId,) nIds
-
-batchUpdateSrvSubStatuses :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int64
-batchUpdateSrvSubStatuses st srv subs =
-  batchUpdateStatus_ st srv $ \srvId ->
-    -- without executeMany
-    -- L.toList $ L.map (\(nId, status) -> (status, srvId, nId, status)) subs
-    L.toList $ L.map (\(nId, status) -> (status, srvId, nId)) subs
-
--- without executeMany
--- batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId, NtfSubStatus)]) -> IO Int64
-batchUpdateStatus_ :: NtfPostgresStore -> SMPServer -> (Int64 -> [(NtfSubStatus, Int64, NotifierId)]) -> IO Int64
-batchUpdateStatus_ st srv mkParams =
-  fmap (fromRight (-1)) $ withDB "batchUpdateStatus_" st $ \db -> runExceptT $ do
-    srvId <- ExceptT $ getSMPServerId db
-    let params = mkParams srvId
-    subs <-
-      liftIO $
-        DB.returning
+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|
-            UPDATE subscriptions s
-            SET status = upd.status
-            FROM (VALUES(?, ?, ?)) AS upd(status, smp_server_id, smp_notifier_id)
-            WHERE s.smp_server_id = upd.smp_server_id
-              AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA)
-              AND s.status != upd.status
-            RETURNING s.subscription_id, s.status
+            SELECT smp_server_id, ntf_service_id
+            FROM smp_servers
+            WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
+            FOR UPDATE
           |]
-          params
-    -- TODO [ntfdb] below is equivalent without using executeMany.
-    -- executeMany "works", and logs updates.
-    -- We do not have tests that validate correct subscription status,
-    -- and the potential problem is BYTEA conversation - VALUES are inserted as TEXT in this case for some reason.
-    -- subs <-
-    --   liftIO $ fmap catMaybes $ forM params $
-    --     maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ? RETURNING subscription_id, status"
-    -- logWarn $ "batchUpdateStatus_: " <> tshow (length subs)
-    withLog "batchUpdateStatus_" st $ forM_ subs . uncurry . logSubscriptionStatus
-    pure $ fromIntegral $ length subs
+          (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 $
@@ -522,31 +531,47 @@ batchUpdateStatus_ st srv mkParams =
           |]
           (srvToRow srv)
 
-batchUpdateSubStatus :: NtfPostgresStore -> NonEmpty ServerNtfSub -> NtfSubStatus -> IO Int64
-batchUpdateSubStatus st subs status =
-  fmap (fromRight (-1)) $ withFastDB' "batchUpdateSubStatus" st $ \db -> do
-    let params = L.toList $ L.map (\(subId, _) -> (status, subId)) subs
-    subIds <-
-      DB.returning
-        db
-        [sql|
-          UPDATE subscriptions s
-          SET status = upd.status
-          FROM (VALUES(?, ?)) AS upd(status, subscription_id)
-          WHERE s.subscription_id = (upd.subscription_id :: BYTEA)
-            AND s.status != upd.status
-          RETURNING s.subscription_id
-        |]
-        params
-    -- TODO [ntfdb] below is equivalent without using executeMany - see comment above.
-    -- let params = L.toList $ L.map (\NtfSubRec {ntfSubId} -> (status, ntfSubId, status)) subs
-    -- subIds <-
-    --   fmap catMaybes $ forM params $
-    --     maybeFirstRow id . DB.query db "UPDATE subscriptions SET status = ? WHERE subscription_id = ? AND status != ? RETURNING subscription_id"
-    -- logWarn $ "batchUpdateSubStatus: " <> tshow (length subIds)
-    withLog "batchUpdateSubStatus" st $ \sl ->
-      forM_ subIds $ \(Only subId) -> logSubscriptionStatus sl subId status
-    pure $ fromIntegral $ length subIds
+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 =
@@ -626,15 +651,16 @@ getEntityCounts st =
     pure (tCnt, sCnt, nCnt)
   where
     count (Only n : _) = n
-    count [] = 0    
+    count [] = 0
 
-importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, Int64, Int64)
+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
-  pure (tCnt, sCnt, nCnt)
+  serviceCnt <- importNtfServiceIds
+  pure (tCnt, sCnt, nCnt, serviceCnt)
   where
     importTokens = do
       allTokens <- M.elems <$> readTVarIO (tokens stmStore)
@@ -697,7 +723,7 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
         filterSubs allSubs = do
           let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs
               skipped = length allSubs - length subs
-          when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens" 
+          when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens"
           let (removedSubTokens, removeSubs, dupQueues) = foldl' addSubToken (S.empty, S.empty, S.empty) subs
           unless (null removeSubs) $ putStrLn $ "Skipped " <> show (S.size removeSubs) <> " duplicate subscriptions of " <> show (S.size removedSubTokens) <> " tokens for " <> show (S.size dupQueues) <> " queues"
           pure $ filter (\NtfSubData {ntfSubId} -> S.notMember ntfSubId removeSubs) subs
@@ -761,10 +787,22 @@ importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
               else (S.insert tId stIds, cnt', acc)
           where
             ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of
-              Just ntfSubId -> 
+              Just ntfSubId ->
                 let row = (tId, ntfSubId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta)
                  in (qs, row : rows)
               Nothing -> (S.insert smpQueue qs, rows)
+    importNtfServiceIds = do
+      ss <- M.assocs <$> readTVarIO (ntfServices stmStore)
+      withConnection s $ \db -> DB.executeMany db serviceQuery $ map serviceToRow ss
+      where
+        serviceQuery =
+          [sql|
+            INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash, ntf_service_id)
+            VALUES (?, ?, ?, ?)
+            ON CONFLICT (smp_host, smp_port, smp_keyhash)
+            DO UPDATE SET ntf_service_id = EXCLUDED.ntf_service_id
+          |]
+        serviceToRow (srv, serviceId) = srvToRow srv :. Only serviceId
     checkCount name expected inserted
       | fromIntegral expected == inserted = do
           putStrLn $ "Imported " <> show inserted <> " " <> name <> "s."
@@ -799,15 +837,15 @@ exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFi
       where
         ntfSubQuery =
           [sql|
-            SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status,
+            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) :. qRow)  =
+        toNtfSub (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow)  =
           let smpQueue = rowToSMPQueue qRow
-           in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}
+           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) ->
@@ -825,32 +863,32 @@ exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFi
           |]
         encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n'
 
-withFastDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
+withFastDB' :: Text -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
 withFastDB' op st action = withFastDB op st $ fmap Right . action
 {-# INLINE withFastDB' #-}
 
-withDB' :: String -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
+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. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+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. String -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+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. String -> NtfPostgresStore -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+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: " <> 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 -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog :: MonadIO m => Text -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
 withLog op NtfPostgresStore {dbStoreLog} = withLog_ op dbStoreLog
 {-# INLINE withLog #-}
 

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

@@ -9,6 +9,7 @@ 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
@@ -77,30 +78,36 @@ data NtfSubRec = NtfSubRec
     smpQueue :: SMPQueueNtf,
     notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus
+    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} = do
+mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
   subStatus <- newTVarIO status
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
+  ntfServiceAssoc <- newTVarIO serviceAssoc
+  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
 
 mkSubRec :: NtfSubData -> IO NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
+mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
   subStatus <- readTVarIO status
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
+  ntfServiceAssoc <- readTVarIO serviceAssoc
+  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
 
 instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
+  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
+        "subStatus=" <> strEncode subStatus,
+        "serviceAssoc=" <> strEncode ntfServiceAssoc
       ]
   strP = do
     ntfSubId <- "subId=" *> strP_
@@ -108,4 +115,5 @@ instance StrEncoding NtfSubRec where
     notifierKey <- "notifierKey=" *> strP_
     tokenId <- "tknId=" *> strP_
     subStatus <- "subStatus=" *> strP
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
+    ntfServiceAssoc <- fromMaybe False <$> optional (" serviceAssoc=" *> strP)
+    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}

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

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

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

@@ -24,17 +24,21 @@ module Simplex.Messaging.Notifications.Server.StoreLog
   )
 where
 
+import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Base64.URL as B64
 import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
 import Data.Word (Word16)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.Store.Types
-import Simplex.Messaging.Protocol (EntityId (..))
+import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
 import System.IO
@@ -47,8 +51,9 @@ data NtfStoreLogRecord
   | DeleteToken NtfTokenId
   | UpdateTokenTime NtfTokenId RoundedSystemTime
   | CreateSubscription NtfSubRec
-  | SubscriptionStatus NtfSubscriptionId NtfSubStatus
+  | SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
   | DeleteSubscription NtfSubscriptionId
+  | SetNtfService SMPServer (Maybe ServiceId)
   deriving (Show)
 
 instance StrEncoding NtfStoreLogRecord where
@@ -60,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),
@@ -71,8 +79,9 @@ 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))
       ]
 
 logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
@@ -100,12 +109,15 @@ logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
 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
 
+logSetNtfService :: StoreLog 'WriteMode -> SMPServer -> Maybe ServiceId -> IO ()
+logSetNtfService s srv serviceId = logNtfStoreRecord s $ SetNtfService srv serviceId
+
 readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
 readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore
 
@@ -147,13 +159,19 @@ readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
               Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId
             where
               enc = B64.encode . unEntityId
-          SubscriptionStatus subId status -> do
-            stmGetNtfSubscriptionIO st subId
-              >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
+          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 -> NtfSTMStore -> IO ()
-writeNtfStore s NtfSTMStore {tokens, subscriptions} = do
+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/Protocol.hs

@@ -66,7 +66,10 @@ module Simplex.Messaging.Protocol
     EncDataBytes (..),
     Party (..),
     Cmd (..),
-    DirectParty,
+    QueueParty,
+    BatchParty,
+    ServiceParty,
+    ASubscriberParty (..),
     BrokerMsg (..),
     SParty (..),
     PartyI (..),
@@ -78,11 +81,13 @@ module Simplex.Messaging.Protocol
     BrokerErrorType (..),
     BlockingInfo (..),
     BlockingReason (..),
+    RawTransmission,
     Transmission,
+    TAuthorizations,
     TransmissionAuth (..),
     SignedTransmission,
+    SignedTransmissionOrError,
     SentRawTransmission,
-    SignedRawTransmission,
     ClientMsgEnvelope (..),
     PubHeader (..),
     ClientMessage (..),
@@ -116,6 +121,7 @@ module Simplex.Messaging.Protocol
     SenderId,
     LinkId,
     NotifierId,
+    ServiceId,
     RcvPrivateAuthKey,
     RcvPublicAuthKey,
     RcvPublicDhKey,
@@ -149,6 +155,11 @@ module Simplex.Messaging.Protocol
     currentSMPClientVersion,
     senderCanSecure,
     queueReqMode,
+    queueParty,
+    batchParty,
+    serviceParty,
+    partyClientRole,
+    partyServiceRole,
     userProtocol,
     rcvMessageMeta,
     noMsgFlags,
@@ -180,9 +191,11 @@ module Simplex.Messaging.Protocol
     TransportBatch (..),
     tPut,
     tPutLog,
-    tGet,
+    tGetServer,
+    tGetClient,
     tParse,
-    tDecodeParseValidate,
+    tDecodeServer,
+    tDecodeClient,
     tEncode,
     tEncodeBatch1,
     batchTransmissions,
@@ -197,30 +210,30 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Exception (Exception)
-import Control.Monad
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
 import Data.Constraint (Dict (..))
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (isJust, isNothing)
 import Data.String
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
 import Data.Type.Equality
 import Data.Word (Word16)
-import qualified Data.X509 as X
 import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import qualified GHC.TypeLits as TE
 import qualified GHC.TypeLits as Type
@@ -297,46 +310,154 @@ e2eEncMessageLength :: Int
 e2eEncMessageLength = 16000 -- 15988 .. 16005
 
 -- | SMP protocol clients
-data Party = Recipient | Sender | Notifier | LinkClient | ProxiedClient
+data Party
+  = Creator
+  | Recipient
+  | RecipientService
+  | Sender
+  | IdleClient
+  | Notifier
+  | NotifierService
+  | LinkClient
+  | ProxiedClient
+  | ProxyService
   deriving (Show)
 
 -- | Singleton types for SMP protocol clients
 data SParty :: Party -> Type where
+  SCreator :: SParty Creator
   SRecipient :: SParty Recipient
+  SRecipientService :: SParty RecipientService
   SSender :: SParty Sender
+  SIdleClient :: SParty IdleClient
   SNotifier :: SParty Notifier
-  SSenderLink :: SParty LinkClient 
+  SNotifierService :: SParty NotifierService
+  SSenderLink :: SParty LinkClient
   SProxiedClient :: SParty ProxiedClient
+  SProxyService :: SParty ProxyService
 
 instance TestEquality SParty where
+  testEquality SCreator SCreator = Just Refl
   testEquality SRecipient SRecipient = Just Refl
+  testEquality SRecipientService SRecipientService = Just Refl
   testEquality SSender SSender = Just Refl
+  testEquality SIdleClient SIdleClient = Just Refl
   testEquality SNotifier SNotifier = Just Refl
+  testEquality SNotifierService SNotifierService = Just Refl
   testEquality SSenderLink SSenderLink = Just Refl
   testEquality SProxiedClient SProxiedClient = Just Refl
+  testEquality SProxyService SProxyService = Just Refl
   testEquality _ _ = Nothing
 
 deriving instance Show (SParty p)
 
 class PartyI (p :: Party) where sParty :: SParty p
 
+instance PartyI Creator where sParty = SCreator
+
 instance PartyI Recipient where sParty = SRecipient
 
+instance PartyI RecipientService where sParty = SRecipientService
+
 instance PartyI Sender where sParty = SSender
 
+instance PartyI IdleClient where sParty = SIdleClient
+
 instance PartyI Notifier where sParty = SNotifier
 
+instance PartyI NotifierService where sParty = SNotifierService
+
 instance PartyI LinkClient where sParty = SSenderLink
 
 instance PartyI ProxiedClient where sParty = SProxiedClient
 
-type family DirectParty (p :: Party) :: Constraint where
-  DirectParty Recipient = ()
-  DirectParty Sender = ()
-  DirectParty Notifier = ()
-  DirectParty LinkClient = ()
-  DirectParty p =
-    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not direct"))
+instance PartyI ProxyService where sParty = SProxyService
+
+-- command parties that can read queues
+type family QueueParty (p :: Party) :: Constraint where
+  QueueParty Recipient = ()
+  QueueParty Sender = ()
+  QueueParty Notifier = ()
+  QueueParty LinkClient = ()
+  QueueParty p =
+    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not QueueParty"))
+
+queueParty :: SParty p -> Maybe (Dict (PartyI p, QueueParty p))
+queueParty = \case
+  SRecipient -> Just Dict
+  SSender -> Just Dict
+  SSenderLink -> Just Dict
+  SNotifier -> Just Dict
+  _ -> Nothing
+{-# INLINE queueParty #-}
+
+type family BatchParty (p :: Party) :: Constraint where
+  BatchParty Recipient = ()
+  BatchParty Notifier = ()
+  BatchParty p =
+    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not BatchParty"))
+
+batchParty :: SParty p -> Maybe (Dict (PartyI p, BatchParty p))
+batchParty = \case
+  SRecipient -> Just Dict
+  SNotifier -> Just Dict
+  _ -> Nothing
+{-# INLINE batchParty #-}
+
+-- command parties that can subscribe to individual queues
+type family ServiceParty (p :: Party) :: Constraint where
+  ServiceParty RecipientService = ()
+  ServiceParty NotifierService = ()
+  ServiceParty p =
+    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not ServiceParty"))
+
+serviceParty :: SParty p -> Maybe (Dict (PartyI p, ServiceParty p))
+serviceParty = \case
+  SRecipientService -> Just Dict
+  SNotifierService -> Just Dict
+  _ -> Nothing
+{-# INLINE serviceParty #-}
+
+data ASubscriberParty = forall p. (PartyI p, ServiceParty p) => ASP (SParty p)
+
+deriving instance Show ASubscriberParty
+
+instance Eq ASubscriberParty where
+  ASP p == ASP p' = isJust $ testEquality p p'
+
+instance Encoding ASubscriberParty where
+  smpEncode = \case
+    ASP SRecipientService -> "R"
+    ASP SNotifierService -> "N"
+  smpP =
+    A.anyChar >>= \case
+      'R' -> pure $ ASP SRecipientService
+      'N' -> pure $ ASP SNotifierService
+      _ -> fail "bad ASubscriberParty"
+
+instance StrEncoding ASubscriberParty where
+  strEncode = smpEncode
+  strP = smpP
+
+partyClientRole :: SParty p -> Maybe SMPServiceRole
+partyClientRole = \case
+  SCreator -> Just SRMessaging
+  SRecipient -> Just SRMessaging
+  SRecipientService -> Just SRMessaging
+  SSender -> Just SRMessaging
+  SIdleClient -> Nothing
+  SNotifier -> Just SRNotifier
+  SNotifierService -> Just SRNotifier
+  SSenderLink -> Just SRMessaging
+  SProxiedClient -> Just SRMessaging
+  SProxyService -> Just SRProxy
+{-# INLINE partyClientRole #-}
+
+partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole
+partyServiceRole = \case
+  SRecipientService -> SRMessaging
+  SNotifierService -> SRNotifier
+{-# INLINE partyServiceRole #-}
 
 -- | Type for client command of any participant.
 data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
@@ -347,13 +468,16 @@ deriving instance Show Cmd
 type Transmission c = (CorrId, EntityId, c)
 
 -- | signed parsed transmission, with original raw bytes and parsing error.
-type SignedTransmission e c = (Maybe TransmissionAuth, Signed, Transmission (Either e c))
+type SignedTransmission c = (Maybe TAuthorizations, Signed, Transmission c)
+
+type SignedTransmissionOrError e c = Either (Transmission e) (SignedTransmission c)
 
 type Signed = ByteString
 
 -- | unparsed SMP transmission with signature.
 data RawTransmission = RawTransmission
   { authenticator :: ByteString, -- signature or encrypted transmission hash
+    serviceSig :: Maybe (C.Signature 'C.Ed25519), -- optional second signature with the key of the client service
     authorized :: ByteString, -- authorized transmission
     sessId :: SessionId,
     corrId :: CorrId,
@@ -362,32 +486,33 @@ data RawTransmission = RawTransmission
   }
   deriving (Show)
 
+type TAuthorizations = (TransmissionAuth, Maybe (C.Signature 'C.Ed25519))
+
 data TransmissionAuth
   = TASignature C.ASignature
   | TAAuthenticator C.CbAuthenticator
   deriving (Show)
 
--- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization
-tAuthBytes :: Maybe TransmissionAuth -> ByteString
-tAuthBytes = \case
-  Nothing -> ""
-  Just (TASignature s) -> C.signatureBytes s
-  Just (TAAuthenticator (C.CbAuthenticator s)) -> s
+-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TransmissionAuth
+tEncodeAuth :: Bool -> Maybe TAuthorizations -> ByteString
+tEncodeAuth serviceAuth = \case
+  Nothing -> smpEncode B.empty
+  Just (auth, sig)
+    | serviceAuth -> smpEncode (authBytes auth, sig)
+    | otherwise -> smpEncode (authBytes auth)
+  where
+    authBytes = \case
+      TASignature s -> C.signatureBytes s
+      TAAuthenticator (C.CbAuthenticator s) -> s
 
-decodeTAuthBytes :: ByteString -> Either String (Maybe TransmissionAuth)
-decodeTAuthBytes s
+decodeTAuthBytes :: ByteString -> Maybe (C.Signature 'C.Ed25519) -> Either String (Maybe TAuthorizations)
+decodeTAuthBytes s serviceSig
   | B.null s = Right Nothing
-  | B.length s == C.cbAuthenticatorSize = Right . Just . TAAuthenticator $ C.CbAuthenticator s
-  | otherwise = Just . TASignature <$> C.decodeSignature s
-
-instance IsString (Maybe TransmissionAuth) where
-  fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature
-
--- | unparsed sent SMP transmission with signature, without session ID.
-type SignedRawTransmission = (Maybe TransmissionAuth, CorrId, EntityId, ByteString)
+  | B.length s == C.cbAuthenticatorSize = Right $ Just (TAAuthenticator (C.CbAuthenticator s), serviceSig)
+  | otherwise = (\sig -> Just (TASignature sig, serviceSig)) <$> C.decodeSignature s
 
 -- | unparsed sent SMP transmission with signature.
-type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
+type SentRawTransmission = (Maybe TAuthorizations, ByteString)
 
 -- | SMP queue ID for the recipient.
 type RecipientId = QueueId
@@ -403,14 +528,6 @@ type LinkId = QueueId
 -- | SMP queue ID on the server.
 type QueueId = 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 ""
-
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
@@ -418,8 +535,10 @@ data Command (p :: Party) where
   -- v6 of SMP servers only support signature algorithm for command authorization.
   -- v7 of SMP servers additionally support additional layer of authenticated encryption.
   -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys.
-  NEW :: NewQueueReq -> Command Recipient
+  NEW :: NewQueueReq -> Command Creator
   SUB :: Command Recipient
+  -- | subscribe all associated queues. Service ID must be used as entity ID, and service session key must sign the command.
+  SUBS :: Command RecipientService
   KEY :: SndPublicAuthKey -> Command Recipient
   RKEY :: NonEmpty RcvPublicAuthKey -> Command Recipient
   LSET :: LinkId -> QueueLinkData -> Command Recipient
@@ -436,12 +555,14 @@ data Command (p :: Party) where
   -- SEND v1 has to be supported for encoding/decoding
   -- SEND :: MsgBody -> Command Sender
   SEND :: MsgFlags -> MsgBody -> Command Sender
-  PING :: Command Sender
+  PING :: Command IdleClient
   -- Client accessing short links
   LKEY :: SndPublicAuthKey -> Command LinkClient
   LGET :: Command LinkClient
   -- SMP notification subscriber commands
   NSUB :: Command Notifier
+  -- | subscribe all associated queues. Service ID must be used as entity ID, and service session key must sign the command.
+  NSUBS :: Command NotifierService
   PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
   -- Transmission to proxy:
   -- - entity ID: ID of the session with relay returned in PKEY (response to PRXY)
@@ -452,7 +573,7 @@ data Command (p :: Party) where
   -- Transmission forwarded to relay:
   -- - entity ID: empty
   -- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission
-  RFWD :: EncFwdTransmission -> Command Sender -- use CorrId as CbNonce, proxy to relay
+  RFWD :: EncFwdTransmission -> Command ProxyService -- use CorrId as CbNonce, proxy to relay
 
 deriving instance Show (Command p)
 
@@ -568,6 +689,10 @@ data BrokerMsg where
   -- SMP broker messages (responses, client messages, notifications)
   IDS :: QueueIdsKeys -> BrokerMsg
   LNK :: SenderId -> QueueLinkData -> BrokerMsg
+  -- | Service subscription success - confirms when queue was associated with the service
+  SOK :: Maybe ServiceId -> BrokerMsg
+  -- | The number of queues subscribed with SUBS command
+  SOKS :: Int64 -> BrokerMsg
   -- MSG v1/2 has to be supported for encoding/decoding
   -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
   -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
@@ -575,10 +700,11 @@ data BrokerMsg where
   NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
   NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
   -- Should include certificate chain
-  PKEY :: SessionId -> VersionRangeSMP -> (X.CertificateChain, X.SignedExact X.PubKey) -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
+  PKEY :: SessionId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
   RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
   PRES :: EncResponse -> BrokerMsg -- proxy to client
   END :: BrokerMsg
+  ENDS :: Int64 -> BrokerMsg
   DELD :: BrokerMsg
   INFO :: QueueInfo -> BrokerMsg
   OK :: BrokerMsg
@@ -770,8 +896,9 @@ noMsgFlags = MsgFlags {notification = False}
 -- * SMP command tags
 
 data CommandTag (p :: Party) where
-  NEW_ :: CommandTag Recipient
+  NEW_ :: CommandTag Creator
   SUB_ :: CommandTag Recipient
+  SUBS_ :: CommandTag RecipientService
   KEY_ :: CommandTag Recipient
   RKEY_ :: CommandTag Recipient
   LSET_ :: CommandTag Recipient
@@ -785,13 +912,14 @@ data CommandTag (p :: Party) where
   QUE_ :: CommandTag Recipient
   SKEY_ :: CommandTag Sender
   SEND_ :: CommandTag Sender
-  PING_ :: CommandTag Sender
+  PING_ :: CommandTag IdleClient
   LKEY_ :: CommandTag LinkClient
   LGET_ :: CommandTag LinkClient
   PRXY_ :: CommandTag ProxiedClient
   PFWD_ :: CommandTag ProxiedClient
-  RFWD_ :: CommandTag Sender
+  RFWD_ :: CommandTag ProxyService
   NSUB_ :: CommandTag Notifier
+  NSUBS_ :: CommandTag NotifierService
 
 data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p)
 
@@ -802,6 +930,8 @@ deriving instance Show CmdTag
 data BrokerMsgTag
   = IDS_
   | LNK_
+  | SOK_
+  | SOKS_
   | MSG_
   | NID_
   | NMSG_
@@ -809,6 +939,7 @@ data BrokerMsgTag
   | RRES_
   | PRES_
   | END_
+  | ENDS_
   | DELD_
   | INFO_
   | OK_
@@ -828,6 +959,7 @@ instance PartyI p => Encoding (CommandTag p) where
   smpEncode = \case
     NEW_ -> "NEW"
     SUB_ -> "SUB"
+    SUBS_ -> "SUBS"
     KEY_ -> "KEY"
     RKEY_ -> "RKEY"
     LSET_ -> "LSET"
@@ -848,12 +980,14 @@ instance PartyI p => Encoding (CommandTag p) where
     PFWD_ -> "PFWD"
     RFWD_ -> "RFWD"
     NSUB_ -> "NSUB"
+    NSUBS_ -> "NSUBS"
   smpP = messageTagP
 
 instance ProtocolMsgTag CmdTag where
   decodeTag = \case
-    "NEW" -> Just $ CT SRecipient NEW_
+    "NEW" -> Just $ CT SCreator NEW_
     "SUB" -> Just $ CT SRecipient SUB_
+    "SUBS" -> Just $ CT SRecipientService SUBS_
     "KEY" -> Just $ CT SRecipient KEY_
     "RKEY" -> Just $ CT SRecipient RKEY_
     "LSET" -> Just $ CT SRecipient LSET_
@@ -867,13 +1001,14 @@ instance ProtocolMsgTag CmdTag where
     "QUE" -> Just $ CT SRecipient QUE_
     "SKEY" -> Just $ CT SSender SKEY_
     "SEND" -> Just $ CT SSender SEND_
-    "PING" -> Just $ CT SSender PING_
+    "PING" -> Just $ CT SIdleClient PING_
     "LKEY" -> Just $ CT SSenderLink LKEY_
     "LGET" -> Just $ CT SSenderLink LGET_
     "PRXY" -> Just $ CT SProxiedClient PRXY_
     "PFWD" -> Just $ CT SProxiedClient PFWD_
-    "RFWD" -> Just $ CT SSender RFWD_
+    "RFWD" -> Just $ CT SProxyService RFWD_
     "NSUB" -> Just $ CT SNotifier NSUB_
+    "NSUBS" -> Just $ CT SNotifierService NSUBS_
     _ -> Nothing
 
 instance Encoding CmdTag where
@@ -887,6 +1022,8 @@ instance Encoding BrokerMsgTag where
   smpEncode = \case
     IDS_ -> "IDS"
     LNK_ -> "LNK"
+    SOK_ -> "SOK"
+    SOKS_ -> "SOKS"
     MSG_ -> "MSG"
     NID_ -> "NID"
     NMSG_ -> "NMSG"
@@ -894,6 +1031,7 @@ instance Encoding BrokerMsgTag where
     RRES_ -> "RRES"
     PRES_ -> "PRES"
     END_ -> "END"
+    ENDS_ -> "ENDS"
     DELD_ -> "DELD"
     INFO_ -> "INFO"
     OK_ -> "OK"
@@ -905,6 +1043,8 @@ instance ProtocolMsgTag BrokerMsgTag where
   decodeTag = \case
     "IDS" -> Just IDS_
     "LNK" -> Just LNK_
+    "SOK" -> Just SOK_
+    "SOKS" -> Just SOKS_
     "MSG" -> Just MSG_
     "NID" -> Just NID_
     "NMSG" -> Just NMSG_
@@ -912,6 +1052,7 @@ instance ProtocolMsgTag BrokerMsgTag where
     "RRES" -> Just RRES_
     "PRES" -> Just PRES_
     "END" -> Just END_
+    "ENDS" -> Just ENDS_
     "DELD" -> Just DELD_
     "INFO" -> Just INFO_
     "OK" -> Just OK_
@@ -1251,7 +1392,8 @@ data QueueIdsKeys = QIK
     sndId :: SenderId,
     rcvPublicDhKey :: RcvPublicDhKey,
     queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
-    linkId :: Maybe LinkId
+    linkId :: Maybe LinkId,
+    serviceId :: Maybe ServiceId
     -- TODO [notifications]
     -- serverNtfCreds :: Maybe ServerNtfCreds
   }
@@ -1321,12 +1463,14 @@ data ErrorType
     AUTH
   | -- | command with the entity that was blocked
     BLOCKED {blockInfo :: BlockingInfo}
+  | -- | service signature is not allowed for command or session; service command is sent not in service session
+    SERVICE
   | -- | encryption/decryption error in proxy protocol
     CRYPTO
   | -- | SMP queue capacity is exceeded on the server
     QUOTA
   | -- | SMP server storage error
-    STORE {storeErr :: String}
+    STORE {storeErr :: Text}
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
   | -- | sent message is too large (> maxMessageLength = 16088 bytes)
@@ -1347,9 +1491,10 @@ instance StrEncoding ErrorType where
     PROXY e -> "PROXY " <> strEncode e
     AUTH -> "AUTH"
     BLOCKED info -> "BLOCKED " <> strEncode info
+    SERVICE -> "SERVICE"
     CRYPTO -> "CRYPTO"
     QUOTA -> "QUOTA"
-    STORE e -> "STORE " <> encodeUtf8 (T.pack e)
+    STORE e -> "STORE " <> encodeUtf8 e
     NO_MSG -> "NO_MSG"
     LARGE_MSG -> "LARGE_MSG"
     EXPIRED -> "EXPIRED"
@@ -1363,9 +1508,10 @@ instance StrEncoding ErrorType where
         "PROXY " *> (PROXY <$> strP),
         "AUTH" $> AUTH,
         "BLOCKED " *> strP,
+        "SERVICE" $> SERVICE,
         "CRYPTO" $> CRYPTO,
         "QUOTA" $> QUOTA,
-        "STORE " *> (STORE . T.unpack . safeDecodeUtf8 <$> A.takeByteString),
+        "STORE " *> (STORE . safeDecodeUtf8 <$> A.takeByteString),
         "NO_MSG" $> NO_MSG,
         "LARGE_MSG" $> LARGE_MSG,
         "EXPIRED" $> EXPIRED,
@@ -1379,7 +1525,7 @@ data CommandError
     UNKNOWN
   | -- | error parsing command
     SYNTAX
-  | -- | command is not allowed (SUB/GET cannot be used with the same queue in the same TCP connection)
+  | -- | command is not allowed (bad service role, or SUB/GET used with the same queue in the same TCP session)
     PROHIBITED
   | -- | transmission has no required credentials (signature or queue ID)
     NO_AUTH
@@ -1411,6 +1557,8 @@ data BrokerErrorType
     NETWORK
   | -- | no compatible server host (e.g. onion when public is required, or vice versa)
     HOST
+  | -- | service unavailable client-side - used in agent errors
+    NO_SERVICE
   | -- | handshake or other transport error
     TRANSPORT {transportErr :: TransportError}
   | -- | command response timeout
@@ -1450,23 +1598,25 @@ instance FromJSON BlockingReason where
 
 -- | SMP transmission parser.
 transmissionP :: THandleParams v p -> Parser RawTransmission
-transmissionP THandleParams {sessionId, implySessId} = do
+transmissionP THandleParams {sessionId, implySessId, serviceAuth} = do
   authenticator <- smpP
+  serviceSig <- if serviceAuth && not (B.null authenticator) then smpP else pure Nothing
   authorized <- A.takeByteString
-  either fail pure $ parseAll (trn authenticator authorized) authorized
+  either fail pure $ parseAll (trn authenticator serviceSig authorized) authorized
   where
-    trn authenticator authorized = do
+    trn authenticator serviceSig authorized = do
       sessId <- if implySessId then pure "" else smpP
       let authorized' = if implySessId then smpEncode sessionId <> authorized else authorized
       corrId <- smpP
       entityId <- smpP
       command <- A.takeByteString
-      pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
+      pure RawTransmission {authenticator, serviceSig, authorized = authorized', sessId, corrId, entityId, command}
 
 class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
+  protocolClientHandshake :: Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle v c 'TClient)
+  useServiceAuth :: ProtoCommand msg -> Bool
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
@@ -1476,17 +1626,26 @@ instance Protocol SMPVersion ErrorType BrokerMsg where
   type ProtoCommand BrokerMsg = Cmd
   type ProtoType BrokerMsg = 'PSMP
   protocolClientHandshake = smpClientHandshake
-  protocolPing = Cmd SSender PING
+  {-# INLINE protocolClientHandshake #-}
+  useServiceAuth = \case
+    Cmd _ (NEW _) -> True
+    Cmd _ SUB -> True
+    Cmd _ NSUB -> True
+    _ -> False
+  {-# INLINE useServiceAuth #-}
+  protocolPing = Cmd SIdleClient PING
+  {-# INLINE protocolPing #-}
   protocolError = \case
     ERR e -> Just e
     _ -> Nothing
+  {-# INLINE protocolError #-}
 
 class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -> v where
   type Tag msg
   encodeProtocol :: Version v -> msg -> ByteString
   protocolP :: Version v -> Tag msg -> Parser msg
   fromProtocolError :: ProtocolErrorType -> err
-  checkCredentials :: SignedRawTransmission -> msg -> Either err msg
+  checkCredentials :: Maybe TAuthorizations -> EntityId -> msg -> Either err msg
 
 instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   type Tag (Command p) = CommandTag p
@@ -1499,6 +1658,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
         new = e (NEW_, ' ', rKey, dhKey)
         auth = maybe "" (e . ('A',)) auth_
     SUB -> e SUB_
+    SUBS -> e SUBS_
     KEY k -> e (KEY_, ' ', k)
     RKEY ks -> e (RKEY_, ' ', ks)
     LSET lnkId d -> e (LSET_, ' ', lnkId, d)
@@ -1514,6 +1674,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
     PING -> e PING_
     NSUB -> e NSUB_
+    NSUBS -> e NSUBS_
     LKEY k -> e (LKEY_, ' ', k)
     LGET -> e LGET_
     PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
@@ -1528,7 +1689,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials auth (EntityId entId) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
     NEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -1543,6 +1704,8 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     PRXY {} -> noAuthCmd
     PFWD {} -> entityCmd
     RFWD _ -> noAuthCmd
+    SUB -> serviceCmd
+    NSUB -> serviceCmd
     -- other client commands must have both signature and queue ID
     _
       | isNothing auth || B.null entId -> Left $ CMD NO_AUTH
@@ -1558,20 +1721,25 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
         | B.null entId = Left $ CMD NO_ENTITY
         | isNothing auth = Right cmd
         | otherwise = Left $ CMD HAS_AUTH
+      serviceCmd :: Either ErrorType (Command p)
+      serviceCmd
+        | isNothing auth || B.null entId = Left $ CMD NO_AUTH
+        | otherwise = Right cmd
 
 instance ProtocolEncoding SMPVersion ErrorType Cmd where
   type Tag Cmd = CmdTag
   encodeProtocol v (Cmd _ c) = encodeProtocol v c
+  {-# INLINE encodeProtocol #-}
 
   protocolP v = \case
-    CT SRecipient tag ->
-      Cmd SRecipient <$> case tag of
-        NEW_
-          | v >= shortLinksSMPVersion -> NEW <$> new smpP smpP
-          | v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP)
-          | otherwise -> NEW <$> new auth (pure Nothing)
+    CT SCreator NEW_ -> Cmd SCreator <$> newCmd
+      where
+        newCmd
+          | v >= shortLinksSMPVersion = new smpP smpP
+          | v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP)
+          | otherwise = new auth (pure Nothing)
           where
-            new p1 p2 = do
+            new p1 p2 = NEW <$> do
               rcvAuthKey <- _smpP
               rcvDhKey <- smpP
               auth_ <- p1
@@ -1582,6 +1750,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
               pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData} -- ntfCreds
             auth = optional (A.char 'A' *> smpP)
             qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
+    CT SRecipient tag ->
+      Cmd SRecipient <$> case tag of
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
         RKEY_ -> RKEY <$> _smpP
@@ -1594,12 +1764,14 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
         OFF_ -> pure OFF
         DEL_ -> pure DEL
         QUE_ -> pure QUE
+    CT SRecipientService SUBS_ -> pure $ Cmd SRecipientService SUBS
     CT SSender tag ->
       Cmd SSender <$> case tag of
         SKEY_ -> SKEY <$> _smpP
         SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
-        PING_ -> pure PING
-        RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
+    CT SIdleClient PING_ -> pure $ Cmd SIdleClient PING
+    CT SProxyService RFWD_ ->
+      Cmd SProxyService . RFWD . EncFwdTransmission . unTail <$> _smpP
     CT SSenderLink tag ->
       Cmd SSenderLink <$> case tag of
         LKEY_ -> LKEY <$> _smpP
@@ -1609,30 +1781,38 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
         PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP)
         PRXY_ -> PRXY <$> _smpP <*> smpP
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
+    CT SNotifierService NSUBS_ -> pure $ Cmd SNotifierService NSUBS
 
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
+  checkCredentials tAuth entId (Cmd p c) = Cmd p <$> checkCredentials tAuth entId c
+  {-# INLINE checkCredentials #-}
 
 instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol v = \case
-    IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId}
+    IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId}
+      | v >= serviceCertsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId
       | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId
       | v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
       | otherwise -> ids
       where
         ids = e (IDS_, ' ', rcvId, sndId, srvDh)
     LNK sId d -> e (LNK_, ' ', sId, d)
+    SOK serviceId_
+      | v >= serviceCertsSMPVersion -> e (SOK_, ' ', serviceId_)
+      | otherwise -> e OK_ -- won't happen, the association with the service requires v >= serviceCertsSMPVersion
+    SOKS n -> e (SOKS_, ' ', n)
     MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
       e (MSG_, ' ', msgId, Tail body)
     NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
     NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
-    PKEY sid vr (cert, key) -> e (PKEY_, ' ', sid, vr, C.encodeCertChain cert, C.SignedObject key)
+    PKEY sid vr certKey -> e (PKEY_, ' ', sid, vr, certKey)
     RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
     PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
     END -> e END_
+    ENDS n -> e (ENDS_, ' ', n)
     DELD
       | v >= deletedEventSMPVersion -> e DELD_
       | otherwise -> e END_
@@ -1653,28 +1833,33 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       where
         bodyP = EncRcvMsgBody . unTail <$> smpP
     IDS_
-      | v >= shortLinksSMPVersion -> ids smpP smpP
-      | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing
-      | otherwise -> ids nothing nothing
+      | v >= serviceCertsSMPVersion -> ids smpP smpP smpP
+      | v >= shortLinksSMPVersion -> ids smpP smpP nothing
+      | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
+      | otherwise -> ids nothing nothing nothing
       where
         qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
         nothing = pure Nothing
-        ids p1 p2 = do
+        ids p1 p2 p3 = do
           rcvId <- _smpP
           sndId <- smpP
           rcvPublicDhKey <- smpP
           queueMode <- p1
           linkId <- p2
+          serviceId <- p3
           -- TODO [notifications]
           -- serverNtfCreds <- p3
-          pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId}
+          pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId}
     LNK_ -> LNK <$> _smpP <*> smpP
+    SOK_ -> SOK <$> _smpP
+    SOKS_ -> SOKS <$> _smpP
     NID_ -> NID <$> _smpP <*> smpP
     NMSG_ -> NMSG <$> _smpP <*> smpP
-    PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP))
+    PKEY_ -> PKEY <$> _smpP <*> smpP <*> smpP
     RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
     PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
     END_ -> pure END
+    ENDS_ -> ENDS <$> _smpP
     DELD_ -> pure DELD
     INFO_ -> INFO <$> _smpP
     OK_ -> pure OK
@@ -1688,7 +1873,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials _ (EntityId entId) cmd = case cmd of
     -- IDS response should not have queue ID
     IDS _ -> Right cmd
     -- ERR response does not always have queue ID
@@ -1731,9 +1916,10 @@ instance Encoding ErrorType where
     PROXY err -> "PROXY " <> smpEncode err
     AUTH -> "AUTH"
     BLOCKED info -> "BLOCKED " <> smpEncode info
+    SERVICE -> "SERVICE"
     CRYPTO -> "CRYPTO"
     QUOTA -> "QUOTA"
-    STORE err -> "STORE " <> smpEncode err
+    STORE err -> "STORE " <> encodeUtf8 err
     EXPIRED -> "EXPIRED"
     NO_MSG -> "NO_MSG"
     LARGE_MSG -> "LARGE_MSG"
@@ -1748,9 +1934,10 @@ instance Encoding ErrorType where
       "PROXY" -> PROXY <$> _smpP
       "AUTH" -> pure AUTH
       "BLOCKED" -> BLOCKED <$> _smpP
+      "SERVICE" -> pure SERVICE
       "CRYPTO" -> pure CRYPTO
       "QUOTA" -> pure QUOTA
-      "STORE" -> STORE <$> _smpP
+      "STORE" -> STORE . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
       "EXPIRED" -> pure EXPIRED
       "NO_MSG" -> pure NO_MSG
       "LARGE_MSG" -> pure LARGE_MSG
@@ -1813,6 +2000,7 @@ instance Encoding BrokerErrorType where
     NETWORK -> "NETWORK"
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
+    NO_SERVICE -> "NO_SERVICE"
   smpP =
     A.takeTill (== ' ') >>= \case
       "RESPONSE" -> RESPONSE <$> _smpP
@@ -1821,6 +2009,7 @@ instance Encoding BrokerErrorType where
       "NETWORK" -> pure NETWORK
       "TIMEOUT" -> pure TIMEOUT
       "HOST" -> pure HOST
+      "NO_SERVICE" -> pure NO_SERVICE
       _ -> fail "bad BrokerErrorType"
 
 instance StrEncoding BrokerErrorType where
@@ -1831,6 +2020,7 @@ instance StrEncoding BrokerErrorType where
     NETWORK -> "NETWORK"
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
+    NO_SERVICE -> "NO_SERVICE"
   strP =
     A.takeTill (== ' ') >>= \case
       "RESPONSE" -> RESPONSE <$> _textP
@@ -1839,13 +2029,14 @@ instance StrEncoding BrokerErrorType where
       "NETWORK" -> pure NETWORK
       "TIMEOUT" -> pure TIMEOUT
       "HOST" -> pure HOST
+      "NO_SERVICE" -> pure NO_SERVICE
       _ -> fail "bad BrokerErrorType"
     where
       _textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString)
 
 -- | Send signed SMP transmission to TCP transport.
 tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
-tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
+tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions params
   where
     tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
     tPutBatch = \case
@@ -1864,13 +2055,13 @@ tPutLog th s = do
 -- ByteString in TBTransmissions includes byte with transmissions count
 data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBError TransportError r
 
-batchTransmissions :: Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()]
-batchTransmissions batch bSize = batchTransmissions' batch bSize . L.map (,())
+batchTransmissions :: THandleParams v p -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()]
+batchTransmissions params = batchTransmissions' params . L.map (,())
 
 -- | encodes and batches transmissions into blocks
-batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r]
-batchTransmissions' batch bSize ts
-  | batch = batchTransmissions_ bSize $ L.map (first $ fmap tEncodeForBatch) ts
+batchTransmissions' :: forall v p r. THandleParams v p -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r]
+batchTransmissions' THandleParams {batch, blockSize = bSize, serviceAuth} ts
+  | batch = batchTransmissions_ bSize $ L.map (first $ fmap $ tEncodeForBatch serviceAuth) ts
   | otherwise = map mkBatch1 $ L.toList ts
   where
     mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r
@@ -1881,7 +2072,7 @@ batchTransmissions' batch bSize ts
         | B.length s <= bSize - 2 -> TBTransmission s r
         | otherwise -> TBError TELargeMsg r
         where
-          s = tEncode t
+          s = tEncode serviceAuth t
 
 -- | Pack encoded transmissions into batches
 batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
@@ -1904,16 +2095,16 @@ batchTransmissions_ bSize = addBatch . foldr addTransmission ([], 0, 0, [], [])
       where
         b = B.concat $ B.singleton (lenEncode n) : ss
 
-tEncode :: SentRawTransmission -> ByteString
-tEncode (auth, t) = smpEncode (tAuthBytes auth) <> t
+tEncode :: Bool -> SentRawTransmission -> ByteString
+tEncode serviceAuth (auth, t) = tEncodeAuth serviceAuth auth <> t
 {-# INLINE tEncode #-}
 
-tEncodeForBatch :: SentRawTransmission -> ByteString
-tEncodeForBatch = smpEncode . Large . tEncode
+tEncodeForBatch :: Bool -> SentRawTransmission -> ByteString
+tEncodeForBatch serviceAuth = smpEncode . Large . tEncode serviceAuth
 {-# INLINE tEncodeForBatch #-}
 
-tEncodeBatch1 :: SentRawTransmission -> ByteString
-tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
+tEncodeBatch1 :: Bool -> SentRawTransmission -> ByteString
+tEncodeBatch1 serviceAuth t = lenEncode 1 `B.cons` tEncodeForBatch serviceAuth t
 {-# INLINE tEncodeBatch1 #-}
 
 -- tForAuth is lazy to avoid computing it when there is no key to sign
@@ -1955,26 +2146,51 @@ tParse thParams@THandleParams {batch} s
 eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
 eitherList = either (\e -> [Left e])
 
--- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall v err cmd c p. (ProtocolEncoding v err cmd, Transport c) => THandle v c p -> IO (NonEmpty (SignedTransmission err cmd))
-tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
+-- | Receive server transmissions
+tGetServer :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TServer -> IO (NonEmpty (SignedTransmissionOrError err cmd))
+tGetServer = tGet tDecodeServer
+{-# INLINE tGetServer #-}
 
-tDecodeParseValidate :: forall v p err cmd. ProtocolEncoding v err cmd => THandleParams v p -> Either TransportError RawTransmission -> SignedTransmission err cmd
-tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
-  Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
-    | implySessId || sessId == sessionId ->
-        let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
-         in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
-    | otherwise -> (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PESession))
-  Left _ -> tError ""
+-- | Receive client transmissions
+tGetClient :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TClient -> IO (NonEmpty (Transmission (Either err cmd)))
+tGetClient = tGet tDecodeClient
+{-# INLINE tGetClient #-}
+
+tGet ::
+  Transport c =>
+  (THandleParams v p -> Either TransportError RawTransmission -> r) ->
+  THandle v c p ->
+  IO (NonEmpty r)
+tGet tDecode th@THandle {params} = L.map (tDecode params) <$> tGetParse th
+{-# INLINE tGet #-}
+
+tDecodeServer :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TServer -> Either TransportError RawTransmission -> SignedTransmissionOrError err cmd
+tDecodeServer THandleParams {sessionId, thVersion = v, implySessId} = \case
+  Right RawTransmission {authenticator, serviceSig, authorized, sessId, corrId, entityId, command}
+    | implySessId || sessId == sessionId -> case decodeTAuthBytes authenticator serviceSig of
+        Right tAuth -> bimap t ((tAuth,authorized,) . t) cmdOrErr
+          where
+            cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials tAuth entityId
+            t :: a -> (CorrId, EntityId, a)
+            t = (corrId,entityId,)
+        Left _ -> tError corrId PEBlock
+    | otherwise -> tError corrId PESession
+  Left _ -> tError "" PEBlock
   where
-    tError :: CorrId -> SignedTransmission err cmd
-    tError corrId = (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PEBlock))
+    tError :: CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
+    tError corrId err = Left (corrId, NoEntity, fromProtocolError @v @err @cmd err)
 
-    tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
-    tParseValidate signed t@(sig, corrId, entityId, command) =
-      let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t
-       in (sig, signed, (corrId, entityId, cmd))
+tDecodeClient :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TClient -> Either TransportError RawTransmission -> Transmission (Either err cmd)
+tDecodeClient THandleParams {sessionId, thVersion = v, implySessId} = \case
+  Right RawTransmission {sessId, corrId, entityId, command}
+    | implySessId || sessId == sessionId -> (corrId, entityId, cmdOrErr)
+    | otherwise -> tError corrId PESession
+    where
+      cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials Nothing entityId
+  Left _ -> tError "" PEBlock
+  where
+    tError :: CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
+    tError corrId err = (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd err)
 
 $(J.deriveJSON defaultJSON ''MsgFlags)
 

src/Simplex/Messaging/Server/CLI.hs

@@ -32,9 +32,9 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
-import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
-import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
+import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -363,7 +363,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
@@ -373,7 +373,7 @@ 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 ","
@@ -387,14 +387,14 @@ iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
       createSchema = False
     }
 
-printServerConfig :: String -> [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
+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 protocol transports
 
-printServerTransports :: String -> [(ServiceName, ATransport, AddHTTP)] -> IO ()
+printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
 printServerTransports protocol ts = do
   forM_ ts $ \(p, ATransport t, addHTTP) -> do
     let descr = p <> " (" <> transportName t <> ")..."
@@ -405,8 +405,8 @@ printServerTransports protocol ts = do
       "\nWARNING: the clients will use port 443 by default soon.\n\
       \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
 
-printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
-printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
+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

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

@@ -18,20 +18,77 @@
 #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,
+    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 +121,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 +139,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,
@@ -189,13 +247,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,
@@ -203,10 +261,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 = ()
@@ -214,95 +281,185 @@ 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 -- 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)),
+    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)),
     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)
+
 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 :: TMVar (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
+  serviceSubsCount <- newTVarIO 0
+  ntfServiceSubsCount <- newTVarIO 0
   rcvQ <- newTBQueueIO qSize
   sndQ <- newTBQueueIO qSize
   msgQ <- newTBQueueIO qSize
@@ -312,7 +469,25 @@ 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,
+        serviceSubsCount,
+        ntfServiceSubsCount,
+        rcvQ,
+        sndQ,
+        msgQ,
+        procThreads,
+        endThreads,
+        endThreadSeq,
+        clientTHParams,
+        connected,
+        createdAt,
+        rcvActiveAt,
+        sndActiveAt
+      }
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
@@ -325,32 +500,32 @@ newProhibitedSub = do
   delivered <- newEmptyTMVar
   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
@@ -362,9 +537,24 @@ 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
@@ -420,7 +610,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
@@ -449,8 +639,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/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -29,6 +30,7 @@ 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
@@ -38,7 +40,7 @@ import Options.Applicative
 import Simplex.Messaging.Agent.Protocol (connReqUriP')
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
-import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), 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,9 @@ 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 (simplexMQVersion, supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
-import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
+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 +72,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 +147,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 +164,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 +182,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 +204,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"
@@ -323,54 +326,58 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       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
@@ -381,7 +388,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,
@@ -398,15 +413,7 @@ 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 defaultDBOpts, 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,
@@ -437,12 +444,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)
+                  (fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
               controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
@@ -456,7 +464,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,
@@ -549,26 +558,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)
@@ -651,7 +664,7 @@ data CliCommand
   | Start StartOptions
   | Delete
   | Journal StoreCmd
-  | Database StoreCmd DBOpts 
+  | Database StoreCmd DBOpts
 
 data StoreCmd = SCImport | SCExport | SCDelete
 

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 #-}
+  getNtfServiceQueueCount = withQS (getNtfServiceQueueCount @(JournalQueue s))
+  {-# INLINE getNtfServiceQueueCount #-}
 
 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/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,16 +15,17 @@ 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
   }
 
@@ -33,27 +36,33 @@ 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, rtsOptions} = 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
@@ -85,6 +94,7 @@ prometheusMetrics sm rtm ts =
         _msgSentLarge,
         _msgSentBlock,
         _msgRecv,
+        _msgRecvAckTimes,
         _msgRecvGet,
         _msgGet,
         _msgGetNoMsg,
@@ -104,6 +114,8 @@ prometheusMetrics sm rtm ts =
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
+        _rcvServices,
+        _ntfServices,
         _qCount,
         _msgCount,
         _ntfCount
@@ -144,7 +156,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\
@@ -268,7 +280,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\
@@ -347,6 +359,60 @@ 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\
@@ -367,21 +433,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\
@@ -403,15 +504,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,10 +21,13 @@
 module Simplex.Messaging.Server.QueueStore.Postgres
   ( PostgresQueueStore (..),
     PostgresStoreCfg (..),
+    batchInsertServices,
     batchInsertQueues,
+    foldServiceRecs,
     foldQueueRecs,
     handleDuplicate,
     withLog_,
+    withDB',
   )
 where
 
@@ -34,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, rights)
 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.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Text as T
+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
+import qualified Data.Set as S
+import Data.Text (Text)
 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,7 +64,7 @@ import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))
 import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import GHC.IO (catchAny)
-import Simplex.Messaging.Agent.Client (withLockMap)
+import Simplex.Messaging.Agent.Client (withLockMap, withLocksMap)
 import Simplex.Messaging.Agent.Lock (Lock)
 import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
@@ -64,16 +72,18 @@ import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.Postgres.Config
 import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
-import Simplex.Messaging.Server.QueueStore.STM (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
@@ -95,6 +105,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
   }
 
@@ -110,7 +121,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
@@ -130,18 +142,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 =
+  getEntityCounts :: PostgresQueueStore q -> IO EntityCounts
+  getEntityCounts st =
     withConnection (dbStore st) $ \db -> do
-      (queueCount, notifierCount) : _ <-
-        DB.query_
+      (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.
@@ -165,7 +182,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
@@ -211,6 +228,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
@@ -221,7 +279,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))
@@ -272,20 +330,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
@@ -294,21 +352,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 =
@@ -316,7 +374,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)
@@ -335,7 +393,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} ->
@@ -370,6 +428,75 @@ 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)
+
+  getNtfServiceQueueCount :: PostgresQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
+  getNtfServiceQueueCount st serviceId =
+    E.uninterruptibleMask_ $ runExceptT $ withDB' "getNtfServiceQueueCount" st $ \db ->
+      fmap (fromMaybe 0) $ maybeFirstRow fromOnly $
+        DB.query db "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL" (Only serviceId)
+
+batchInsertServices :: [STMService] -> PostgresQueueStore q -> IO Int64
+batchInsertServices services' toStore =
+  withConnection (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)
@@ -380,7 +507,7 @@ batchInsertQueues tty queues toStore = 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)
@@ -398,10 +525,24 @@ 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 =
+  withConnection (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 ->
@@ -416,12 +557,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
@@ -429,9 +569,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
   |]
 
@@ -440,23 +579,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
@@ -470,9 +614,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_)
       ]
@@ -493,19 +639,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 ->
@@ -513,33 +672,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
   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 :: MonadIO m => Text -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
 withLog op PostgresQueueStore {dbStoreLog} = withLog_ op dbStoreLog
 {-# INLINE withLog #-}
 
-withLog_ :: MonadIO m => String -> Maybe (StoreLog 'WriteMode) -> (StoreLog 'WriteMode -> IO ()) -> m ()
+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: " <> T.pack (op <> ", withLog, " <> show e)
+    logWarn $ "STORE: " <> op <> ", withLog, " <> tshow e
 
 handleDuplicate :: SqlError -> IO ErrorType
 handleDuplicate e = case constraintViolation e of
@@ -552,6 +711,14 @@ instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary .
 
 instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode
 
+instance ToField SMPServiceRole where toField = toField . decodeLatin1 . smpEncode
+
+instance FromField SMPServiceRole where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
+
+instance ToField X.CertificateChain where toField = toField . Binary . smpEncode . C.encodeCertChain
+
+instance FromField X.CertificateChain where fromField = blobFieldDecoder (parseAll C.certChainP)
+
 #if !defined(dbPostgres)
 instance ToField EntityId where toField (EntityId s) = toField $ Binary s
 

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,11 +93,25 @@ 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
@@ -97,7 +128,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
       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 +138,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 +207,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 +264,93 @@ 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)
+
+  getNtfServiceQueueCount :: STMQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
+  getNtfServiceQueueCount st serviceId =
+    TM.lookupIO serviceId (services st) >>=
+      maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceNtfQueues)
+
 withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
 withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
 
@@ -238,6 +360,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 +383,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)]))
+  getNtfServiceQueueCount :: s -> 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,
@@ -56,6 +60,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 +83,8 @@ data ServerStats = ServerStats
     pMsgFwds :: ProxyStats,
     pMsgFwdsOwn :: ProxyStats,
     pMsgFwdsRecv :: IORef Int,
+    rcvServices :: ServiceStats,
+    ntfServices :: ServiceStats,
     qCount :: IORef Int,
     msgCount :: IORef Int,
     ntfCount :: IORef Int
@@ -112,6 +119,7 @@ data ServerStatsData = ServerStatsData
     _msgSentLarge :: Int,
     _msgSentBlock :: Int,
     _msgRecv :: Int,
+    _msgRecvAckTimes :: TimeBuckets,
     _msgRecvGet :: Int,
     _msgGet :: Int,
     _msgGetNoMsg :: Int,
@@ -133,6 +141,8 @@ data ServerStatsData = ServerStatsData
     _pMsgFwds :: ProxyStatsData,
     _pMsgFwdsOwn :: ProxyStatsData,
     _pMsgFwdsRecv :: Int,
+    _ntfServices :: ServiceStatsData,
+    _rcvServices :: ServiceStatsData,
     _qCount :: Int,
     _msgCount :: Int,
     _ntfCount :: Int
@@ -169,6 +179,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 +201,8 @@ newServerStats ts = do
   pMsgFwds <- newProxyStats
   pMsgFwdsOwn <- newProxyStats
   pMsgFwdsRecv <- newIORef 0
+  rcvServices <- newServiceStats
+  ntfServices <- newServiceStats
   qCount <- newIORef 0
   msgCount <- newIORef 0
   ntfCount <- newIORef 0
@@ -223,6 +236,7 @@ newServerStats ts = do
         msgSentLarge,
         msgSentBlock,
         msgRecv,
+        msgRecvAckTimes,
         msgRecvGet,
         msgGet,
         msgGetNoMsg,
@@ -244,6 +258,8 @@ newServerStats ts = do
         pMsgFwds,
         pMsgFwdsOwn,
         pMsgFwdsRecv,
+        rcvServices,
+        ntfServices,
         qCount,
         msgCount,
         ntfCount
@@ -279,6 +295,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 +317,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
@@ -333,6 +352,7 @@ getServerStatsData s = do
         _msgSentLarge,
         _msgSentBlock,
         _msgRecv,
+        _msgRecvAckTimes,
         _msgRecvGet,
         _msgGet,
         _msgGetNoMsg,
@@ -354,6 +374,8 @@ getServerStatsData s = do
         _pMsgFwds,
         _pMsgFwdsOwn,
         _pMsgFwdsRecv,
+        _rcvServices,
+        _ntfServices,
         _qCount,
         _msgCount,
         _ntfCount
@@ -390,6 +412,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 +434,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
@@ -473,7 +498,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
@@ -541,6 +570,8 @@ instance StrEncoding ServerStatsData where
     _pMsgFwds <- proxyStatsP "pMsgFwds:"
     _pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:"
     _pMsgFwdsRecv <- opt "pMsgFwdsRecv="
+    _rcvServices <- serviceStatsP "rcvServices:"
+    _ntfServices <- serviceStatsP "ntfServices:"
     pure
       ServerStatsData
         { _fromTime,
@@ -571,6 +602,7 @@ instance StrEncoding ServerStatsData where
           _msgSentLarge,
           _msgSentBlock,
           _msgRecv,
+          _msgRecvAckTimes = emptyTimeBuckets,
           _msgRecvGet,
           _msgGet,
           _msgGetNoMsg,
@@ -592,6 +624,8 @@ instance StrEncoding ServerStatsData where
           _pMsgFwds,
           _pMsgFwdsOwn,
           _pMsgFwdsRecv,
+          _rcvServices,
+          _ntfServices,
           _qCount,
           _msgCount = 0,
           _ntfCount = 0
@@ -603,6 +637,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 +691,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 +714,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 +802,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

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,7 @@ module Simplex.Messaging.Transport
     encryptedBlockSMPVersion,
     blockedEntitySMPVersion,
     shortLinksSMPVersion,
+    serviceCertsSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -61,12 +62,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 +85,12 @@ module Simplex.Messaging.Transport
     THandle (..),
     THandleParams (..),
     THandleAuth (..),
+    CertChainPubKey (..),
+    ServiceCredentials (..),
+    THClientService' (..),
+    THClientService,
+    THPeerClientService,
+    SMPServiceRole (..),
     TSbChainKeys (..),
     TransportError (..),
     HandshakeError (..),
@@ -93,20 +106,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 +134,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 +165,7 @@ 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)
 
 data SMPVersion
 
@@ -188,6 +205,9 @@ proxyServerHandshakeSMPVersion = VersionSMP 14
 shortLinksSMPVersion :: VersionSMP
 shortLinksSMPVersion = VersionSMP 15
 
+serviceCertsSMPVersion :: VersionSMP
+serviceCertsSMPVersion = VersionSMP 16
+
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 6
 
@@ -195,13 +215,13 @@ minServerSMPRelayVersion :: VersionSMP
 minServerSMPRelayVersion = VersionSMP 6
 
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 15
+currentClientSMPRelayVersion = VersionSMP 16
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 15
+currentServerSMPRelayVersion = VersionSMP 16
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -228,8 +248,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 +261,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 +353,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 +412,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 +451,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 +473,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 +512,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 +651,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 +686,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 +735,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 +802,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 +865,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 +898,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 +911,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,13 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Logger.Simple (logError)
-import Control.Monad (when)
 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.IORef
 import Data.IP
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
@@ -56,6 +57,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
+import Simplex.Messaging.Transport.Shared
 import Simplex.Messaging.Util (bshow, catchAll, tshow, (<$?>))
 import System.IO.Error
 import Text.Read (readMaybe)
@@ -124,8 +126,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,21 +137,31 @@ 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
+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
@@ -159,13 +171,9 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
     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
+    chain <- takePeerCertChain serverCert `E.onException` closeTLS tls
+    sent <- readIORef clientCredsSent
+    getTransportConnection tCfg sent chain tls
   client c `E.finally` closeConnection c
   where
     hostAddr = \case
@@ -264,41 +272,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,6 +23,7 @@ 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
 --
@@ -54,7 +55,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 +65,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

@@ -22,10 +22,10 @@ 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

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,7 @@ import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
+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 +81,7 @@ defaultHTTP2ClientConfig =
             tcpKeepAlive = Nothing,
             logTLSErrors = True,
             clientCredentials = Nothing,
-            alpn = Nothing,
+            clientALPN = Nothing,
             useSNI = False
           },
       bufferSize = defaultHTTP2BufferSize,
@@ -97,13 +100,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
@@ -124,15 +128,17 @@ getVerifiedHTTP2ClientWith config host port disconnected setup =
         Just (Left e) -> pure $ Left e
         Nothing -> cancel action $> Left HCNetworkError
 
-    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,
@@ -179,14 +185,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,6 +48,7 @@ import GHC.IO.Exception (ioe_errno)
 import Network.Socket
 import qualified Network.TLS as T
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Shared
 import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
 import System.Exit (exitFailure)
 import System.IO.Error (tryIOError)
@@ -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 ()
@@ -214,21 +251,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

@@ -192,7 +192,7 @@ catchThrow action err = catchAllErrors err action throwE
 {-# 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 err action final = tryAllErrors err action >>= \r -> final >> except r
 {-# INLINE allFinally #-}
 
 eitherToMaybe :: Either a b -> Maybe b
@@ -265,9 +265,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)
@@ -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
   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
@@ -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}
@@ -315,12 +315,12 @@ catchRCError = catchAllErrors $ \e -> case fromException e of
 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
 
-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

src/Simplex/RemoteControl/Discovery.hs

@@ -23,10 +23,10 @@ import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Network.UDP as UDP
-import Simplex.Messaging.Transport (defaultSupportedParams)
+import Simplex.Messaging.Transport (TransportPeer (..), defaultSupportedParams)
 import qualified Simplex.Messaging.Transport as Transport
 import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
+import Simplex.Messaging.Transport.Server (mkTransportServerConfig, runTransportServerSocket, startTCPServer)
 import Simplex.Messaging.Util (ifM, tshow)
 import Simplex.RemoteControl.Discovery.Multicast (setMembership)
 import Simplex.RemoteControl.Types
@@ -68,7 +68,7 @@ preferAddress RCCtrlAddress {address, interface} addrs =
     matchAddr RCCtrlAddress {address = a} = a == address
     matchIface RCCtrlAddress {interface = i} = i == interface
 
-startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
+startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS 'TServer -> IO ()) -> IO (Async ())
 startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do
   started <- newEmptyTMVarIO
   bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
@@ -81,7 +81,7 @@ startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ d
       port <- N.socketPort socket
       logInfo $ "System-assigned port: " <> tshow port
       setPort $ Just port
-      runTransportServerSocket started (pure socket) "RCP TLS" credentials serverParams defaultTransportServerConfig server
+      runTransportServerSocket started (pure socket) "RCP TLS" serverParams (mkTransportServerConfig True Nothing True) server
     setPort = void . atomically . tryPutTMVar startedOnPort
     serverParams =
       def

src/Simplex/RemoteControl/Types.hs

@@ -18,12 +18,13 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word16)
+import qualified Data.X509 as X
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
-import Simplex.Messaging.Transport (TLS, TSbChainKeys)
+import Simplex.Messaging.Transport (TLS, TSbChainKeys, TransportPeer (..))
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
@@ -140,7 +141,7 @@ $(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello)
 -- | Long-term part of controller (desktop) connection to host (mobile)
 data RCHostPairing = RCHostPairing
   { caKey :: C.APrivateSignKey,
-    caCert :: C.SignedCertificate,
+    caCert :: X.SignedCertificate,
     idPrivKey :: C.PrivateKeyEd25519,
     knownHost :: Maybe KnownHostPairing
   }
@@ -159,7 +160,7 @@ data RCCtrlAddress = RCCtrlAddress
 -- | Long-term part of host (mobile) connection to controller (desktop)
 data RCCtrlPairing = RCCtrlPairing
   { caKey :: C.APrivateSignKey,
-    caCert :: C.SignedCertificate,
+    caCert :: X.SignedCertificate,
     ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller
     idPubKey :: C.PublicKeyEd25519,
     dhPrivKey :: C.PrivateKeyX25519,
@@ -167,13 +168,13 @@ data RCCtrlPairing = RCCtrlPairing
   }
 
 data RCHostKeys = RCHostKeys
-  { sessKeys :: C.KeyPair 'C.Ed25519,
-    dhKeys :: C.KeyPair 'C.X25519
+  { sessKeys :: C.KeyPairEd25519,
+    dhKeys :: C.KeyPairX25519
   }
 
 -- Connected session with Host
 data RCHostSession = RCHostSession
-  { tls :: TLS,
+  { tls :: TLS 'TServer,
     sessionKeys :: HostSessKeys
   }
 
@@ -186,7 +187,7 @@ data HostSessKeys = HostSessKeys
 -- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing)
 
 data RCCtrlSession = RCCtrlSession
-  { tls :: TLS,
+  { tls :: TLS 'TClient,
     sessionKeys :: CtrlSessKeys
   }
 

tests/AgentTests.hs

@@ -15,8 +15,8 @@ import AgentTests.MigrationTests (migrationTests)
 import AgentTests.ServerChoice (serverChoiceTests)
 import AgentTests.ShortLinkTests (shortLinkTests)
 import Simplex.Messaging.Server.Env.STM (AStoreType (..))
-import Simplex.Messaging.Transport (ATransport (..))
-import Test.Hspec
+import Simplex.Messaging.Transport (ASrvTransport)
+import Test.Hspec hiding (fit, it)
 
 #if defined(dbPostgres)
 import Fixtures
@@ -38,7 +38,7 @@ agentCoreTests = do
   describe "Double ratchet tests" doubleRatchetTests
   describe "Short link tests" shortLinkTests
 
-agentTests :: (ATransport, AStoreType) -> Spec
+agentTests :: (ASrvTransport, AStoreType) -> Spec
 agentTests ps = do
 #if defined(dbPostgres)
   after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do
@@ -47,7 +47,7 @@ agentTests ps = do
 #endif
     describe "Functional API" $ functionalAPITests ps
     describe "Chosen servers" serverChoiceTests
-#if defined(dbServerPostgres)    
+#if defined(dbServerPostgres)
     around_ (postgressBracket ntfTestServerDBConnectInfo) $
       describe "Notification tests" $ notificationTests ps
 #endif

tests/AgentTests/ConnectionRequestTests.hs

@@ -28,7 +28,8 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (EntityId (..), ProtocolServer (..), QueueMode (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC)
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import Simplex.Messaging.Version
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 srv :: SMPServer
 srv = SMPServer "smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "5223" (C.KeyHash "\215m\248\251")
@@ -288,7 +289,7 @@ connectionRequestTests =
       smpEncodingTest queueV1NoPort
       smpEncodingTest connectionRequest
       -- smpEncodingTest connectionRequestNoQM -- this fails, because of queue mode patch
-      smpEncodingTest connectionRequestContact  -- this passes because of queue mode patch in ConnReqUriData encoding
+      smpEncodingTest connectionRequestContact -- this passes because of queue mode patch in ConnReqUriData encoding
       smpEncodingTest connectionRequest1
       smpEncodingTest connectionRequest2queues
       smpEncodingTest connectionRequestNew
@@ -334,12 +335,12 @@ connectionRequestTests =
       restoreShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef"))
         `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")
       Right (lnk :: ConnShortLink 'CMContact) <- pure $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
-      Right (lnk' :: ConnShortLink 'CMContact) <- pure $ strDecode  "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM"
+      Right (lnk' :: ConnShortLink 'CMContact) <- pure $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM"
       let presetSrv :: SMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"
       shortenShortLink [presetSrv] lnk `shouldBe` lnk'
       restoreShortLink [presetSrv] lnk' `shouldBe` lnk
       Right (inv :: ConnShortLink 'CMInvitation) <- pure $ strDecode "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
-      Right (inv' :: ConnShortLink 'CMInvitation) <- pure $ strDecode  "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY"
+      Right (inv' :: ConnShortLink 'CMInvitation) <- pure $ strDecode "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY"
       shortenShortLink [presetSrv] inv `shouldBe` inv'
       restoreShortLink [presetSrv] inv' `shouldBe` inv
   where

tests/AgentTests/DoubleRatchetTests.hs

@@ -26,13 +26,14 @@ import qualified Data.Map.Strict as M
 import Data.Type.Equality
 import Simplex.Messaging.Crypto (Algorithm (..), AlgorithmI, CryptoError, DhAlgorithm)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Crypto.Ratchet
+import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$$>))
 import Simplex.Messaging.Version
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 doubleRatchetTests :: Spec
 doubleRatchetTests = do
@@ -82,7 +83,6 @@ runMessageTests initRatchets_ agreeRatchetKEMs = do
       withRatchets_ @X25519 initRatchets_ test
       withRatchets_ @X448 initRatchets_ test
 
-
 testAlgs :: (forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()) -> IO ()
 testAlgs test = test C.SX25519 >> test C.SX448
 

tests/AgentTests/EqInstances.hs

@@ -5,7 +5,7 @@
 module AgentTests.EqInstances where
 
 import Data.Type.Equality
-import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..))
+import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..), UserLinkData (..))
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Client (ProxiedRelay (..))
 
@@ -18,12 +18,10 @@ deriving instance Eq (Connection d)
 
 deriving instance Eq (SConnType d)
 
-deriving instance Eq (StoredRcvQueue q)
+deriving instance Eq (StoredRcvQueue s)
 
 deriving instance Eq (StoredSndQueue q)
 
-deriving instance Eq (DBQueueId q)
-
 deriving instance Eq ClientNtfCreds
 
 deriving instance Eq ShortLinkCreds
@@ -32,6 +30,10 @@ deriving instance Show (ConnLinkData c)
 
 deriving instance Eq (ConnLinkData c)
 
+deriving instance Show UserLinkData
+
+deriving instance Eq UserLinkData
+
 deriving instance Show OwnerAuth
 
 deriving instance Eq OwnerAuth

tests/AgentTests/FunctionalAPITests.hs

@@ -71,19 +71,21 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as M
 import Data.Maybe (isJust, isNothing)
 import qualified Data.Set as S
+import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
+import qualified Data.Text.IO as T
 import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Type.Equality (testEquality, (:~:) (Refl))
 import Data.Word (Word16)
 import GHC.Stack (withFrozenCallStack)
 import SMPAgentClient
-import SMPClient (cfgJ2QS, cfgMS, prevRange, prevVersion, proxyCfgJ2QS, proxyCfgMS, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
-import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
+import SMPClient
+import Simplex.Messaging.Agent hiding (createConnection, joinConnection, subscribeConnection, sendMessage)
 import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
-import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
+import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT, INV, JOINED)
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface
@@ -98,23 +100,32 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF)
 import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange)
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
 import Simplex.Messaging.Server.QueueStore.QueueInfo
-import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds)
 import Simplex.Messaging.Version (VersionRange (..))
 import qualified Simplex.Messaging.Version as V
 import Simplex.Messaging.Version.Internal (Version (..))
 import System.Directory (copyFile, renameFile)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO
 import Util
 import XFTPClient (testXFTPServer)
 #if defined(dbPostgres)
 import Fixtures
 #endif
+#if defined(dbServerPostgres)
+import qualified Database.PostgreSQL.Simple as PSQL
+import Simplex.Messaging.Agent.Store (Connection (..), StoredRcvQueue (..), SomeConn (..))
+import Simplex.Messaging.Agent.Store.AgentStore (getConn)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
+import Simplex.Messaging.Server.QueueStore.Postgres
+import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..))
+#endif
 
 type AEntityTransmission e = (ACorrId, ConnId, AEvent e)
 
@@ -202,6 +213,12 @@ pattern SENT msgId = A.SENT msgId Nothing
 pattern Rcvd :: AgentMsgId -> AEvent 'AEConn
 pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
 
+pattern INV :: AConnectionRequestUri -> AEvent 'AEConn
+pattern INV cReq = A.INV cReq Nothing
+
+pattern JOINED :: SndQueueSecured -> AEvent 'AEConn
+pattern JOINED sndSecure = A.JOINED sndSecure Nothing
+
 smpCfgVPrev :: ProtocolClientConfig SMPVersion
 smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
 
@@ -253,13 +270,17 @@ inAnyOrder g rs = withFrozenCallStack $ do
 
 createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
 createConnection c userId enableNtfs cMode clientData subMode = do
-  (connId, CCLink cReq _) <- A.createConnection c userId enableNtfs cMode Nothing clientData (IKNoPQ PQSupportOn) subMode
+  (connId, (CCLink cReq _, Nothing)) <- A.createConnection c userId enableNtfs cMode Nothing clientData IKPQOn subMode
   pure (connId, cReq)
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
 joinConnection c userId enableNtfs cReq connInfo subMode = do
   connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
-  (connId,) <$> A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
+  (sndSecure, Nothing) <- A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
+  pure (connId, sndSecure)
+
+subscribeConnection :: AgentClient -> ConnId -> AE ()
+subscribeConnection c = void . A.subscribeConnection c
 
 sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
 sendMessage c connId msgFlags msgBody = do
@@ -267,7 +288,7 @@ sendMessage c connId msgFlags msgBody = do
   liftIO $ pqEnc `shouldBe` PQEncOn
   pure msgId
 
-functionalAPITests :: (ATransport, AStoreType) -> Spec
+functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
 functionalAPITests ps = do
   describe "Establishing duplex connection" $ do
     testMatrix2 ps runAgentClientTest
@@ -315,11 +336,12 @@ functionalAPITests ps = do
     describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync
     describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink
     describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink
-    describe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInviationShortLinkPrev
+    xdescribe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInviationShortLinkPrev
     describe "server restart" $ do
       it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps
       it "should connect via contact short link after restart" $ testContactShortLinkRestart ps
       it "should connect via added contact short link after restart" $ testAddContactShortLinkRestart ps
+    it "should create and get short links with the old contact queues" $ testOldContactQueueShortLink ps
   describe "Message delivery" $ do
     describe "update connection agent version on received messages" $ do
       it "should increase if compatible, shouldn'ps decrease" $
@@ -486,9 +508,9 @@ functionalAPITests ps = do
     it "server should respond with queue and subscription information" $
       withSmpServer ps testServerQueueInfo
 
-testBasicAuth :: (ATransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
+testBasicAuth :: (ASrvTransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
 testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do
-  let testCfg = (cfgMS msType) {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion}
+  let testCfg = updateCfg (cfgMS msType) $ \cfg' -> cfg' {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion}
       canCreate1 = canCreateQueue allowNewQueues srv clnt1
       canCreate2 = canCreateQueue allowNewQueues srv clnt2
       expected
@@ -503,7 +525,7 @@ canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, Ver
 canCreateQueue allowNew (srvAuth, _) (clntAuth, _) =
   allowNew && (isNothing srvAuth || srvAuth == clntAuth)
 
-testMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2 ps runTest = do
   it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
   it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
@@ -512,7 +534,7 @@ testMatrix2 ps runTest = do
   it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff False False
   it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 1 $ runTest PQSupportOff False False
 
-testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testMatrix2Stress :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2Stress ps runTest = do
   it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
   it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 initAgentServersProxy 1 $ runTest PQSupportOn False True
@@ -525,14 +547,14 @@ testMatrix2Stress ps runTest = do
     aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval}
     aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval}
 
-testBasicMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testBasicMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testBasicMatrix2 ps runTest = do
   it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True
   it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 1 $ runTest False
   it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 1 $ runTest False
   it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 1 $ runTest False
 
-testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testRatchetMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testRatchetMatrix2 ps runTest = do
   it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
   it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
@@ -541,36 +563,36 @@ testRatchetMatrix2 ps runTest = do
   it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False
   it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
 
-testServerMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec
+testServerMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 ps runTest = do
   it "1 server" $ withSmpServer ps $ runTest initAgentServers
   it "2 servers" $ withSmpServers2 ps $ runTest initAgentServers2
 
-testProxyMatrix :: HasCallStack => (ATransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
+testProxyMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
 testProxyMatrix ps runTest = do
   it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False
   it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True
 
-testProxyMatrixWithPrev :: HasCallStack => (ATransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
+testProxyMatrixWithPrev :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
 testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do
   it "2 servers, directly, curr clients, prev servers" $ withSmpServers2Prev $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False True
   it "2 servers, via proxy, curr clients, prev servers" $ withSmpServersProxy2Prev $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True True
   it "2 servers, directly, prev clients, curr servers" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServers) (agentCfgVPrevPQ, initAgentServers2) $ runTest False False
   it "2 servers, via proxy, prev clients, curr servers" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServersProxy) (agentCfgVPrevPQ, initAgentServersProxy2) $ runTest True False
   where
-    prev cfg' = cfg' {smpServerVRange = prevRange supportedServerSMPRelayVRange}
+    prev cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange supportedServerSMPRelayVRange}
     withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgJ2QS qs) a
     withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgJ2QS qs) a
     withServers2 cfg1 cfg2 a =
       withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a
 
-testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
+testPQMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
 testPQMatrix2 = pqMatrix2_ True
 
-testPQMatrix2NoInv :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
+testPQMatrix2NoInv :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
 testPQMatrix2NoInv = pqMatrix2_ False
 
-pqMatrix2_ :: HasCallStack => Bool -> (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
+pqMatrix2_ :: HasCallStack => Bool -> (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
 pqMatrix2_ pqInv ps test = do
   it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
   it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
@@ -584,7 +606,7 @@ pqMatrix2_ pqInv ps test = do
 
 testPQMatrix3 ::
   HasCallStack =>
-  (ATransport, AStoreType) ->
+  (ASrvTransport, AStoreType) ->
   (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) ->
   Spec
 testPQMatrix3 ps test = do
@@ -640,14 +662,14 @@ withAgentClients3 runTest =
 
 runAgentClientTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
-  runAgentClientTestPQ sqSecured viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
+  runAgentClientTestPQ sqSecured viaProxy (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId
 
 runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (bobId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
+    (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
@@ -842,19 +864,19 @@ testAgentClient3 =
 
 runAgentClientContactTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
-  runAgentClientContactTestPQ sqSecured viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
+  runAgentClientContactTestPQ sqSecured viaProxy pqSupport (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId
 
 runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (_, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+    (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
+    (sqSecuredJoin, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` reqPQSupport
     bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-    sqSecured' <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+    (sqSecured', Nothing) <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
     liftIO $ pqSup'' `shouldBe` bPQ
@@ -891,7 +913,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
 
 runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
-  (_, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+  (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
   (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
   sentMessages abPQEnc alice bobId bob bAliceId
   (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
@@ -900,12 +922,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
     msgId = subtract baseId . fst
     connectViaContact b pq qInfo = do
       aId <- A.prepareConnectionToJoin b 1 True qInfo pq
-      sqSecuredJoin <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
+      (sqSecuredJoin, Nothing) <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
       liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
       ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
       bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
-      sqSecuredAccept <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
+      (sqSecuredAccept, Nothing) <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
       liftIO $ pqSup'' `shouldBe` pq
@@ -944,9 +966,9 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
 testRejectContactRequest :: HasCallStack => IO ()
 testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
-    (addrConnId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    (addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
     ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
     liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
@@ -960,7 +982,7 @@ testUpdateConnectionUserId =
     newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
     _ <- changeConnectionUser alice 1 connId newUserId
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured' `shouldBe` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -1047,7 +1069,7 @@ testAsyncBothOffline = do
     liftIO $ disposeAgentClient alice'
     liftIO $ disposeAgentClient bob'
 
-testAsyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testAsyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
   -- create connection and shutdown the server
   (bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ ->
@@ -1063,6 +1085,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
+    liftIO $ threadDelay 250000
     (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     liftIO $ sqSecured `shouldBe` True
     ("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -1072,7 +1095,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
     get bob ##> ("", aliceId, CON)
     exchangeGreetings alice bobId bob aliceId
 
-testAllowConnectionClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testAllowConnectionClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
@@ -1114,8 +1137,8 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
 testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testInviationShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
-    let userData = "some user data"
-    (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+    let userData = UserLinkData "some user data"
+    (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
@@ -1129,11 +1152,15 @@ testInviationShortLink viaProxy a b =
       Left (SMP _ AUTH) -> pure ()
       r -> liftIO $ expectationFailure ("unexpected result " <> show r)
     runRight $ testJoinConn_ viaProxy True a bId b connReq
+    -- invitation link data is removed after the connection is established
+    runExceptT (getConnShortLink b 1 shortLink) >>= \case
+      Left (SMP _ AUTH) -> pure ()
+      r -> liftIO $ expectationFailure ("unexpected result " <> show r)
 
 testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
 testJoinConn_ viaProxy sndSecure a bId b connReq = do
   aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
-  sndSecure' <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
+  (sndSecure', Nothing) <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
   liftIO $ sndSecure' `shouldBe` sndSecure
   ("", _, CONF confId _ "bob's connInfo") <- get a
   allowConnection a bId confId "alice's connInfo"
@@ -1144,15 +1171,15 @@ testJoinConn_ viaProxy sndSecure a bId b connReq = do
 
 testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO ()
 testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
   -- can't create short link with previous version
-  (bId, CCLink connReq Nothing) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
+  (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
   testJoinConn_ viaProxy sndSecure a bId b connReq
 
 testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testInviationShortLinkAsync viaProxy a b = do
-  let userData = "some user data"
-  (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+  let userData = UserLinkData "some user data"
+  (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
   (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
   strDecode (strEncode shortLink) `shouldBe` Right shortLink
   connReq' `shouldBe` connReq
@@ -1170,8 +1197,8 @@ testInviationShortLinkAsync viaProxy a b = do
 testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
-    let userData = "some user data"
-    (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
+    let userData = UserLinkData "some user data"
+    (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0)
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
@@ -1190,7 +1217,7 @@ testContactShortLink viaProxy a b =
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
       bId <- A.prepareConnectionToAccept a True invId PQSupportOn
-      sndSecure' <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+      (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
       allowConnection b aId confId "bob's connInfo"
@@ -1199,27 +1226,27 @@ testContactShortLink viaProxy a b =
       get b ##> ("", aId, CON)
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
-    let updatedData = "updated user data"
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    let updatedData = UserLinkData "updated user data"
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink' `shouldBe` shortLink
     (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink
     connReq4 `shouldBe` connReq
     linkUserData updatedConnData' `shouldBe` updatedData
     -- one more time
-    shortLink2 <- runRight $ setContactShortLink a contactId updatedData
+    shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink2 `shouldBe` shortLink
     -- delete short link
-    runRight_ $ deleteContactShortLink a contactId
+    runRight_ $ deleteConnShortLink a contactId SCMContact
     Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink
     pure ()
 
 testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testAddContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
-    (contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
+    (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0) --
-    let userData = "some user data"
-    shortLink <- runRight $ setContactShortLink a contactId userData
+    let userData = UserLinkData "some user data"
+    shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
@@ -1237,7 +1264,7 @@ testAddContactShortLink viaProxy a b =
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
       bId <- A.prepareConnectionToAccept a True invId PQSupportOn
-      sndSecure' <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
+      (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
       allowConnection b aId confId "bob's connInfo"
@@ -1246,17 +1273,17 @@ testAddContactShortLink viaProxy a b =
       get b ##> ("", aId, CON)
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
-    let updatedData = "updated user data"
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    let updatedData = UserLinkData "updated user data"
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink' `shouldBe` shortLink
     (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink
     connReq4 `shouldBe` connReq
     linkUserData updatedConnData' `shouldBe` updatedData
 
-testInviationShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
-  let userData = "some user data"
-  (bId, CCLink connReq (Just shortLink)) <- withSmpServer ps $
+  let userData = UserLinkData "some user data"
+  (bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $
     runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
   withSmpServer ps $ do
     runRight_ $ subscribeConnection a bId
@@ -1265,48 +1292,91 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
     connReq' `shouldBe` connReq
     linkUserData connData' `shouldBe` userData
 
-testContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
-  let userData = "some user data"
-  (contactId, CCLink connReq0 (Just shortLink)) <- withSmpServer ps $
+  let userData = UserLinkData "some user data"
+  (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $
     runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
-  let updatedData = "updated user data"
+  let updatedData = UserLinkData "updated user data"
   withSmpServer ps $ do
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
     linkUserData connData' `shouldBe` userData
     -- update user data
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink' `shouldBe` shortLink
   withSmpServer ps $ do
     (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
     connReq4 `shouldBe` connReq
     linkUserData updatedConnData' `shouldBe` updatedData
 
-testAddContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
-  let userData = "some user data"
-  ((contactId, CCLink connReq0 Nothing), shortLink) <- withSmpServer ps $ runRight $ do
+  let userData = UserLinkData "some user data"
+  ((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do
     r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
-    (r,) <$> setContactShortLink a contactId userData
+    (r,) <$> setConnShortLink a contactId SCMContact userData Nothing
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
-  let updatedData = "updated user data"
+  let updatedData = UserLinkData "updated user data"
   withSmpServer ps $ do
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
     linkUserData connData' `shouldBe` userData
     -- update user data
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
     shortLink' `shouldBe` shortLink
   withSmpServer ps $ do
     (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
     connReq4 `shouldBe` connReq
     linkUserData updatedConnData' `shouldBe` updatedData
 
-testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
+  (contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $
+    A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
+  -- make it an "old" queue
+  let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
+  () <- case testServerStoreConfig msType of
+    ASSCfg _ _ (SSCMemory (Just StorePaths {storeLogFile})) -> updateStoreLog storeLogFile
+    ASSCfg _ _ (SSCMemoryJournal {storeLogFile}) -> updateStoreLog storeLogFile
+    ASSCfg _ _ (SSCDatabaseJournal {storeCfg}) -> do
+#if defined(dbServerPostgres)
+      let AgentClient {agentEnv = Env {store}} = a
+      Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
+      st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) storeCfg
+      Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
+      closeQueueStore @(JournalQueue 'QSPostgres) st
+#else
+      error "no dbServerPostgres flag"
+#endif
+    _ -> pure ()
+
+  withSmpServer ps $ do
+    let userData = UserLinkData "some user data"
+    shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
+    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+    strDecode (strEncode shortLink) `shouldBe` Right shortLink
+    connReq' `shouldBe` connReq
+    linkUserData connData' `shouldBe` userData
+    -- update user data
+    let updatedData = UserLinkData "updated user data"
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+    shortLink' `shouldBe` shortLink
+    -- check updated
+    (connReq'', updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
+    connReq'' `shouldBe` connReq
+    linkUserData updatedConnData' `shouldBe` updatedData
+
+replaceSubstringInFile :: FilePath -> T.Text -> T.Text -> IO ()
+replaceSubstringInFile filePath oldText newText = do
+  content <- T.readFile filePath
+  let newContent = T.replace oldText newText content
+  T.writeFile filePath newContent
+
+testIncreaseConnAgentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testIncreaseConnAgentVersion ps = do
   alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
@@ -1371,7 +1441,7 @@ checkVersion c connId v = do
   ConnectionStats {connAgentVersion} <- getConnectionServers c connId
   liftIO $ connAgentVersion `shouldBe` VersionSMPA v
 
-testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testIncreaseConnAgentVersionMaxCompatible ps = do
   alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
@@ -1401,7 +1471,7 @@ testIncreaseConnAgentVersionMaxCompatible ps = do
     disposeAgentClient alice2
     disposeAgentClient bob2
 
-testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testIncreaseConnAgentVersionStartDifferentVersion ps = do
   alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
@@ -1427,7 +1497,7 @@ testIncreaseConnAgentVersionStartDifferentVersion ps = do
     disposeAgentClient alice2
     disposeAgentClient bob
 
-testDeliverClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testDeliverClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDeliverClientRestart ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1458,7 +1528,7 @@ testDeliverClientRestart ps = do
   disposeAgentClient alice
   disposeAgentClient bob2
 
-testDuplicateMessage :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testDuplicateMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDuplicateMessage ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1510,7 +1580,7 @@ testDuplicateMessage ps = do
   disposeAgentClient alice2
   disposeAgentClient bob2
 
-testSkippedMessages :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testSkippedMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testSkippedMessages (t, msType) = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1559,9 +1629,9 @@ testSkippedMessages (t, msType) = do
   disposeAgentClient alice2
   disposeAgentClient bob2
   where
-    cfg' = (cfgMS msType) {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing}
+    cfg' = withServerCfg (cfgMS msType) $ \cfg_ -> ASrvCfg SQSMemory SMSMemory cfg_ {serverStoreCfg = SSCMemory $ Just $ StorePaths testStoreLogFile Nothing}
 
-testDeliveryAfterSubscriptionError :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testDeliveryAfterSubscriptionError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDeliveryAfterSubscriptionError ps = do
   (aId, bId) <- withAgentClients2 $ \a b -> do
     (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b
@@ -1579,7 +1649,7 @@ testDeliveryAfterSubscriptionError ps = do
       withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
       ackMessage b aId 2 Nothing
 
-testMsgDeliveryQuotaExceeded :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testMsgDeliveryQuotaExceeded :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testMsgDeliveryQuotaExceeded ps =
   withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
     (aId, bId) <- makeConnection a b
@@ -1607,7 +1677,7 @@ testMsgDeliveryQuotaExceeded ps =
     get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False
     liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events")
 
-testExpireMessage :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testExpireMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testExpireMessage ps =
   withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
@@ -1623,7 +1693,7 @@ testExpireMessage ps =
         withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False
         ackMessage b aId 2 Nothing
 
-testExpireManyMessages :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testExpireManyMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testExpireManyMessages ps =
   withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
@@ -1662,8 +1732,8 @@ withUP a bId p =
         \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
       ]
 
-testExpireMessageQuota :: HasCallStack => (ATransport, AStoreType) -> IO ()
-testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
+testExpireMessageQuota :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testExpireMessageQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1687,9 +1757,11 @@ testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msg
     get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 3) "3") -> c == aId; _ -> False
     ackMessage b' aId 4 Nothing
   disposeAgentClient a
+  where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
 
-testExpireManyMessagesQuota :: (ATransport, AStoreType) -> IO ()
-testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
+testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO ()
+testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1724,8 +1796,10 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType)
     get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 5) "5") -> c == aId; _ -> False
     ackMessage b' aId 4 Nothing
   disposeAgentClient a
+  where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
 
-testRatchetSync :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testRatchetSync :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testRatchetSync ps = withAgentClients2 $ \alice bob ->
   withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
     (aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob
@@ -1799,7 +1873,7 @@ ratchetSyncP' cId rss = \case
     cId' == cId && rss' == rss && ratchetSyncState == rss
   _ -> False
 
-testRatchetSyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testRatchetSyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do
   (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
     setupDesynchronizedRatchet alice bob
@@ -1825,7 +1899,7 @@ serverUpP = \case
   ("", "", AEvt SAENone (UP _ _)) -> True
   _ -> False
 
-testRatchetSyncClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testRatchetSyncClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testRatchetSyncClientRestart ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1850,7 +1924,7 @@ testRatchetSyncClientRestart ps = do
   disposeAgentClient bob
   disposeAgentClient bob3
 
-testRatchetSyncSuspendForeground :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testRatchetSyncSuspendForeground :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testRatchetSyncSuspendForeground ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1879,7 +1953,7 @@ testRatchetSyncSuspendForeground ps = do
   disposeAgentClient bob
   disposeAgentClient bob2
 
-testRatchetSyncSimultaneous :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testRatchetSyncSimultaneous :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testRatchetSyncSimultaneous ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1993,9 +2067,9 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
 
 makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
-  (bobId, CCLink qInfo Nothing) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (CR.IKNoPQ pqSupport) SMSubscribe
+  (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
-  sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
+  (sqSecured', Nothing) <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
   liftIO $ sqSecured' `shouldBe` sqSecured
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
@@ -2006,9 +2080,9 @@ makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
   get bob ##> ("", aliceId, A.CON pqEnc)
   pure (aliceId, bobId)
 
-testInactiveNoSubs :: (ATransport, AStoreType) -> IO ()
+testInactiveNoSubs :: (ASrvTransport, AStoreType) -> IO ()
 testInactiveNoSubs (t, msType) = do
-  let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
+  let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
     withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
       runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check
@@ -2016,9 +2090,9 @@ testInactiveNoSubs (t, msType) = do
       Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
       pure ()
 
-testInactiveWithSubs :: (ATransport, AStoreType) -> IO ()
+testInactiveWithSubs :: (ASrvTransport, AStoreType) -> IO ()
 testInactiveWithSubs (t, msType) = do
-  let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
+  let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
     withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
       runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -2027,9 +2101,9 @@ testInactiveWithSubs (t, msType) = do
       -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
       liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
 
-testActiveClientNotDisconnected :: (ATransport, AStoreType) -> IO ()
+testActiveClientNotDisconnected :: (ASrvTransport, AStoreType) -> IO ()
 testActiveClientNotDisconnected (t, msType) = do
-  let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
+  let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
     withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
       ts <- getSystemTime
@@ -2070,7 +2144,7 @@ testSuspendingAgent =
     liftIO $ foregroundAgent b
     get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
 
-testSuspendingAgentCompleteSending :: (ATransport, AStoreType) -> IO ()
+testSuspendingAgentCompleteSending :: (ASrvTransport, AStoreType) -> IO ()
 testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do
   (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
@@ -2101,7 +2175,7 @@ testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
     ackMessage a bId 4 Nothing
 
-testSuspendingAgentTimeout :: (ATransport, AStoreType) -> IO ()
+testSuspendingAgentTimeout :: (ASrvTransport, AStoreType) -> IO ()
 testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
   (aId, _) <- withSmpServer ps . runRight $ do
     (aId, bId) <- makeConnection a b
@@ -2120,7 +2194,7 @@ testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
     ("", "", SUSPENDED) <- nGet b
     pure ()
 
-testBatchedSubscriptions :: Int -> Int -> (ATransport, AStoreType) -> IO ()
+testBatchedSubscriptions :: Int -> Int -> (ASrvTransport, AStoreType) -> IO ()
 testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
   withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     conns <- runServers $ do
@@ -2264,7 +2338,7 @@ receiveMsg c cId msgId msg = do
 testAsyncCommands :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
 testAsyncCommands sqSecured alice bob baseId =
   runRight_ $ do
-    bobId <- createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
+    bobId <- createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
     ("1", bobId', INV (ACR _ qInfo)) <- get alice
     liftIO $ bobId' `shouldBe` bobId
     aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe
@@ -2312,10 +2386,10 @@ testAsyncCommands sqSecured alice bob baseId =
   where
     msgId = subtract baseId
 
-testAsyncCommandsRestore :: (ATransport, AStoreType) -> IO ()
+testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO ()
 testAsyncCommandsRestore ps = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
+  bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
   liftIO $ noMessages alice "alice doesn't receive INV because server is down"
   disposeAgentClient alice
   withAgent 2 agentCfg initAgentServers testDB $ \alice' ->
@@ -2363,7 +2437,7 @@ testAcceptContactAsync sqSecured alice bob baseId =
   where
     msgId = subtract baseId
 
-testDeleteConnectionAsync :: (ATransport, AStoreType) -> IO ()
+testDeleteConnectionAsync :: (ASrvTransport, AStoreType) -> IO ()
 testDeleteConnectionAsync ps =
   withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do
     connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
@@ -2379,7 +2453,7 @@ testDeleteConnectionAsync ps =
       get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False
       liftIO $ noMessages a "nothing else should be delivered to alice"
 
-testWaitDeliveryNoPending :: (ATransport, AStoreType) -> IO ()
+testWaitDeliveryNoPending :: (ASrvTransport, AStoreType) -> IO ()
 testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob ->
   withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
     (aliceId, bobId) <- makeConnection alice bob
@@ -2407,7 +2481,7 @@ testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob ->
     baseId = 1
     msgId = subtract baseId
 
-testWaitDelivery :: (ATransport, AStoreType) -> IO ()
+testWaitDelivery :: (ASrvTransport, AStoreType) -> IO ()
 testWaitDelivery ps =
   withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2461,7 +2535,7 @@ testWaitDelivery ps =
     baseId = 1
     msgId = subtract baseId
 
-testWaitDeliveryAUTHErr :: (ATransport, AStoreType) -> IO ()
+testWaitDeliveryAUTHErr :: (ASrvTransport, AStoreType) -> IO ()
 testWaitDeliveryAUTHErr ps =
   withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2504,7 +2578,7 @@ testWaitDeliveryAUTHErr ps =
     baseId = 1
     msgId = subtract baseId
 
-testWaitDeliveryTimeout :: (ATransport, AStoreType) -> IO ()
+testWaitDeliveryTimeout :: (ASrvTransport, AStoreType) -> IO ()
 testWaitDeliveryTimeout ps =
   withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2544,7 +2618,7 @@ testWaitDeliveryTimeout ps =
     baseId = 1
     msgId = subtract baseId
 
-testWaitDeliveryTimeout2 :: (ATransport, AStoreType) -> IO ()
+testWaitDeliveryTimeout2 :: (ASrvTransport, AStoreType) -> IO ()
 testWaitDeliveryTimeout2 ps =
   withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
     withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2590,13 +2664,13 @@ testWaitDeliveryTimeout2 ps =
     baseId = 1
     msgId = subtract baseId
 
-testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
   withAgent 1 cfg' initAgentServers testDB $ \a ->
     withAgent 2 cfg' initAgentServersSrv2 testDB2 $ \b -> do
       (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
-        bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
+        bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
         ("1", bId', INV (ACR _ qInfo)) <- get a
         liftIO $ bId' `shouldBe` bId
         aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe
@@ -2635,13 +2709,13 @@ testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
           smpCfg = smpCfgVPrev {serverVRange = V.mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion}  -- before SKEY
         }
 
-testJoinConnectionAsyncReplyError :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testJoinConnectionAsyncReplyError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
   let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
   withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do
       (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
-        bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
+        bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
         ("1", bId', INV (ACR _ qInfo)) <- get a
         liftIO $ bId' `shouldBe` bId
         aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe
@@ -2702,7 +2776,7 @@ testDeleteUserQuietly =
     exchangeGreetingsMsgId 4 a bId b aId
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
-testUsersNoServer :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testUsersNoServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
   (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
@@ -3132,17 +3206,19 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
   where
     getClient clientId (clntAuth, clntVersion) db =
       let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]}
-          alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing
+          alpn_ = if clntVersion >= authCmdsSMPVersion then Just alpnSupportedSMPHandshakes else Nothing
           smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange minClientSMPRelayVersion clntVersion
           sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
        in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
 
-testSMPServerConnectionTest :: (ATransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
+testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
-  withSmpServerConfigOn t (cfgMS msType) {newQueueBasicAuth} testPort2 $ \_ -> do
+  withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
     -- initially passed server is not running
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
       testProtocolServer a 1 srv
+  where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
 
 testRatchetAdHash :: HasCallStack => IO ()
 testRatchetAdHash =
@@ -3172,7 +3248,7 @@ testDeliveryReceipts =
     ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
     ackMessage b aId 5 Nothing
 
-testDeliveryReceiptsVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testDeliveryReceiptsVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDeliveryReceiptsVersion ps = do
   a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
@@ -3225,9 +3301,9 @@ testDeliveryReceiptsVersion ps = do
     disposeAgentClient a'
     disposeAgentClient b'
 
-testDeliveryReceiptsConcurrent :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testDeliveryReceiptsConcurrent :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDeliveryReceiptsConcurrent (t, msType) =
-  withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do
+  withSmpServerConfigOn t cfg' testPort $ \_ -> do
     withAgentClients2 $ \a b -> do
       (aId, bId) <- runRight $ makeConnection a b
       t1 <- liftIO getCurrentTime
@@ -3237,6 +3313,7 @@ testDeliveryReceiptsConcurrent (t, msType) =
       liftIO $ noMessages a "nothing else should be delivered to alice"
       liftIO $ noMessages b "nothing else should be delivered to bob"
   where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 256, maxJournalMsgCount = 512}
     runClient :: String -> AgentClient -> ConnId -> IO ()
     runClient _cName client connId = do
       concurrently_ send receive
@@ -3577,7 +3654,7 @@ exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient
 exchangeGreetingsMsgId_ = exchangeGreetingsViaProxyMsgId_ False
 
 exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 
+exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2
 
 exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc msgId alice bobId bob aliceId = do

tests/AgentTests/MigrationTests.hs

@@ -11,7 +11,8 @@ import Simplex.Messaging.Agent.Store.Interface
 import Simplex.Messaging.Agent.Store.Migrations (migrationsToRun)
 import Simplex.Messaging.Agent.Store.Shared
 import System.Random (randomIO)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 #if defined(dbPostgres)
 import qualified Data.ByteString.Char8 as B
 import Database.PostgreSQL.Simple (fromOnly)

tests/AgentTests/NotificationTests.hs

@@ -8,6 +8,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
@@ -53,15 +55,12 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
-import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
-import qualified Data.Text.IO as TIO
 import Data.Time.Clock.System (systemToUTCTime)
 import qualified Database.PostgreSQL.Simple as PSQL
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
-import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, ntfTestPort, ntfTestPort2, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'')
+import SMPClient
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
@@ -81,17 +80,19 @@ import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
-import Simplex.Messaging.Transport (ATransport)
+import Simplex.Messaging.Transport (ASrvTransport)
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..))
 import System.Process (callCommand)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO
+import Util
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 #else
 import Database.SQLite.Simple.QQ (sql)
 #endif
 
-notificationTests :: (ATransport, AStoreType) -> Spec
+notificationTests :: (ASrvTransport, AStoreType) -> Spec
 notificationTests ps@(t, _) = do
   describe "Managing notification tokens" $ do
     it "should register and verify notification token" $
@@ -156,10 +157,10 @@ notificationTests ps@(t, _) = do
     it "should resume subscriptions after SMP server is restarted" $
       withAPNSMockServer $ \apns ->
         withNtfServer t $ testNotificationsSMPRestart ps apns
-  describe "Notifications after SMP server restart" $
+  describe "Notifications after SMP server restart (batched)" $
     it "should resume batched subscriptions after SMP server is restarted" $
       withAPNSMockServer $ \apns ->
-        withNtfServer t $ testNotificationsSMPRestartBatch 100 ps apns
+        withNtfServer t $ testNotificationsSMPRestartBatch 50 ps apns
   describe "should switch notifications to the new queue" $
     testServerMatrix2 ps $ \servers ->
       withAPNSMockServer $ \apns ->
@@ -174,8 +175,9 @@ notificationTests ps@(t, _) = do
       withAPNSMockServer $ \apns ->
         withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 . withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
           testNotificationsNewToken apns ntf
+  it "should migrate to service subscriptions" $ testMigrateToServiceSubscriptions ps
 
-testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
+testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
 testNtfMatrix ps@(_, msType) runTest = do
   describe "next and current" $ do
     it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest
@@ -192,9 +194,10 @@ testNtfMatrix ps@(_, msType) runTest = do
     cfg' = cfgMS msType
     cfgVPrev' = cfgVPrev msType
 
-runNtfTestCfg :: HasCallStack => (ATransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
+runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
 runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
-  let smpCfg' = smpCfg {serverStoreCfg = serverStoreConfig msType}
+  ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
+  let smpCfg' = withServerCfg smpCfg $ \cfg_ -> ASrvCfg qt mt cfg_ {serverStoreCfg}
   withSmpServerConfigOn t smpCfg' testPort $ \_ ->
     withAPNSMockServer $ \apns ->
       withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ ->
@@ -227,8 +230,6 @@ v .-> key = do
 
 testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration apns = do
-  -- setLogLevel LogError -- LogDebug
-  -- withGlobalLogging logCfg $ do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -248,8 +249,6 @@ testNtfTokenRepeatRegistration apns = do
 
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration apns =
-  -- setLogLevel LogError -- LogDebug
-  -- withGlobalLogging logCfg $ do
   withAgentClients2 $ \a a' -> runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -278,7 +277,7 @@ testNtfTokenSecondRegistration apns =
     NTActive <- checkNtfToken a' tkn
     pure ()
 
-testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -299,7 +298,7 @@ testNtfTokenServerRestart t apns = do
       NTActive <- checkNtfToken a' tkn
       pure ()
 
-testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverify t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a -> do
@@ -322,7 +321,7 @@ testNtfTokenServerRestartReverify t apns = do
       NTActive <- checkNtfToken a' tkn
       pure ()
 
-testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverifyTimeout t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -357,7 +356,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
       NTActive <- checkNtfToken a' tkn
       pure ()
 
-testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregister t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -381,7 +380,7 @@ testNtfTokenServerRestartReregister t apns = do
       NTActive <- checkNtfToken a' tkn
       pure ()
 
-testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregisterTimeout t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -422,7 +421,7 @@ getTestNtfTokenPort a =
     Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
     Nothing -> error "no active NtfToken"
 
-testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenMultipleServers t apns = do
   let tkn = DeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
@@ -446,7 +445,7 @@ testNtfTokenMultipleServers t apns = do
         Left _ <- tryError (checkNtfToken a tkn)
         pure ()
 
-testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenChangeServers t apns =
   withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do
     tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -476,7 +475,7 @@ testNtfTokenChangeServers t apns =
         tkn <- registerTestToken a "qwer" NMInstant apns
         checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
 
-testNtfTokenReRegisterInvalid :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenReRegisterInvalid :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenReRegisterInvalid t apns = do
   tkn <- withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -501,13 +500,7 @@ testNtfTokenReRegisterInvalid t apns = do
       NTActive <- checkNtfToken a tkn1
       pure ()
 
-replaceSubstringInFile :: FilePath -> Text -> Text -> IO ()
-replaceSubstringInFile filePath oldText newText = do
-  content <- TIO.readFile filePath
-  let newContent = T.replace oldText newText content
-  TIO.writeFile filePath newContent
-
-testNtfTokenReRegisterInvalidOnCheck :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenReRegisterInvalidOnCheck t apns = do
   tkn <- withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -532,7 +525,7 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
       NTActive <- checkNtfToken a tkn1
       pure ()
 
-testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
+testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
 testRunNTFServerTests t srv =
   withNtfServer t $
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -559,7 +552,6 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
     verifyNtfToken alice tkn vNonce verification
     NTActive <- checkNtfToken alice tkn
     -- send message
-    liftIO $ threadDelay 250000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     -- notification
@@ -571,11 +563,10 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
   -- alice client already has subscription for the connection,
   [Left (CMD PROHIBITED _)] <- getConnectionMessages alice [ConnMsgReq cId 1 $ Just $ systemToUTCTime msgTs]
 
-  threadDelay 500000
+  threadDelay 1000000
   suspendAgent alice 0
   closeDBStore store
   threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000
-  putStrLn "before opening the database from another agent"
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
   withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> do
@@ -583,7 +574,6 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
     pure ()
 
   threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000
-  putStrLn "after closing the database in another agent"
   reopenDBStore store
   foregroundAgent alice
   threadDelay 500000
@@ -741,7 +731,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d
     pure (aliceId, bobId)
 
   withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do
-    subscribeConnection alice1 bobId
+    void $ subscribeConnection alice1 bobId
     -- change notification token
     void $ registerTestToken alice1 "bcde" NMInstant apns
     -- send message, receive notification
@@ -757,7 +747,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d
     baseId = 1
     msgId = subtract baseId
 
-testNotificationsStoreLog :: (ATransport, AStoreType) -> APNSMockServer -> IO ()
+testNotificationsStoreLog :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
 testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
   withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
     (aliceId, bobId) <- withNtfServer t $ runRight $ do
@@ -792,7 +782,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
     withNtfServer t $ runRight_ $ do
       void $ messageNotificationData alice apns
 
-testNotificationsSMPRestart :: (ATransport, AStoreType) -> APNSMockServer -> IO ()
+testNotificationsSMPRestart :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
 testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
   (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
@@ -820,7 +810,7 @@ testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
 
-testNotificationsSMPRestartBatch :: Int -> (ATransport, AStoreType) -> APNSMockServer -> IO ()
+testNotificationsSMPRestartBatch :: Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
 testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
   withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     threadDelay 1000000
@@ -926,6 +916,94 @@ testNotificationsNewToken apns oldNtf =
     let testMessageAC = testMessage_ apns a acId c caId
     testMessageAC "greetings"
 
+testMigrateToServiceSubscriptions :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> do
+  (c1, c2, c3) <- withSmpServerConfigOn t cfgNoService testPort $ \_ -> do
+    (c1, c2) <- withAPNSMockServer $ \apns -> do
+      withNtfServerCfg ntfCfgNoService $ \_ -> runRight $ do
+        _tkn <- registerTestToken a "abcd" NMInstant apns
+        -- create 2 connections with ntfs, test delivery
+        c1 <- testConnectMsg apns a b "hello"
+        c2 <- testConnectMsg apns a b "hello too"
+        pure (c1, c2)
+    liftIO $ threadDelay 250000
+    fmap (c1,c2,) $ withAPNSMockServer $ \apns ->
+      withNtfServer t $ runRight $ do
+        liftIO $ threadDelay 250000
+        testSendMsg apns a b c1 "hello 1"
+        testSendMsg apns a b c2 "hello 2"
+        testConnectMsg apns a b "hello 3"
+  serverDOWN a b 3
+
+  -- this session creates association of subscriptions with service
+  c4 <- withAPNSMockServer $ \apns -> withSmpServer ps $ withNtfServer t $ do
+    serverUP a b 3
+    runRight $ do
+      liftIO $ threadDelay 250000
+      testSendMsg apns a b c1 "hey 1"
+      testSendMsg apns a b c2 "hey 2"
+      testSendMsg apns a b c3 "hey 3"
+      testConnectMsg apns a b "hey 4"
+  serverDOWN a b 4
+
+  -- this session uses service to subscribe
+  c5 <- withAPNSMockServer $ \apns -> withSmpServer ps $ withNtfServer t $ do
+    serverUP a b 4
+    runRight $ do
+      liftIO $ threadDelay 250000
+      testSendMsg apns a b c1 "hi 1"
+      testSendMsg apns a b c2 "hi 2"
+      testSendMsg apns a b c3 "hi 3"
+      testSendMsg apns a b c4 "hi 4"
+      testConnectMsg apns a b "hi 5"
+  serverDOWN a b 5
+
+  -- Ntf server does not use server, subscriptions downgrade
+  c6 <- withAPNSMockServer $ \apns -> withSmpServer ps $ withNtfServerCfg ntfCfgNoService $ \_ -> do
+    serverUP a b 5
+    runRight $ do
+      testSendMsg apns a b c1 "msg 1"
+      testSendMsg apns a b c2 "msg 2"
+      testSendMsg apns a b c3 "msg 3"
+      testSendMsg apns a b c4 "msg 4"
+      testSendMsg apns a b c5 "msg 5"
+      testConnectMsg apns a b "msg 6"
+  serverDOWN a b 6
+
+  withAPNSMockServer $ \apns -> withSmpServerConfigOn t cfgNoService testPort $ \_ -> withNtfServerCfg ntfCfgNoService $ \_ -> do
+    serverUP a b 6
+    runRight_ $ do
+      testSendMsg apns a b c1 "1"
+      testSendMsg apns a b c2 "2"
+      testSendMsg apns a b c3 "3"
+      testSendMsg apns a b c4 "4"
+      testSendMsg apns a b c5 "5"
+      testSendMsg apns a b c6 "6"
+      void $ testConnectMsg apns a b "7"
+  serverDOWN a b 7
+  where
+    testConnectMsg apns a b msg = do
+      conn <- makeConnection a b
+      liftIO $ threadDelay 250000
+      testSendMsg apns a b conn msg
+      pure conn
+    testSendMsg :: HasCallStack => APNSMockServer -> AgentClient -> AgentClient -> (ConnId, ConnId) -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
+    testSendMsg apns a b (abId, baId) = testMessage_ apns a abId b baId
+    serverDOWN a b n = do
+      ("", "", DOWN _ cs) <- nGet a
+      ("", "", DOWN _ cs') <- nGet b
+      length cs `shouldBe` n
+      length cs' `shouldBe` n
+    serverUP a b n = do
+      ("", "", UP _ cs) <- nGet a
+      ("", "", UP _ cs') <- nGet b
+      length cs `shouldBe` n
+      length cs' `shouldBe` n
+    cfgNoService = updateCfg (cfgMS msType) $ \(cfg' :: ServerConfig s) ->
+      let ServerConfig {transportConfig} = cfg'
+       in cfg' {transportConfig = transportConfig {askClientCert = False}} :: ServerConfig s
+    ntfCfgNoService = ntfServerCfg {useServiceCreds = False, transports = [(ntfTestPort, t, False)]}
+
 testMessage_ :: HasCallStack => APNSMockServer -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
 testMessage_ apns a aId b bId msg = do
   msgId <- sendMessage b aId (SMP.MsgFlags True) msg

tests/AgentTests/SQLiteTests.hs

@@ -49,14 +49,16 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
-import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn)
+import Simplex.Messaging.Crypto.Ratchet (pattern IKPQOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), QueueMode (..), pattern VersionSMPC)
+import Simplex.Messaging.Protocol (EntityId (..), QueueMode (..), SubscriptionMode (..), pattern VersionSMPC)
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Agent.Store.Entity
 import System.Random
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.Directory (removeFile)
+import Util
 
 testDB :: String
 testDB = "tests/tmp/smp-agent.test.db"
@@ -228,8 +230,9 @@ rcvQueue1 =
       sndId = EntityId "2345",
       queueMode = Just QMMessaging,
       shortLink = Nothing,
+      clientService = Nothing,
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = DBNewEntity,
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,
@@ -251,7 +254,7 @@ sndQueue1 =
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = DBNewEntity,
       primary = True,
       dbReplaceQueueId = Nothing,
       sndSwchStatus = Nothing,
@@ -270,11 +273,11 @@ testCreateRcvConn =
     g <- C.newRandom
     Right (connId, rq@RcvQueue {dbQueueId}) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     connId `shouldBe` "conn1"
-    dbQueueId `shouldBe` DBQueueId 1
+    dbQueueId `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
     Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+    dbQueueId' `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
 
@@ -286,7 +289,7 @@ testCreateRcvConnRandomId =
     getConn db connId
       `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq))
     Right sq@SndQueue {dbQueueId = dbQueueId'} <- upgradeRcvConnToDuplex db connId sndQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+    dbQueueId' `shouldBe` DBEntityId 1
     getConn db connId
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq]))
 
@@ -304,11 +307,11 @@ testCreateSndConn =
     g <- C.newRandom
     Right (connId, sq@SndQueue {dbQueueId}) <- createSndConn db g cData1 sndQueue1
     connId `shouldBe` "conn1"
-    dbQueueId `shouldBe` DBQueueId 1
+    dbQueueId `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
     Right rq@RcvQueue {dbQueueId = dbQueueId'} <- upgradeSndConnToDuplex db "conn1" rcvQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+    dbQueueId' `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
 
@@ -320,7 +323,7 @@ testCreateSndConnRandomID =
     getConn db connId
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq))
     Right (rq@RcvQueue {dbQueueId = dbQueueId'}) <- upgradeSndConnToDuplex db connId rcvQueue1
-    dbQueueId' `shouldBe` DBQueueId 1
+    dbQueueId' `shouldBe` DBEntityId 1
     getConn db connId
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq]))
 
@@ -411,7 +414,7 @@ testUpgradeRcvConnToDuplex =
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = DBNewEntity,
               sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -441,8 +444,9 @@ testUpgradeSndConnToDuplex =
               sndId = EntityId "4567",
               queueMode = Just QMMessaging,
               shortLink = Nothing,
+              clientService = Nothing,
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = DBNewEntity,
               rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -693,7 +697,7 @@ testGetPendingServerCommand st = do
     Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db connId (Just smpServer1)
     corrId' `shouldBe` "4"
   where
-    command = AClientCommand $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
+    command = AClientCommand $ NEW True (ACM SCMInvitation) IKPQOn SMSubscribe
     corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO ()
     corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
 

tests/AgentTests/SchemaDump.hs

@@ -18,7 +18,8 @@ import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmati
 import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 testDB :: FilePath
 testDB = "tests/tmp/test_agent_schema.db"

tests/AgentTests/ServerChoice.hs

@@ -14,8 +14,9 @@ import Simplex.Messaging.Agent.Client hiding (userServers)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Protocol
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import Test.QuickCheck
+import Util
 import XFTPClient (testXFTPServer)
 
 serverChoiceTests :: Spec

tests/AgentTests/ShortLinkTests.hs

@@ -8,10 +8,11 @@ import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest)
 import AgentTests.EqInstances ()
 import Control.Concurrent.STM
 import Control.Monad.Except
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), linkUserData, supportedSMPAgentVRange)
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SConnectionMode (..), SMPAgentError (..), UserLinkData (..), linkUserData, supportedSMPAgentVRange)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.ShortLink as SL
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 shortLinkTests :: Spec
 shortLinkTests = do
@@ -20,7 +21,7 @@ shortLinkTests = do
     it "should fail to decrypt invitation data with bad hash" testInvShortLinkBadDataHash
   describe "contact short link" $ do
     it "should encrypt and decrypt data" testContactShortLink
-    it "should encrypt updated user data" testUpdateContactShortLink    
+    it "should encrypt updated user data" testUpdateContactShortLink
     it "should fail to decrypt contact data with bad hash" testContactShortLinkBadDataHash
     it "should fail to decrypt contact data with bad signature" testContactShortLinkBadSignature
 
@@ -29,7 +30,7 @@ testInvShortLink = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData
       k = SL.invShortLinkKdf linkKey
   Right srvData <- runExceptT $ SL.encryptLinkData g k linkData
@@ -43,7 +44,7 @@ testInvShortLinkBadDataHash = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData
   -- different key
   linkKey <- LinkKey <$> atomically (C.randomBytes 32 g)
@@ -58,7 +59,7 @@ testContactShortLink = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right srvData <- runExceptT $ SL.encryptLinkData g k linkData
@@ -72,13 +73,13 @@ testUpdateContactShortLink = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData
   -- encrypt updated user data
-  let updatedUserData = "updated user data"
-      signed = SL.encodeSignUserData (snd sigKeys) supportedSMPAgentVRange updatedUserData
+  let updatedUserData = UserLinkData "updated user data"
+      signed = SL.encodeSignUserData SCMContact (snd sigKeys) supportedSMPAgentVRange updatedUserData
   Right ud' <- runExceptT $ SL.encryptUserData g k signed
   -- decrypt
   Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k (fd, ud')
@@ -90,7 +91,7 @@ testContactShortLinkBadDataHash = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
   -- different key
   linkKey <- LinkKey <$> atomically (C.randomBytes 32 g)
@@ -105,15 +106,15 @@ testContactShortLinkBadSignature = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let userData = "some user data"
+  let userData = UserLinkData "some user data"
       (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData
   -- encrypt updated user data
-  let updatedUserData = "updated user data"
+  let updatedUserData = UserLinkData "updated user data"
   -- another signature key
   (_, pk) <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let signed = SL.encodeSignUserData pk supportedSMPAgentVRange updatedUserData
+  let signed = SL.encodeSignUserData SCMContact pk supportedSMPAgentVRange updatedUserData
   Right ud' <- runExceptT $ SL.encryptUserData g k signed
   -- decryption fails
   SL.decryptLinkData @'CMContact linkKey k (fd, ud')

tests/CLITests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -23,7 +24,7 @@ import qualified Network.HTTP2.Client as H2
 import Simplex.FileTransfer.Server.Main (xftpServerCLI)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_)
-import Simplex.Messaging.Transport (TLS (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
+import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
@@ -35,12 +36,13 @@ import System.Environment (withArgs)
 import System.FilePath ((</>))
 import System.IO.Silently (capture_)
 import System.Timeout (timeout)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import Test.Main (withStdin)
 import UnliftIO (catchAny)
 import UnliftIO.Async (async, cancel)
 import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Exception (bracket)
+import Util
 
 #if defined(dbServerPostgres)
 import qualified Database.PostgreSQL.Simple as PSQL
@@ -163,7 +165,7 @@ smpServerTestStatic = do
 
     threadDelay 2000000
 
-    let cfgHttp = defaultTransportClientConfig {alpn = Just ["h2"], useSNI = True}
+    let cfgHttp = defaultTransportClientConfig {clientALPN = Just ["h2"], useSNI = True}
     runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfgHttp Nothing "localhost" "5223" (Just caHTTP) $ \tls -> do
       tlsALPN tls `shouldBe` Just "h2"
       case getCerts tls of
@@ -181,19 +183,19 @@ smpServerTestStatic = do
     -- "local" CA signing SMP credentials
     Fingerprint fpSMP <- loadFileFingerprint (cfgPath <> "/ca.crt")
     let caSMP = C.KeyHash fpSMP
-    let cfgSmp = defaultTransportClientConfig {alpn = Just ["smp/1"], useSNI = False}
+    let cfgSmp = defaultTransportClientConfig {clientALPN = Just ["smp/1"], useSNI = False}
     runTLSTransportClient defaultSupportedParams Nothing cfgSmp Nothing "localhost" "5223" (Just caSMP) $ \tls -> do
       tlsALPN tls `shouldBe` Just "smp/1"
       case getCerts tls of
         X.Certificate {X.certPubKey = X.PubKeyEd25519 _k} : _ca -> print _ca -- pure ()
         leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf
         [] -> error "Empty chain"
-      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False
+      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False Nothing
     logDebug "Combined SMP works"
   where
-    getCerts :: TLS -> [X.Certificate]
+    getCerts :: TLS 'TClient -> [X.Certificate]
     getCerts tls =
-      let X.CertificateChain cc = tlsServerCerts tls
+      let X.CertificateChain cc = tlsPeerCert tls
        in map (X.signedObject . X.getSigned) cc
 
 #if defined(dbServerPostgres)

tests/CoreTests/BatchingTests.hs

@@ -24,7 +24,8 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 batchingTests :: Spec
 batchingTests = do
@@ -34,7 +35,7 @@ batchingTests = do
       it "should break on message that does not fit" testBatchWithMessageV6
       it "should break on large message" testBatchWithLargeMessageV6
     describe "SMP current" $ do
-      it "should batch with 136 subscriptions per batch" testBatchSubscriptions
+      it "should batch with 135 subscriptions per batch" testBatchSubscriptions
       it "should break on message that does not fit" testBatchWithMessage
       it "should break on large message" testBatchWithLargeMessage
   describe "batchTransmissions'" $ do
@@ -43,7 +44,7 @@ batchingTests = do
       it "should break on message that does not fit" testClientBatchWithMessageV6
       it "should break on large message" testClientBatchWithLargeMessageV6
     describe "SMP current" $ do
-      it "should batch with 136 subscriptions per batch" testClientBatchSubscriptions
+      it "should batch with 135 subscriptions per batch" testClientBatchSubscriptions
       it "should batch with 255 ENDs per batch" testClientBatchENDs
       it "should batch with 80 NMSGs per batch" testClientBatchNMSGs
       it "should break on message that does not fit" testClientBatchWithMessage
@@ -53,10 +54,11 @@ testBatchSubscriptionsV6 :: IO ()
 testBatchSubscriptionsV6 = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   subs <- replicateM 250 $ randomSUBv6 sessId
-  let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
+  let thParams = testTHandleParams minServerSMPRelayVersion sessId
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 250
-  let batches = batchTransmissions True smpBlockSize $ L.fromList subs
+  let batches = batchTransmissions thParams $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
   (n1, n2, n3) `shouldBe` (38, 106, 106)
@@ -66,13 +68,14 @@ testBatchSubscriptions :: IO ()
 testBatchSubscriptions = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
   subs <- replicateM 300 $ randomSUB sessId
-  let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
+  let thParams = testTHandleParams currentClientSMPRelayVersion sessId
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 300
-  let batches = batchTransmissions True smpBlockSize $ L.fromList subs
+  let batches = batchTransmissions thParams $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (28, 136, 136)
+  (n1, n2, n3) `shouldBe` (30, 135, 135)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchWithMessageV6 :: IO ()
@@ -81,11 +84,12 @@ testBatchWithMessageV6 = do
   subs1 <- replicateM 60 $ randomSUBv6 sessId
   send <- randomSENDv6 sessId 8000
   subs2 <- replicateM 40 $ randomSUBv6 sessId
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  let thParams = testTHandleParams minServerSMPRelayVersion sessId
+      cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 101
-  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions thParams $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
   (n1, n2) `shouldBe` (47, 54)
@@ -97,14 +101,15 @@ testBatchWithMessage = do
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 8000
   subs2 <- replicateM 40 $ randomSUB sessId
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  let thParams = testTHandleParams currentClientSMPRelayVersion sessId
+      cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 101
-  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions thParams $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
-  (n1, n2) `shouldBe` (32, 69)
+  (n1, n2) `shouldBe` (33, 68)
   all lenOk [s1, s2] `shouldBe` True
 
 testBatchWithLargeMessageV6 :: IO ()
@@ -113,14 +118,15 @@ testBatchWithLargeMessageV6 = do
   subs1 <- replicateM 50 $ randomSUBv6 sessId
   send <- randomSENDv6 sessId 17000
   subs2 <- replicateM 150 $ randomSUBv6 sessId
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  let thParams = testTHandleParams minServerSMPRelayVersion sessId
+      cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
   length batches1 `shouldBe` 201
   let batches1' = take 50 batches1 <> drop 51 batches1
   all lenOk1 batches1' `shouldBe` True
   length batches1' `shouldBe` 200
-  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions thParams $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
   (n1, n2, n3) `shouldBe` (50, 44, 106)
@@ -132,26 +138,27 @@ testBatchWithLargeMessage = do
   subs1 <- replicateM 60 $ randomSUB sessId
   send <- randomSEND sessId 17000
   subs2 <- replicateM 150 $ randomSUB sessId
-  let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  let thParams = testTHandleParams currentClientSMPRelayVersion sessId
+      cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions thParams {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
   length batches1 `shouldBe` 211
   let batches1' = take 60 batches1 <> drop 61 batches1
   all lenOk1 batches1' `shouldBe` True
   length batches1' `shouldBe` 210
-  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions thParams $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 14, 136)
+  (n1, n2, n3) `shouldBe` (60, 15, 135)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchSubscriptionsV6 :: IO ()
 testClientBatchSubscriptionsV6 = do
   client <- testClientStubV6
   subs <- replicateM 250 $ randomSUBCmdV6 client
-  let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
+  let batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
+  let batches = batchTransmissions' (thParams client) $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
   (n1, n2, n3) `shouldBe` (38, 106, 106)
@@ -162,13 +169,13 @@ testClientBatchSubscriptions :: IO ()
 testClientBatchSubscriptions = do
   client <- testClientStub
   subs <- replicateM 300 $ randomSUBCmd client
-  let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
+  let batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
+  let batches = batchTransmissions' (thParams client) $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (28, 136, 136)
-  (length rs1, length rs2, length rs3) `shouldBe` (28, 136, 136)
+  (n1, n2, n3) `shouldBe` (30, 135, 135)
+  (length rs1, length rs2, length rs3) `shouldBe` (30, 135, 135)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchENDs :: IO ()
@@ -176,9 +183,9 @@ testClientBatchENDs = do
   client <- testClientStub
   ends <- replicateM 300 randomENDCmd
   let ends' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ends
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList ends'
+      batches1 = batchTransmissions (thParams client) {batch = False} $ L.fromList ends'
   all lenOk1 batches1 `shouldBe` True
-  let batches = batchTransmissions True smpBlockSize $ L.fromList ends'
+  let batches = batchTransmissions (thParams client) $ L.fromList ends'
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
   (n1, n2) `shouldBe` (45, 255)
@@ -191,9 +198,9 @@ testClientBatchNMSGs = do
   ts <- getSystemTime
   ntfs <- replicateM 200 $ randomNMSGCmd ts
   let ntfs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ntfs
-      batches1 = batchTransmissions False smpBlockSize $ L.fromList ntfs'
+      batches1 = batchTransmissions (thParams client) {batch = False} $ L.fromList ntfs'
   all lenOk1 batches1 `shouldBe` True
-  let batches = batchTransmissions True smpBlockSize $ L.fromList ntfs'
+  let batches = batchTransmissions (thParams client) $ L.fromList ntfs'
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
   (n1, n2, n3) `shouldBe` (40, 80, 80)
@@ -207,10 +214,10 @@ testClientBatchWithMessageV6 = do
   send <- randomSENDCmdV6 client 8000
   subs2 <- replicateM 40 $ randomSUBCmdV6 client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+      batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 101
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions' (thParams client) $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
   (n1, n2) `shouldBe` (47, 54)
@@ -224,14 +231,14 @@ testClientBatchWithMessage = do
   send <- randomSENDCmd client 8000
   subs2 <- replicateM 40 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+      batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` True
   length batches1 `shouldBe` 101
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions' (thParams client) $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
-  (n1, n2) `shouldBe` (32, 69)
-  (length rs1, length rs2) `shouldBe` (32, 69)
+  (n1, n2) `shouldBe` (33, 68)
+  (length rs1, length rs2) `shouldBe` (33, 68)
   all lenOk [s1, s2] `shouldBe` True
 
 testClientBatchWithLargeMessageV6 :: IO ()
@@ -241,14 +248,14 @@ testClientBatchWithLargeMessageV6 = do
   send <- randomSENDCmdV6 client 17000
   subs2 <- replicateM 150 $ randomSUBCmdV6 client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+      batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
   length batches1 `shouldBe` 201
   let batches1' = take 50 batches1 <> drop 51 batches1
   all lenOk1 batches1' `shouldBe` True
   length batches1' `shouldBe` 200
   --
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions' (thParams client) $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
   (n1, n2, n3) `shouldBe` (50, 44, 106)
@@ -256,7 +263,7 @@ testClientBatchWithLargeMessageV6 = do
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
-  let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
+  let batches' = batchTransmissions' (thParams client) $ L.fromList cmds'
   length batches' `shouldBe` 3
   [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
   (n1', n2') `shouldBe` (94, 106)
@@ -270,26 +277,26 @@ testClientBatchWithLargeMessage = do
   send <- randomSENDCmd client 17000
   subs2 <- replicateM 150 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
-      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+      batches1 = batchTransmissions' (thParams client) {batch = False} $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
   length batches1 `shouldBe` 211
   let batches1' = take 60 batches1 <> drop 61 batches1
   all lenOk1 batches1' `shouldBe` True
   length batches1' `shouldBe` 210
   --
-  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  let batches = batchTransmissions' (thParams client) $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 14, 136)
-  (length rs1, length rs2, length rs3) `shouldBe` (60, 14, 136)
+  (n1, n2, n3) `shouldBe` (60, 15, 135)
+  (length rs1, length rs2, length rs3) `shouldBe` (60, 15, 135)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
-  let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
+  let batches' = batchTransmissions' (thParams client) $ L.fromList cmds'
   length batches' `shouldBe` 3
   [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (74, 136)
-  (length rs1', length rs2') `shouldBe` (74, 136)
+  (n1', n2') `shouldBe` (75, 135)
+  (length rs1', length rs2') `shouldBe` (75, 135)
   all lenOk [s1', s2'] `shouldBe` True
 
 testClientStubV6 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
@@ -306,13 +313,14 @@ testClientStub = do
   thAuth_ <- testTHandleAuth currentClientSMPRelayVersion g rKey
   smpClientStub g sessId currentClientSMPRelayVersion thAuth_
 
-randomSUBv6 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUBv6 :: ByteString -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSUBv6 = randomSUB_ C.SEd25519 minServerSMPRelayVersion
 
-randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUB :: ByteString -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion
 
-randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+-- TODO [certs] test with the additional certificate signature
+randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSUB_ a v sessId = do
   g <- C.newRandom
   rId <- atomically $ C.randomBytes 24 g
@@ -321,7 +329,7 @@ randomSUB_ a v sessId = do
   thAuth_ <- testTHandleAuth v g rKey
   let thParams = testTHandleParams v sessId
       TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB)
-  pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth
+  pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) nonce tForAuth
 
 randomSUBCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
 randomSUBCmdV6 = randomSUBCmd_ C.SEd25519
@@ -334,7 +342,7 @@ randomSUBCmd_ a c = do
   g <- C.newRandom
   rId <- atomically $ C.randomBytes 24 g
   (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
-  mkTransmission c (Just rpKey, EntityId rId, Cmd SRecipient SUB)
+  mkTransmission c (EntityId rId, Just rpKey, Cmd SRecipient SUB)
 
 randomENDCmd :: IO (Transmission BrokerMsg)
 randomENDCmd = do
@@ -353,13 +361,13 @@ randomNMSGCmd ts = do
   Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128
   pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta)
 
-randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSENDv6 = randomSEND_ C.SEd25519 minServerSMPRelayVersion
 
-randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSEND = randomSEND_ C.SX25519 currentClientSMPRelayVersion
 
-randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
 randomSEND_ a v sessId len = do
   g <- C.newRandom
   sId <- atomically $ C.randomBytes 24 g
@@ -369,7 +377,7 @@ randomSEND_ a v sessId len = do
   msg <- atomically $ C.randomBytes len g
   let thParams = testTHandleParams v sessId
       TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
-  pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth
+  pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) nonce tForAuth
 
 testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient
 testTHandleParams v sessionId =
@@ -381,19 +389,20 @@ testTHandleParams v sessionId =
       thAuth = Nothing,
       implySessId = v >= authCmdsSMPVersion,
       encryptBlock = Nothing,
-      batch = True
+      batch = True,
+      serviceAuth = v >= serviceCertsSMPVersion
     }
 
 testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient))
-testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
+testTHandleAuth v g (C.APublicAuthKey a peerServerPubKey) = case a of
   C.SX25519 | v >= authCmdsSMPVersion -> do
     ca <- head <$> XS.readCertificates "tests/fixtures/ca.crt"
     serverCert <- head <$> XS.readCertificates "tests/fixtures/server.crt"
     serverKey <- head <$> XF.readKeyFile "tests/fixtures/server.key"
     signKey <- either error pure $ C.x509ToPrivate (serverKey, []) >>= C.privKey @C.APrivateSignKey
     (serverAuthPub, _) <- atomically $ C.generateKeyPair @'C.X25519 g
-    let serverCertKey = (X.CertificateChain [serverCert, ca], C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
-    pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
+    let peerServerCertKey = CertChainPubKey (X.CertificateChain [serverCert, ca]) (C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
+    pure $ Just THAuthClient {peerServerPubKey, peerServerCertKey, clientService = Nothing, sessSecret = Nothing}
   _ -> pure Nothing
 
 randomSENDCmdV6 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
@@ -408,7 +417,7 @@ randomSENDCmd_ a c len = do
   sId <- atomically $ C.randomBytes 24 g
   (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
   msg <- atomically $ C.randomBytes len g
-  mkTransmission c (Just rpKey, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
+  mkTransmission c (EntityId sId, Just rpKey, Cmd SSender $ SEND noMsgFlags msg)
 
 lenOk :: ByteString -> Bool
 lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2

tests/CoreTests/CryptoFileTests.hs

@@ -13,7 +13,8 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import System.Directory (getFileSize)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 cryptoFileTests :: Spec
 cryptoFileTests = do

tests/CoreTests/CryptoTests.hs

@@ -24,9 +24,10 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Transport.Client
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
+import Util
 
 cryptoTests :: Spec
 cryptoTests = do

tests/CoreTests/EncodingTests.hs

@@ -16,9 +16,10 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
+import Util
 
 int64 :: Int64
 int64 = 1234567890123456789

tests/CoreTests/MsgStoreTests.hs

@@ -10,8 +10,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module CoreTests.MsgStoreTests where
 
@@ -23,13 +23,14 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
+import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Base64.URL as B64
 import Data.List (isPrefixOf, isSuffixOf)
 import Data.Maybe (fromJust)
 import Data.Time.Clock (addUTCTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
 import Simplex.Messaging.Crypto (pattern MaxLenBS)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (EntityId (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags)
@@ -43,11 +44,11 @@ import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue)
-import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
 import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile)
 import System.FilePath ((</>))
 import System.IO (IOMode (..), withFile)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 msgStoreTests :: Spec
 msgStoreTests = do
@@ -130,7 +131,8 @@ testNewQueueRecData g qm queueData = do
             queueData,
             notifier = Nothing,
             status = EntityActive,
-            updatedAt = Nothing
+            updatedAt = Nothing,
+            rcvServiceId = Nothing
           }
   pure (rId, qr)
   where
@@ -204,7 +206,7 @@ testExportImportStore ms = do
   g <- C.newRandom
   (rId1, qr1) <- testNewQueueRec g QMMessaging
   (rId2, qr2) <- testNewQueueRec g QMMessaging
-  sl <- readWriteQueueStore True (mkQueue ms True) testStoreLogFile $ queueStore ms
+  sl <- readWriteQueueStore True (mkQueue ms True) testStoreLogFile $ stmQueueStore ms
   runRight_ $ do
     let write q s = writeMsg ms q True =<< mkMessage s
     q1 <- ExceptT $ addQueue ms rId1 qr1
@@ -229,7 +231,7 @@ testExportImportStore ms = do
   closeStoreLog sl
   let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2}
   ms' <- newMsgStore cfg
-  readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (queueStore ms') >>= closeStoreLog
+  readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (stmQueueStore ms') >>= closeStoreLog
   stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
     importMessages False ms' testStoreMsgsFile Nothing False
   printMessageStats "Messages" stats
@@ -256,7 +258,6 @@ testQueueState ms = do
   length . lines <$> readFile statePath `shouldReturn` 1
   readQueueState ms statePath `shouldReturn` (Just state, False)
   length <$> listDirectory dir `shouldReturn` 1 -- no backup
-
   let state1 =
         state
           { size = 1,
@@ -267,7 +268,6 @@ testQueueState ms = do
   length . lines <$> readFile statePath `shouldReturn` 2
   readQueueState ms statePath `shouldReturn` (Just state1, False)
   length <$> listDirectory dir `shouldReturn` 1 -- no backup
-
   let state2 =
         state
           { size = 2,
@@ -343,7 +343,7 @@ testRemoveJournals ms = do
   runRight $ do
     q <- ExceptT $ addQueue ms rId qr
     Just (Message {msgId = mId1}, True) <- write q "message 1"
-    Just (Message {msgId = mId2}, False) <- write q "message 2"    
+    Just (Message {msgId = mId2}, False) <- write q "message 2"
     (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
     (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
     liftIO $ closeMsgQueue ms q

tests/CoreTests/RetryIntervalTests.hs

@@ -8,14 +8,15 @@ import Control.Concurrent.STM
 import Control.Monad (when)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
 import Simplex.Messaging.Agent.RetryInterval
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 retryIntervalTests :: Spec
 retryIntervalTests = do
   describe "Retry interval with 2 modes and lock" $ do
     testRetryIntervalSameMode
     testRetryIntervalSwitchMode
-  describe "Foreground retry interval" $ do 
+  describe "Foreground retry interval" $ do
     testRetryForeground
     testRetryToBackground
     testRetrySkipWhenForeground
@@ -103,7 +104,7 @@ testRetryForeground =
       when (length ints < 8) $ loop
     (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
     (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
+      `shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
 
 testRetryToBackground :: Spec
 testRetryToBackground =
@@ -124,7 +125,7 @@ testRetryToBackground =
       )
     (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
     (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
+      `shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
 
 testRetrySkipWhenForeground :: Spec
 testRetrySkipWhenForeground =
@@ -149,7 +150,7 @@ testRetrySkipWhenForeground =
       )
     (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 3, 1]
     (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 10000, 10000, 15000, 22500, 33750, 40000, 10000]
+      `shouldReturn` [10000, 10000, 15000, 22500, 33750, 10000, 10000, 15000, 22500, 33750, 40000, 10000]
 
 addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
 addInterval intervals ts = do

tests/CoreTests/SOCKSSettings.hs

@@ -12,7 +12,8 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ErrorType)
 import Simplex.Messaging.Transport.Client
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 socksSettingsTests :: Spec
 socksSettingsTests = do
@@ -90,7 +91,7 @@ testSocksMode = do
   where
     transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
     transportSocksCfg cfg host =
-      let TransportClientConfig {socksProxy} = transportClientConfig cfg host False
+      let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing
        in socksProxy
 
 testSocksProxyEncoding :: Spec

tests/CoreTests/StoreLogTests.hs

@@ -17,6 +17,8 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (partitionEithers)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
+import qualified Data.X509 as X
+import qualified Data.X509.Validation as XV
 import SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -29,7 +31,10 @@ import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
-import Test.Hspec
+import Simplex.Messaging.Transport (SMPServiceRole (..))
+import Simplex.Messaging.Transport.Credentials (genCredentials)
+import Test.Hspec hiding (fit, it)
+import Util
 
 testPublicAuthKey :: C.APublicAuthKey
 testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
@@ -42,7 +47,8 @@ testNtfCreds g = do
     NtfCreds
       { notifierId = EntityId "ijkl",
         notifierKey,
-        rcvNtfDhSecret = C.dh' k pk
+        rcvNtfDhSecret = C.dh' k pk,
+        ntfServiceId = Nothing
       }
 
 data StoreLogTestCase r s = SLTC {name :: String, saved :: [r], state :: s, compacted :: [r]}
@@ -51,6 +57,8 @@ type SMPStoreLogTestCase = StoreLogTestCase StoreLogRecord (M.Map RecipientId Qu
 
 deriving instance Eq QueueRec
 
+deriving instance Eq ServiceRec
+
 deriving instance Eq StoreLogRecord
 
 deriving instance Eq NtfCreds
@@ -59,8 +67,8 @@ storeLogTests :: Spec
 storeLogTests =
   forM_ [QMMessaging, QMContact] $ \qm -> do
     g <- runIO C.newRandom
-    ((rId, qr), ntfCreds, date) <- runIO $
-      (,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate
+    ((rId, qr), ntfCreds, date, sr@ServiceRec {serviceId}) <- runIO $
+      (,,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate <*> newTestServiceRec g
     ((rId', qr'), lnkId, qd) <- runIO $ do
       lnkId <- atomically $ EntityId <$> C.randomBytes 24 g
       let qd = (EncDataBytes "fixed data", EncDataBytes "user data")
@@ -81,19 +89,19 @@ storeLogTests =
             saved = [CreateQueue rId' qr'],
             compacted = [CreateQueue rId' qr'],
             state = M.fromList [(rId', qr')]
-          },          
+          },
         SLTC
           { name = "create new queue, add link data",
             saved = [CreateQueue rId' qr' {queueData = Nothing}, CreateLink rId' lnkId qd],
             compacted = [CreateQueue rId' qr'],
             state = M.fromList [(rId', qr')]
-          },          
+          },
         SLTC
           { name = "create new queue with link data, delete data",
             saved = [CreateQueue rId' qr', DeleteLink rId'],
             compacted = [CreateQueue rId' qr' {queueData = Nothing}],
             state = M.fromList [(rId', qr' {queueData = Nothing})]
-          },          
+          },
         SLTC
           { name = "secure queue",
             saved = [CreateQueue rId qr, SecureQueue rId testPublicAuthKey],
@@ -112,6 +120,12 @@ storeLogTests =
             compacted = [CreateQueue rId qr {notifier = Just ntfCreds}],
             state = M.fromList [(rId, qr {notifier = Just ntfCreds})]
           },
+        SLTC
+          { name = "create queue, add notifier, register and associate notification service",
+            saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, NewService sr, QueueService rId (ASP SNotifierService) (Just serviceId)],
+            compacted = [NewService sr, CreateQueue rId qr {notifier = Just ntfCreds {ntfServiceId = Just serviceId}}],
+            state = M.fromList [(rId, qr {notifier = Just ntfCreds {ntfServiceId = Just serviceId}})]
+          },
         SLTC
           { name = "delete notifier",
             saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, DeleteNotifier rId],
@@ -132,6 +146,20 @@ storeLogTests =
           }
       ]
 
+newTestServiceRec :: TVar ChaChaDRG -> IO ServiceRec
+newTestServiceRec g = do
+  serviceId <- atomically $ EntityId <$> C.randomBytes 24 g
+  (_, cert) <- genCredentials g Nothing (0, 2400) "ntf.example.com"
+  serviceCreatedAt <- getSystemDate
+  pure
+    ServiceRec
+      { serviceId,
+        serviceRole = SRNotifier,
+        serviceCert  = X.CertificateChain [cert],
+        serviceCertHash = XV.getFingerprint cert X.HashSHA256,
+        serviceCreatedAt
+      }
+
 testSMPStoreLog :: String -> [SMPStoreLogTestCase] -> Spec
 testSMPStoreLog testSuite tests =
   describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
@@ -140,18 +168,19 @@ testSMPStoreLog testSuite tests =
     closeStoreLog l
     replicateM_ 3 $ testReadWrite t
 #if defined(dbServerPostgres)
-    qCnt <- fromIntegral <$> importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts
-    qCnt `shouldBe` length (compacted t)
+    (sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts
+    fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t)
     imported <- B.readFile $ testStoreLogFile <> ".bak"
-    qCnt' <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile
-    qCnt' `shouldBe` qCnt
+    (sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile
+    sCnt' `shouldBe` fromIntegral sCnt
+    qCnt' `shouldBe` fromIntegral qCnt
     exported <- B.readFile testStoreLogFile
     imported `shouldBe` exported
 #endif
   where
     testReadWrite SLTC {compacted, state} = do
       st <- newMsgStore $ testJournalStoreCfg MQStoreCfg
-      l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ queueStore st
+      l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ stmQueueStore st
       storeState st `shouldReturn` state
       closeStoreLog l
       ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile

tests/CoreTests/TRcvQueuesTests.hs

@@ -14,12 +14,14 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.String (IsString (..))
 import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
-import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..))
+import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
+import Simplex.Messaging.Agent.Store.Entity
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer, QueueMode (..), pattern NoEntity, pattern VersionSMPC)
-import Test.Hspec
+import Simplex.Messaging.Protocol (EntityId (..), QueueMode (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC)
+import Test.Hspec hiding (fit, it)
 import UnliftIO
+import Util
 
 tRcvQueuesTests :: Spec
 tRcvQueuesTests = do
@@ -120,7 +122,7 @@ getSessQueuesTest = do
   atomically (RQ.hasSessQueues tSess3 trq) `shouldReturn` False
   let tSess4 = (0, "smp://1234-w==@alpha", Nothing)
   RQ.getSessQueues tSess4 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"]
-  atomically (RQ.hasSessQueues tSess4 trq) `shouldReturn`True
+  atomically (RQ.hasSessQueues tSess4 trq) `shouldReturn` True
 
 getDelSessQueuesTest :: IO ()
 getDelSessQueuesTest = do
@@ -199,8 +201,9 @@ dummyRQ userId server connId rcvId =
       sndId = NoEntity,
       queueMode = Just QMMessaging,
       shortLink = Nothing,
+      clientService = Nothing,
       status = New,
-      dbQueueId = DBQueueId 0,
+      dbQueueId = DBEntityId 0,
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,

tests/CoreTests/UtilTests.hs

@@ -8,8 +8,9 @@ import Control.Monad.Except
 import Control.Monad.IO.Class
 import Data.IORef
 import Simplex.Messaging.Util
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import qualified UnliftIO.Exception as UE
+import Util
 
 utilTests :: Spec
 utilTests = do

tests/CoreTests/VersionRangeTests.hs

@@ -11,9 +11,10 @@ import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
+import Util
 
 data V = V1 | V2 | V3 | V4 | V5 deriving (Eq, Enum, Ord, Generic, Show)
 

tests/FileDescriptionTests.hs

@@ -16,7 +16,8 @@ import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Protocol (EntityId (..))
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import System.Directory (removeFile)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 fileDescriptionTests :: Spec
 fileDescriptionTests = do

tests/NtfClient.hs

@@ -34,7 +34,7 @@ import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
-import SMPClient (defaultStartOptions, ntfTestPort, prevRange, serverBracket)
+import SMPClient (defaultStartOptions, ntfTestPort, ntfTestServerCredentials, prevRange, serverBracket)
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
@@ -55,7 +55,7 @@ import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.Server
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
@@ -83,7 +83,7 @@ ntfTestPrometheusMetricsFile :: FilePath
 ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt"
 
 ntfTestStoreDBOpts :: DBOpts
-ntfTestStoreDBOpts = 
+ntfTestStoreDBOpts =
   DBOpts
     { connstr = ntfTestServerDBConnstr,
       schema = "ntf_server",
@@ -99,10 +99,10 @@ ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db"
 
 ntfTestServerDBConnectInfo :: ConnectInfo
 ntfTestServerDBConnectInfo =
-  defaultConnectInfo {
-    connectUser = "ntf_test_server_user",
-    connectDatabase = "ntf_test_server_db"
-  }
+  defaultConnectInfo
+    { connectUser = "ntf_test_server_user",
+      connectDatabase = "ntf_test_server_db"
+    }
 
 ntfTestDBCfg :: PostgresStoreCfg
 ntfTestDBCfg =
@@ -120,7 +120,7 @@ testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
   runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
-    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False) >>= \case
+    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False Nothing) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -134,7 +134,6 @@ ntfServerCfg =
       subIdBytes = 24,
       regCodeBytes = 32,
       clientQSize = 2,
-      subQSize = 2,
       pushQSize = 2,
       smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
       apnsConfig =
@@ -145,12 +144,8 @@ ntfServerCfg =
       subsBatchSize = 900,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       dbStoreConfig = ntfTestDBCfg,
-      ntfCredentials =
-        ServerCredentials
-          { caCertificateFile = Just "tests/fixtures/ca.crt",
-            privateKeyFile = "tests/fixtures/server.key",
-            certificateFile = "tests/fixtures/server.crt"
-          },
+      ntfCredentials = ntfTestServerCredentials,
+      useServiceCreds = True,
       periodicNtfsInterval = 1,
       -- stats config
       logStatsInterval = Nothing,
@@ -160,7 +155,7 @@ ntfServerCfg =
       prometheusInterval = Nothing,
       prometheusMetricsFile = ntfTestPrometheusMetricsFile,
       ntfServerVRange = supportedServerNTFVRange,
-      transportConfig = defaultTransportServerConfig,
+      transportConfig = mkTransportServerConfig True (Just alpnSupportedNTFHandshakes) False,
       startOptions = defaultStartOptions
     }
 
@@ -175,7 +170,7 @@ ntfServerCfgVPrev =
     smpCfg' = smpCfg smpAgentCfg'
     serverVRange' = serverVRange smpCfg'
 
-withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
+withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
 withNtfServerThreadOn t port' dbStoreConfig =
   withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
 
@@ -188,10 +183,10 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
         (\started -> runNtfServerBlocking started cfg)
         (pure ())
 
-withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
+withNtfServerOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
 withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const
 
-withNtfServer :: HasCallStack => ATransport -> (HasCallStack => IO a) -> IO a
+withNtfServer :: HasCallStack => ASrvTransport -> (HasCallStack => IO a) -> IO a
 withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg
 
 runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
@@ -200,21 +195,21 @@ runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 ntfServerTest ::
   forall c smp.
   (Transport c, Encoding smp) =>
-  TProxy c ->
-  (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
-  IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
+  TProxy c 'TServer ->
+  (Maybe TAuthorizations, ByteString, ByteString, smp) ->
+  IO (Maybe TAuthorizations, ByteString, ByteString, NtfResponse)
 ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
   where
-    tPut' :: THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
+    tPut' :: THandleNTF c 'TClient -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO ()
     tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
       let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
       [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
-      [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
+      [(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h
       pure (Nothing, corrId, qId, cmd)
 
-ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation
+ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
 ntfTest _ test' = runNtfTest test' `shouldReturn` ()
 
 data APNSMockRequest = APNSMockRequest
@@ -243,10 +238,10 @@ apnsMockServerConfig =
             privateKeyFile = "tests/fixtures/server.key",
             certificateFile = "tests/fixtures/server.crt"
           },
-      transportConfig = defaultTransportServerConfig
+      transportConfig = mkTransportServerConfig True Nothing False
     }
 
-withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
+withAPNSMockServer :: (APNSMockServer -> IO a) -> IO a
 withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
 
 deriving instance Generic APNSAlertBody
@@ -274,7 +269,7 @@ deriving instance ToJSON APNSErrorResponse
 
 getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
 getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
-  http2Server <- getHTTP2Server config Nothing
+  http2Server <- getHTTP2Server config
   notifications <- TM.emptyIO
   action <- async $ runAPNSMockServer notifications http2Server
   pure APNSMockServer {action, notifications, http2Server}

tests/NtfServerTests.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
@@ -42,18 +43,20 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Transport (THandleNTF)
 import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
+import Simplex.Messaging.Server.Env.STM (AStoreType)
 import Simplex.Messaging.Transport
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.STM
+import Util
 
-ntfServerTests :: ATransport -> Spec
-ntfServerTests t = do
+ntfServerTests :: (ASrvTransport, AStoreType) -> Spec
+ntfServerTests ps@(t, _) = do
   describe "Notifications server protocol syntax" $ ntfSyntaxTests t
-  describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY
-  -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW
-  describe "Retried notification subscription" $ testRetriedNtfSubscription t
+  describe "Notification subscriptions (NKEY)" $ testNotificationSubscription ps createNtfQueueNKEY
+  -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription ps createNtfQueueNEW
+  describe "Retried notification subscription" $ testRetriedNtfSubscription ps
 
-ntfSyntaxTests :: ATransport -> Spec
+ntfSyntaxTests :: ASrvTransport -> Spec
 ntfSyntaxTests (ATransport t) = do
   it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", NRErr $ CMD UNKNOWN)
   describe "NEW" $ do
@@ -64,29 +67,29 @@ ntfSyntaxTests (ATransport t) = do
   where
     (>#>) ::
       Encoding smp =>
-      (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
-      (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse) ->
+      (Maybe TAuthorizations, ByteString, ByteString, smp) ->
+      (Maybe TAuthorizations, ByteString, ByteString, NtfResponse) ->
       Expectation
     command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
 
-pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse
-pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
+pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> Transmission (Either ErrorType NtfResponse)
+pattern RespNtf corrId queueId command <- (corrId, queueId, Right command)
 
 deriving instance Eq NtfResponse
 
-sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TAuthorizations, ByteString, NtfEntityId, NtfCommand e) -> IO (Transmission (Either ErrorType NtfResponse))
 sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do
   let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (sgn, tToSend)
   tGet1 h
 
-signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, NtfEntityId, NtfCommand e) -> IO (Transmission (Either ErrorType NtfResponse))
 signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (authorize tForAuth, tToSend)
   tGet1 h
   where
-    authorize t = case a of
+    authorize t = (,Nothing) <$> case a of
       C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t
       C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t
       _ -> Nothing
@@ -96,8 +99,8 @@ v .-> key =
   let J.Object o = v
    in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
 
-testNotificationSubscription :: ATransport -> CreateQueueFunc -> Spec
-testNotificationSubscription (ATransport t) createQueue =
+testNotificationSubscription :: (ASrvTransport, AStoreType) -> CreateQueueFunc -> Spec
+testNotificationSubscription (ATransport t, msType) createQueue =
   it "should create notification subscription and notify when message is received" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -106,7 +109,7 @@ testNotificationSubscription (ATransport t) createQueue =
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
     let tkn = DeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \apns ->
-      smpTest2' t $ \rh sh ->
+      smpTest2 t msType $ \rh sh ->
         ntfTest t $ \nh -> do
           ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) <- createQueue rh sPub nPub
           -- register and verify token
@@ -179,14 +182,14 @@ testNotificationSubscription (ATransport t) createQueue =
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId
 
-testRetriedNtfSubscription :: ATransport -> Spec
-testRetriedNtfSubscription (ATransport t) =
+testRetriedNtfSubscription :: (ASrvTransport, AStoreType) -> Spec
+testRetriedNtfSubscription (ATransport t, msType) =
   it "should allow retrying to create notification subscription with the same token and key" $ do
     g <- C.newRandom
     (sPub, _sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     withAPNSMockServer $ \apns ->
-      smpTest' t $ \h ->
+      smpTest t msType $ \h ->
         ntfTest t $ \nh -> do
           ((_sId, _rId, _rKey, _rcvDhSecret), nId, _rcvNtfDhSecret) <- createNtfQueueNKEY h sPub nPub
           (tknKey, _dhSecret, tId, regCode) <- registerToken nh apns "abcd"
@@ -243,7 +246,7 @@ registerToken nh apns token = do
         let Right verification = nd .-> "verification"
             Right nonce = C.cbNonce <$> nd .-> "nonce"
             Right pt = C.cbDecrypt dhSecret nonce verification
-          in NtfRegCode pt
+         in NtfRegCode pt
   let code = decryptCode ntfData
   pure (tknKey, dhSecret, tId, code)
 

tests/PostgresSchemaDump.hs

@@ -15,9 +15,9 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Directory (doesFileExist, removeFile)
-import System.Environment (lookupEnv)
 import System.Process (readCreateProcess, shell)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 
 testSchemaPath :: FilePath
 testSchemaPath = "tests/tmp/test_schema.sql"
@@ -57,7 +57,7 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
 
     getSchema :: FilePath -> IO String
     getSchema schemaPath = do
-      ci <- (Just "true" ==) <$> lookupEnv "CI"
+      ci <- envCI
       let cmd =
             ("pg_dump " <> B.unpack connstr <> " --schema " <> B.unpack testDBSchema)
               <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > "

tests/RemoteControl.hs

@@ -19,9 +19,10 @@ import qualified Simplex.RemoteControl.Client as RC
 import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress)
 import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation)
 import Simplex.RemoteControl.Types
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO
 import UnliftIO.Concurrent
+import Util
 
 remoteControlTests :: Spec
 remoteControlTests = do