6.4.0.7

* agent: setInvitationShortLink api

* Eq instance

* allow changing link data on server, refactor

* fix

* encodings

* remove link data after connection

* Revert "encodings"

This reverts commit f8e254cca9.

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

apps/ntf-server/Main.hs

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

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.4.0.1
+version:        6.4.0.7
 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
@@ -216,15 +217,6 @@ library
           Simplex.FileTransfer.Server.Stats
           Simplex.FileTransfer.Server.Store
           Simplex.FileTransfer.Server.StoreLog
-          Simplex.Messaging.Notifications.Server
-          Simplex.Messaging.Notifications.Server.Control
-          Simplex.Messaging.Notifications.Server.Env
-          Simplex.Messaging.Notifications.Server.Main
-          Simplex.Messaging.Notifications.Server.Push.APNS
-          Simplex.Messaging.Notifications.Server.Push.APNS.Internal
-          Simplex.Messaging.Notifications.Server.Stats
-          Simplex.Messaging.Notifications.Server.Store
-          Simplex.Messaging.Notifications.Server.StoreLog
           Simplex.Messaging.Server
           Simplex.Messaging.Server.CLI
           Simplex.Messaging.Server.Control
@@ -257,6 +249,19 @@ library
 
       if flag(server_postgres)
           exposed-modules:
+              Simplex.Messaging.Notifications.Server
+              Simplex.Messaging.Notifications.Server.Control
+              Simplex.Messaging.Notifications.Server.Env
+              Simplex.Messaging.Notifications.Server.Main
+              Simplex.Messaging.Notifications.Server.Prometheus
+              Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push.APNS.Internal
+              Simplex.Messaging.Notifications.Server.Stats
+              Simplex.Messaging.Notifications.Server.Store
+              Simplex.Messaging.Notifications.Server.Store.Migrations
+              Simplex.Messaging.Notifications.Server.Store.Postgres
+              Simplex.Messaging.Notifications.Server.Store.Types
+              Simplex.Messaging.Notifications.Server.StoreLog
               Simplex.Messaging.Server.QueueStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres.Migrations
   other-modules:
@@ -304,6 +309,7 @@ library
     , network-transport ==0.5.6
     , network-udp ==0.0.*
     , random >=1.1 && <1.3
+    , scientific ==0.3.7.*
     , simple-logger ==0.1.*
     , socks ==0.6.*
     , stm ==2.5.*
@@ -340,6 +346,8 @@ library
       , sqlcipher-simple ==0.4.*
   if flag(server_postgres)
     cpp-options: -DdbServerPostgres
+    build-depends:
+        hex-text ==0.1.*
   if impl(ghc >= 9.6.2)
     build-depends:
         bytestring ==0.11.*
@@ -352,6 +360,10 @@ library
 executable ntf-server
   if flag(client_library)
       buildable: False
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres
+  else
+    buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
@@ -444,7 +456,6 @@ test-suite simplexmq-test
       AgentTests.EqInstances
       AgentTests.FunctionalAPITests
       AgentTests.MigrationTests
-      AgentTests.NotificationTests
       AgentTests.ServerChoice
       AgentTests.ShortLinkTests
       CLITests
@@ -460,8 +471,6 @@ test-suite simplexmq-test
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
-      NtfClient
-      NtfServerTests
       RemoteControl
       ServerTests
       SMPAgentClient
@@ -484,7 +493,10 @@ test-suite simplexmq-test
           AgentTests.SQLiteTests
   if flag(server_postgres)
       other-modules:
-          ServerTests.SchemaDump  
+          AgentTests.NotificationTests
+          NtfClient
+          NtfServerTests
+          PostgresSchemaDump
   hs-source-dirs:
       tests
       apps/smp-server/web
@@ -509,6 +521,7 @@ test-suite simplexmq-test
     , generic-random ==1.5.*
     , hashable
     , hspec ==2.11.*
+    , hspec-core ==2.11.*
     , http-client
     , http-types
     , http2
@@ -537,6 +550,8 @@ test-suite simplexmq-test
     , warp-tls
     , yaml
   default-language: Haskell2010
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres
   if flag(client_postgres)
     cpp-options: -DdbPostgres
   else
@@ -550,5 +565,3 @@ test-suite simplexmq-test
   if flag(client_postgres) || flag(server_postgres)
     build-depends:
         postgresql-simple ==0.7.*
-  if flag(server_postgres)
-    cpp-options: -DdbServerPostgres

src/Simplex/FileTransfer/Client.hs

@@ -56,7 +56,7 @@ import Simplex.Messaging.Protocol
     SenderId,
     pattern NoEntity,
   )
-import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
@@ -147,12 +147,12 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
         Nothing -> throwE $ PCETransportError TEVersion
         Just (Compatible vr) ->
           fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do
-            let (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

src/Simplex/FileTransfer/Client/Main.hs

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

src/Simplex/FileTransfer/Server.hs

@@ -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 (ALPN, CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
@@ -110,7 +110,7 @@ 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
       env <- ask
@@ -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
@@ -181,7 +181,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     stopServer = do
       withFileLog closeStoreLog
       saveServerStats
-      logInfo "Server stopped"
+      logNote "Server stopped"
 
     expireFilesThread_ :: XFTPServerConfig -> [M ()]
     expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
@@ -560,13 +560,13 @@ expireServerFiles itemDelay expCfg = do
   usedStart <- readTVarIO $ usedStorage st
   old <- liftIO $ expireBeforeEpoch expCfg
   files' <- readTVarIO (files st)
-  logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
+  logNote $ "Expiration check: " <> tshow (M.size files') <> " files"
   forM_ (M.keys files') $ \sId -> do
     mapM_ threadDelay itemDelay
     atomically (expiredFilePath st sId old)
       >>= mapM_ (maybeRemove $ delete st sId)
   usedEnd <- readTVarIO $ usedStorage st
-  logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
+  logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
   where
     mbs bs = tshow (bs `div` 1048576) <> "mb"
     maybeRemove del = maybe del (remove del)
@@ -600,15 +600,15 @@ saveServerStats =
     >>= mapM_ (\f -> asks serverStats >>= liftIO . getFileServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
+      logNote $ "saving server stats to file " <> T.pack f
       B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
+      logNote "server stats saved"
 
 restoreServerStats :: M ()
 restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
+      logNote $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d@FileServerStatsData {_filesCount = statsFilesCount, _filesSize = statsFilesSize} -> do
           s <- asks serverStats
@@ -617,10 +617,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
           _filesSize <- readTVarIO usedStorage
           liftIO $ setFileServerStats s d {_filesCount, _filesSize}
           renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
+          logNote "server stats restored"
           when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount
           when (statsFilesSize /= _filesSize) $ logWarn $ "Files size differs: stats: " <> tshow statsFilesSize <> ", store: " <> tshow _filesSize
-          logInfo $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
+          logNote $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
         Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
+          logNote $ "error restoring server stats: " <> T.pack e
           liftIO exitFailure

src/Simplex/FileTransfer/Server/Env.hs

@@ -103,8 +103,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede
   used <- countUsedStorage <$> readTVarIO (files store)
   atomically $ writeTVar (usedStorage store) used
   forM_ fileSizeQuota $ \quota -> do
-    logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
-    when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
+    logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
+    when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!"
   tlsServerCreds <- loadServerCredential xftpCredentials
   Fingerprint fp <- loadFingerprint xftpCredentials
   serverStats <- newFileServerStats =<< getCurrentTime

src/Simplex/FileTransfer/Transport.hs

@@ -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, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
 import Simplex.Messaging.Util (bshow, tshow)
 import Simplex.Messaging.Version
@@ -102,7 +101,7 @@ 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 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
 xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
 
 supportedXFTPhandshakes :: [ALPN]
@@ -112,7 +111,7 @@ 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,
@@ -216,6 +216,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
@@ -371,13 +372,13 @@ createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enab
 {-# 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 -> ConnInfo -> 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)
@@ -439,7 +440,7 @@ subscribeConnections c = withAgentEnv c . subscribeConnections' c
 {-# INLINE subscribeConnections #-}
 
 -- | Get messages for connections (GET commands)
-getConnectionMessages :: AgentClient -> NonEmpty ConnId -> IO (NonEmpty (Maybe SMPMsgMeta))
+getConnectionMessages :: AgentClient -> NonEmpty ConnMsgReq -> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
 getConnectionMessages c = withAgentEnv' c . getConnectionMessages' c
 {-# INLINE getConnectionMessages #-}
 
@@ -832,43 +833,57 @@ newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
   (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 -> ConnInfo -> 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"
+          unless (shortLinkId == linkId) $ throwE $ INTERNAL "setConnShortLink: link ID is not derived from link"
           d <- liftError id $ SL.encryptUserData g k $ SL.encodeSignUserData linkPrivSigKey smpAgentVRange userData
-          pure (linkId, shortLinkKey, (linkEncFixedData, d))
+          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 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)
@@ -934,7 +949,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
     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
@@ -1122,7 +1137,7 @@ joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMo
     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))
 
@@ -1276,24 +1291,26 @@ resubscribeConnections' c connIds = do
   -- union is left-biased, so results returned by subscribeConnections' take precedence
   (`M.union` r) <$> subscribeConnections' c connIds'
 
-getConnectionMessages' :: AgentClient -> NonEmpty ConnId -> AM' (NonEmpty (Maybe SMPMsgMeta))
-getConnectionMessages' c = mapM getMsg
+-- requesting messages sequentially, to reduce memory usage
+getConnectionMessages' :: AgentClient -> NonEmpty ConnMsgReq -> AM' (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta)))
+getConnectionMessages' c = mapM $ tryAgentError' . getConnectionMessage
   where
-    getMsg :: ConnId -> AM' (Maybe SMPMsgMeta)
-    getMsg connId =
-      getConnectionMessage connId `catchAgentError'` \e -> do
-        logError $ "Error loading message: " <> tshow e
-        pure Nothing
-    getConnectionMessage :: ConnId -> AM (Maybe SMPMsgMeta)
-    getConnectionMessage connId = do
+    getConnectionMessage :: ConnMsgReq -> AM (Maybe SMPMsgMeta)
+    getConnectionMessage (ConnMsgReq connId dbQueueId msgTs_) = do
       whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
       SomeConn _ conn <- withStore c (`getConn` connId)
-      case conn of
-        DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
-        RcvConnection _ rq -> getQueueMessage c rq
-        ContactConnection _ rq -> getQueueMessage c rq
+      rq <- case conn of
+        DuplexConnection _ (rq :| _) _ -> pure rq
+        RcvConnection _ rq -> pure rq
+        ContactConnection _ rq -> pure rq
         SndConnection _ _ -> throwE $ CONN SIMPLEX
         NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
+      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 (DBEntityId dbQueueId) msgTs
+      pure msg_
+{-# INLINE getConnectionMessages' #-}
 
 getNotificationConns' :: AgentClient -> C.CbNonce -> ByteString -> AM (NonEmpty NotificationInfo)
 getNotificationConns' c nonce encNtfInfo =
@@ -1308,7 +1325,7 @@ getNotificationConns' c nonce encNtfInfo =
               lastNtfInfo = Just . fst <$$> getNtfInfo db lastNtf
            in initNtfInfos <> [lastNtfInfo]
       let (errs, ntfInfos_) = partitionEithers rs
-      logError $ "Error(s) loading notifications: " <> tshow errs
+      unless (null errs) $ logError $ "Error(s) loading notifications: " <> tshow errs
       case L.nonEmpty $ catMaybes ntfInfos_ of
         Just r -> pure r
         Nothing -> throwE $ INTERNAL "getNotificationConns: couldn't get conn info"
@@ -1316,17 +1333,18 @@ getNotificationConns' c nonce encNtfInfo =
   where
     getNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (NotificationInfo, Maybe UTCTime))
     getNtfInfo db PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = runExceptT $ do
-      (ntfConnId, rcvNtfDhSecret, lastBrokerTs_) <- liftError' storeError $ getNtfRcvQueue db smpQueue
+      (ntfConnId, ntfDbQueueId, rcvNtfDhSecret, lastBrokerTs_) <- liftError' storeError $ getNtfRcvQueue db smpQueue
       let ntfMsgMeta = eitherToMaybe $ smpDecode =<< first show (C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta)
-          ntfInfo = NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}
+          ntfInfo = NotificationInfo {ntfConnId, ntfDbQueueId, ntfTs, ntfMsgMeta}
       pure (ntfInfo, lastBrokerTs_)
     getInitNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (Maybe NotificationInfo))
     getInitNtfInfo db msgData = runExceptT $ do
-      (nftInfo, lastBrokerTs_) <- ExceptT $ getNtfInfo db msgData
-      pure $ case (ntfMsgMeta nftInfo, lastBrokerTs_) of
-        (Just SMP.NMsgMeta {msgTs}, Just lastBrokerTs)
-          | systemToUTCTime msgTs > lastBrokerTs -> Just nftInfo
+      (ntfInfo, lastBrokerTs_) <- ExceptT $ getNtfInfo db msgData
+      pure $ case ntfMsgMeta ntfInfo of
+        Just SMP.NMsgMeta {msgTs}
+          | maybe True (systemToUTCTime msgTs >) lastBrokerTs_ -> Just ntfInfo
         _ -> Nothing
+{-# INLINE getNotificationConns' #-}
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
@@ -1907,7 +1925,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
@@ -2197,10 +2215,9 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
               atomically $ nsUpdateToken ns tkn'
               agentNtfCheckToken c tknId tkn' >>= \case
                 NTActive -> do
-                  cron <- asks $ ntfCron . config
-                  agentNtfEnableCron c tknId tkn cron
                   when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
                   when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
+                  lift $ setCronInterval c tknId tkn
                   t tkn' (NTActive, Just NTACheck) $ pure ()
                 status -> t tkn' (status, Nothing) $ pure ()
           | otherwise -> replaceToken tknId
@@ -2261,11 +2278,15 @@ verifyNtfToken' c deviceToken nonce code =
         withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
           agentNtfVerifyToken c tknId tkn code'
       when (toStatus == NTActive) $ do
-        cron <- asks $ ntfCron . config
-        agentNtfEnableCron c tknId tkn cron
+        lift $ setCronInterval c tknId tkn
         when (ntfMode == NMInstant) $ initializeNtfSubs c
     _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token"
 
+setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' ()
+setCronInterval c tknId tkn = do
+  cron <- asks $ ntfCron . config
+  void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c tknId tkn cron
+
 checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus
 checkNtfToken' c deviceToken =
   withStore' c getSavedNtfToken >>= \case
@@ -2934,7 +2955,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
@@ -3272,7 +3293,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

@@ -77,7 +77,7 @@ module Simplex.Messaging.Agent.Client
     agentNtfCheckToken,
     agentNtfReplaceToken,
     agentNtfDeleteToken,
-    agentNtfEnableCron,
+    agentNtfSetCronInterval,
     agentNtfCreateSubscription,
     agentNtfCreateSubscriptions,
     agentNtfCheckSubscription,
@@ -278,6 +278,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)
@@ -326,6 +327,7 @@ data AgentClient = AgentClient
     xftpServers :: TMap UserId (UserServers 'PXFTP),
     xftpClients :: TMap XFTPTransportSession XFTPClientVar,
     useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
+    presetSMPDomains :: [HostName],
     userNetworkInfo :: TVar UserNetworkInfo,
     userNetworkUpdated :: TVar (Maybe UTCTime),
     subscrConns :: TVar (Set ConnId),
@@ -478,7 +480,7 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
 newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient
-newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
+newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomains} currentTs agentEnv = do
   let cfg = config agentEnv
       qSize = tbqSize cfg
   proxySessTs <- newTVarIO =<< getCurrentTime
@@ -532,6 +534,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
         xftpServers,
         xftpClients,
         useNetworkConfig,
+        presetSMPDomains = presetDomains,
         userNetworkInfo,
         userNetworkUpdated,
         subscrConns,
@@ -690,7 +693,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _)
       env <- ask
       liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
         ts <- readTVarIO proxySessTs
-        smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
+        smp <- ExceptT $ getProtocolClient g tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
         pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
 
 smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
@@ -793,7 +796,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS
       g <- asks random
       ts <- readTVarIO proxySessTs
       liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
-        getProtocolClient g tSess cfg Nothing ts $
+        getProtocolClient g tSess cfg [] Nothing ts $
           clientDisconnected v
 
     clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -1081,7 +1084,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) ->
@@ -1225,7 +1228,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   liftIO $ do
     let tSess = (userId, srv, Nothing)
     ts <- readTVarIO $ proxySessTs c
-    getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
+    getProtocolClient g tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case
       Right smp -> do
         rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
         (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
@@ -1302,7 +1305,7 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
   liftIO $ do
     let tSess = (userId, srv, Nothing)
     ts <- readTVarIO $ proxySessTs c
-    getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
+    getProtocolClient g tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case
       Right ntf -> do
         (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
         (dhKey, _) <- atomically $ C.generateKeyPair g
@@ -1393,7 +1396,7 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
             queueMode,
             shortLink,
             status = New,
-            dbQueueId = DBNewQueue,
+            dbQueueId = DBNewEntity,
             primary = True,
             dbReplaceQueueId = Nothing,
             rcvSwchStatus = Nothing,
@@ -1406,7 +1409,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)
@@ -1652,6 +1655,7 @@ getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
           l <- maybe (newTMVar ()) pure l_
           takeTMVar l
           pure $ Just l
+{-# INLINE getQueueMessage #-}
 
 decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
 decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
@@ -1741,10 +1745,12 @@ sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
 hasGetLock :: AgentClient -> RcvQueue -> IO Bool
 hasGetLock c RcvQueue {server, rcvId} =
   TM.memberIO (server, rcvId) $ getMsgLocks c
+{-# INLINE hasGetLock #-}
 
 releaseGetLock :: AgentClient -> RcvQueue -> STM ()
 releaseGetLock c RcvQueue {server, rcvId} =
   TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
+{-# INLINE releaseGetLock #-}
 
 suspendQueue :: AgentClient -> RcvQueue -> AM ()
 suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} =
@@ -1812,9 +1818,10 @@ agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfToken
 agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
   withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
 
-agentNtfEnableCron :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
-agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
-  withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
+-- set to 0 to disable
+agentNtfSetCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
+agentNtfSetCronInterval c tknId NtfToken {ntfServer, ntfPrivKey} interval =
+  withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf ntfPrivKey tknId interval
 
 agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId
 agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =

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

@@ -96,7 +96,8 @@ data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
     ntf :: [NtfServer],
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
-    netCfg :: NetworkConfig
+    netCfg :: NetworkConfig,
+    presetDomains :: [HostName]
   }
 
 data ServerCfg p = ServerCfg

src/Simplex/Messaging/Agent/Protocol.hs

@@ -147,6 +147,7 @@ module Simplex.Messaging.Agent.Protocol
     AgentMsgId,
     NotificationsMode (..),
     NotificationInfo (..),
+    ConnMsgReq (..),
 
     -- * Encode/decode
     serializeCommand,
@@ -678,11 +679,21 @@ instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseA
 
 data NotificationInfo = NotificationInfo
   { ntfConnId :: ConnId,
+    ntfDbQueueId :: Int64,
     ntfTs :: SystemTime,
+    -- Nothing means that the message failed to decrypt or to decode,
+    -- we can still show event notification
     ntfMsgMeta :: Maybe NMsgMeta
   }
   deriving (Show)
 
+data ConnMsgReq = ConnMsgReq
+  { msgConnId :: ConnId,
+    msgDbQueueId :: Int64,
+    msgTs :: Maybe UTCTime
+  }
+  deriving (Show)
+
 data ConnectionMode = CMInvitation | CMContact
   deriving (Eq, Show)
 
@@ -1402,6 +1413,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)
 
@@ -1410,6 +1425,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)

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,
@@ -98,7 +87,7 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
     -- | 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
@@ -160,12 +149,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 +173,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 +246,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 +256,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

@@ -98,6 +98,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     -- Messages
     updateRcvIds,
     createRcvMsg,
+    setLastBrokerTs,
     updateRcvMsgHash,
     createSndMsgBody,
     updateSndIds,
@@ -282,6 +283,7 @@ import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
 import Simplex.Messaging.Version.Internal
@@ -855,7 +857,11 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta =
   insertRcvMsgBase_ db connId rcvMsgData
   insertRcvMsgDetails_ db connId rq rcvMsgData
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
-  DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId)
+  setLastBrokerTs db connId dbQueueId brokerTs
+
+setLastBrokerTs :: DB.Connection -> ConnId -> DBEntityId -> UTCTime -> IO ()
+setLastBrokerTs db connId dbQueueId brokerTs =
+  DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ? AND (last_broker_ts IS NULL OR last_broker_ts < ?)" (brokerTs, connId, dbQueueId, brokerTs)
 
 createSndMsgBody :: DB.Connection -> AMessage -> IO Int64
 createSndMsgBody db aMessage =
@@ -1207,7 +1213,7 @@ getSndRatchet db connId v =
     DB.query db "SELECT ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem FROM ratchets WHERE conn_id = ?" (Only connId)
   where
     result = \case
-      (Just ratchetState, Just k1, Just k2, pKem_) -> 
+      (Just ratchetState, Just k1, Just k2, pKem_) ->
         let params = case pKem_ of
               Nothing -> CR.AE2ERatchetParams CR.SRKSProposed (CR.E2ERatchetParams v k1 k2 Nothing)
               Just (CR.ARKP s pKem) -> CR.AE2ERatchetParams s (CR.E2ERatchetParams v k1 k2 (Just pKem))
@@ -1781,19 +1787,19 @@ getActiveNtfToken db =
           ntfMode = fromMaybe NMPeriodic ntfMode_
        in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
-getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime))
+getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime))
 getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
   firstRow' res SEConnNotFound $
     DB.query
       db
       [sql|
-        SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts
+        SELECT conn_id, rcv_queue_id, rcv_ntf_dh_secret, last_broker_ts
         FROM rcv_queues
         WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
       |]
       (host, port, notifierId)
   where
-    res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_)
+    res (connId, dbQueueId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, dbQueueId, rcvNtfDhSecret, lastBrokerTs_)
     res _ = Left SEConnNotFound
 
 setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
@@ -1806,15 +1812,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
@@ -2013,13 +2010,13 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
         smp_client_version=EXCLUDED.smp_client_version,
         server_key_hash=EXCLUDED.server_key_hash
     |]
-    ((host server, port server, sndId, queueMode, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) 
+    ((host server, port server, sndId, queueMode, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret)
     :. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
   pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
 
-newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
-newQueueId_ [] = DBQueueId 1
-newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
+newQueueId_ :: [Only Int64] -> DBEntityId
+newQueueId_ [] = DBEntityId 1
+newQueueId_ (Only maxId : _) = DBEntityId (maxId + 1)
 
 -- * getConn helpers
 
@@ -2155,7 +2152,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
@@ -2205,7 +2202,7 @@ sndQueueQuery =
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode)
     :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
+    :. (DBEntityId, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId, queueMode)

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

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

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

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

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

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

src/Simplex/Messaging/Client.hs

@@ -84,6 +84,7 @@ module Simplex.Messaging.Client
     SocksMode (..),
     SMPProxyMode (..),
     SMPProxyFallback (..),
+    SMPWebPortServers (..),
     defaultClientConfig,
     defaultSMPClientConfig,
     defaultNetworkConfig,
@@ -129,7 +130,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Base64 as B64
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find)
+import Data.List (find, isSuffixOf)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (catMaybes, fromMaybe)
@@ -138,7 +139,7 @@ import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
-import Network.Socket (ServiceName)
+import Network.Socket (HostName, ServiceName)
 import Network.Socks5 (SocksCredentials (..))
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
@@ -291,7 +292,7 @@ data NetworkConfig = NetworkConfig
     -- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
     smpProxyFallback :: SMPProxyFallback,
     -- | use web port 443 for SMP protocol
-    smpWebPort :: Bool,
+    smpWebPortServers :: SMPWebPortServers,
     -- | timeout for the initial client TCP/TLS connection (microseconds)
     tcpConnectTimeout :: Int,
     -- | timeout of protocol commands (microseconds)
@@ -327,6 +328,12 @@ data SMPProxyFallback
   | SPFProhibit -- prohibit direct connection to destination relay.
   deriving (Eq, Show)
 
+data SMPWebPortServers
+  = SWPAll
+  | SWPPreset
+  | SWPOff
+  deriving (Eq, Show)
+
 instance StrEncoding SMPProxyMode where
   strEncode = \case
     SPMAlways -> "always"
@@ -353,6 +360,18 @@ instance StrEncoding SMPProxyFallback where
       "no" -> pure SPFProhibit
       _ -> fail "Invalid SMP proxy fallback mode"
 
+instance StrEncoding SMPWebPortServers where
+  strEncode = \case
+    SWPAll -> "all"
+    SWPPreset -> "preset"
+    SWPOff -> "off"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "all" -> pure SWPAll
+      "preset" -> pure SWPPreset
+      "off" -> pure SWPOff
+      _ -> fail "Invalid SMP wep port setting"
+
 defaultNetworkConfig :: NetworkConfig
 defaultNetworkConfig =
   NetworkConfig
@@ -363,7 +382,7 @@ defaultNetworkConfig =
       sessionMode = TSMSession,
       smpProxyMode = SPMNever,
       smpProxyFallback = SPFAllow,
-      smpWebPort = False,
+      smpWebPortServers = SWPPreset,
       tcpConnectTimeout = defaultTcpConnectTimeout,
       tcpTimeout = 15_000_000,
       tcpTimeoutPerKb = 5_000,
@@ -405,7 +424,7 @@ 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],
@@ -498,15 +517,15 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> 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} msgQ proxySessTs disconnected = do
+getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
-    NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
     mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
     mkProtocolClient transportHost ts = do
       connected <- newTVarIO False
@@ -534,7 +553,7 @@ 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}
@@ -548,14 +567,21 @@ 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)
         _ -> defaultTransport cfg
       p -> (p, transport @TLS)
+      where
+        smpWebPort = case smpWebPortServers of
+          SWPAll -> True
+          SWPPreset -> case srv of
+            ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
+            _ -> False
+          SWPOff -> False
 
-    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
@@ -775,6 +801,7 @@ getSMPMessage c rpKey rId =
     OK -> pure Nothing
     cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
     r -> throwE $ unexpectedResponse r
+{-# INLINE getSMPMessage #-}
 
 -- | Subscribe to the SMP queue notifications.
 --
@@ -929,7 +956,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
@@ -943,10 +970,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,
@@ -1262,6 +1288,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode)
 
 $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
 
+$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)
+
 $(J.deriveJSON defaultJSON ''NetworkConfig)
 
 $(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)

src/Simplex/Messaging/Client/Agent.hs

@@ -42,7 +42,7 @@ import Simplex.Messaging.Session
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=), (<$$>))
+import Simplex.Messaging.Util (catchAll_, ifM, safeDecodeUtf8, toChunks, tshow, whenM, ($>>=), (<$$>))
 import System.Timeout (timeout)
 import UnliftIO (async)
 import qualified UnliftIO.Exception as E
@@ -198,7 +198,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
 -- | Run an SMP client for SMPClientVar
 connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
 connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
-  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
+  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
   where
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected smp = do
@@ -321,7 +321,7 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE
   where
     logSMPError :: SMPClientError -> ExceptT SMPClientError IO a
     logSMPError e = do
-      liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
+      logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host srv) <> "): " <> tshow e
       throwE e
 
 subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO ()
@@ -412,14 +412,22 @@ removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
 removeSubscription = removeSub_ . srvSubs
 {-# INLINE removeSubscription #-}
 
+removePendingSub :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
+removePendingSub = removeSub_ . pendingSrvSubs
+{-# INLINE removePendingSub #-}
+
 removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM ()
 removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
 
+removeSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
+removeSubscriptions = removeSubs_ . srvSubs
+{-# INLINE removeSubscriptions #-}
+
 removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
 removePendingSubs = removeSubs_ . pendingSrvSubs
 {-# INLINE removePendingSubs #-}
 
-removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
+removeSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
 removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss))
   where
     ss = S.fromList $ map (party,) qs

src/Simplex/Messaging/Crypto.hs

@@ -64,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/ShortLink.hs

@@ -48,7 +48,7 @@ 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 -> ConnInfo -> (LinkKey, (ByteString, ByteString))
 encodeSignLinkData (rootKey, pk) agentVRange connReq userData =
   let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq}
       md = smpEncode $ connLinkData @c agentVRange userData

src/Simplex/Messaging/Encoding.hs

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

src/Simplex/Messaging/Encoding/String.hs

@@ -140,11 +140,11 @@ instance StrEncoding Int64 where
 
 instance StrEncoding SystemTime where
   strEncode = strEncode . systemSeconds
-  strP = MkSystemTime <$> strP <*> pure 0
+  strP = (`MkSystemTime` 0) <$> strP
 
 instance StrEncoding UTCTime where
   strEncode = B.pack . iso8601Show
-  strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
+  strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n' || c == ',' || c == ';')
 
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString

src/Simplex/Messaging/Notifications/Client.hs

@@ -49,8 +49,9 @@ ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
 ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
 
-ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
-ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
+-- set to 0 to disable
+ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
+ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
 ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
 ntfCreateSubscription c pKey newSub =

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -517,7 +517,9 @@ instance Encoding NtfSubStatus where
 
 instance StrEncoding NtfSubStatus where
   strEncode = smpEncode
+  {-# INLINE strEncode #-}
   strP = smpP
+  {-# INLINE strP #-}
 
 data NtfTknStatus
   = -- | Token created in DB
@@ -534,6 +536,26 @@ data NtfTknStatus
     NTExpired
   deriving (Eq, Show)
 
+allowTokenVerification :: NtfTknStatus -> Bool
+allowTokenVerification = \case
+  NTNew -> False
+  NTRegistered -> True
+  NTInvalid _ -> False
+  NTConfirmed -> True
+  NTActive -> True
+  NTExpired -> False
+
+allowNtfSubCommands :: NtfTknStatus -> Bool
+allowNtfSubCommands = \case
+  NTNew -> False
+  NTRegistered -> False
+  -- TODO we could have separate statuses to show whether it became invalid
+  -- after verification (allow commands) or before (do not allow)
+  NTInvalid _ -> True
+  NTConfirmed -> False
+  NTActive -> True
+  NTExpired -> True
+
 instance Encoding NtfTknStatus where
   smpEncode = \case
     NTNew -> "NEW"

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

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

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

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

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

@@ -0,0 +1,252 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
+
+module Simplex.Messaging.Notifications.Server.Prometheus where
+
+import Data.Int (Int64)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime (..), diffUTCTime)
+import Data.Time.Clock.System (systemEpochDay)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Numeric.Natural (Natural)
+import Simplex.Messaging.Notifications.Server.Stats
+import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
+import Simplex.Messaging.Transport (simplexMQVersion)
+
+data NtfServerMetrics = NtfServerMetrics
+  { statsData :: NtfServerStatsData,
+    activeTokensCounts :: PeriodStatCounts,
+    activeSubsCounts :: PeriodStatCounts,
+    tokenCount :: Int64,
+    approxSubCount :: Int64,
+    lastNtfCount :: Int64,
+    rtsOptions :: Text
+  }
+
+rtsOptionsEnv :: Text
+rtsOptionsEnv = "NTF_RTS_OPTIONS"
+
+data NtfRealTimeMetrics = NtfRealTimeMetrics
+  { threadsCount :: Int,
+    srvSubscribers :: NtfSMPWorkerMetrics,
+    srvClients :: NtfSMPWorkerMetrics,
+    srvSubWorkers :: NtfSMPWorkerMetrics,
+    ntfActiveSubs :: NtfSMPSubMetrics,
+    ntfPendingSubs :: NtfSMPSubMetrics,
+    smpSessionCount :: Int,
+    apnsPushQLength :: Natural
+  }
+
+data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int}
+
+data NtfSMPSubMetrics = NtfSMPSubMetrics {ownSrvSubs :: M.Map Text Int, otherServers :: Int, otherSrvSubCount :: Int}
+
+{-# FOURMOLU_DISABLE\n#-}
+ntfPrometheusMetrics :: NtfServerMetrics -> NtfRealTimeMetrics -> UTCTime -> Text
+ntfPrometheusMetrics sm rtm ts =
+  time <> tokens <> subscriptions <> notifications <> info
+  where
+    NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm
+    NtfRealTimeMetrics
+      { threadsCount,
+        srvSubscribers,
+        srvClients,
+        srvSubWorkers,
+        ntfActiveSubs,
+        ntfPendingSubs,
+        smpSessionCount,
+        apnsPushQLength
+      } = rtm
+    NtfServerStatsData
+      { _fromTime,
+        _tknCreated,
+        _tknVerified,
+        _tknDeleted,
+        _tknReplaced,
+        _subCreated,
+        _subDeleted,
+        _ntfReceived,
+        _ntfDelivered,
+        _ntfFailed,
+        _ntfCronDelivered,
+        _ntfCronFailed,
+        _ntfVrfQueued,
+        _ntfVrfDelivered,
+        _ntfVrfFailed,
+        _ntfVrfInvalidTkn
+      } = statsData
+    time =
+      "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
+      \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\
+      \\n"
+    tokens =
+      "# Tokens\n\
+      \# ------\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_created Created tokens\n\
+      \# TYPE simplex_ntf_tokens_created counter\n\
+      \simplex_ntf_tokens_created " <> mshow _tknCreated <> "\n# tknCreated\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_verified Verified tokens\n\
+      \# TYPE simplex_ntf_tokens_verified counter\n\
+      \simplex_ntf_tokens_verified " <> mshow _tknVerified <> "\n# tknVerified\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_deleted Deleted tokens\n\
+      \# TYPE simplex_ntf_tokens_deleted counter\n\
+      \simplex_ntf_tokens_deleted " <> mshow _tknDeleted <> "\n# tknDeleted\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_replaced Deleted tokens\n\
+      \# TYPE simplex_ntf_tokens_replaced counter\n\
+      \simplex_ntf_tokens_replaced " <> mshow _tknReplaced <> "\n# tknReplaced\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_daily Daily active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_daily gauge\n\
+      \simplex_ntf_tokens_count_daily " <> mstr (dayCount psTkns) <> "\n# dayCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_weekly Weekly active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_weekly gauge\n\
+      \simplex_ntf_tokens_count_weekly " <> mstr (weekCount psTkns) <> "\n# weekCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_count_monthly Monthly active tokens\n\
+      \# TYPE simplex_ntf_tokens_count_monthly gauge\n\
+      \simplex_ntf_tokens_count_monthly " <> mstr (monthCount psTkns) <> "\n# monthCountTkn\n\
+      \\n\
+      \# HELP simplex_ntf_tokens_total Total number of tokens stored.\n\
+      \# TYPE simplex_ntf_tokens_total gauge\n\
+      \simplex_ntf_tokens_total " <> mshow tokenCount <> "\n# tokenCount\n\
+      \\n"
+    subscriptions =
+      "# Subscriptions\n\
+      \# -------------\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_created Created subscriptions\n\
+      \# TYPE simplex_ntf_subscriptions_created counter\n\
+      \simplex_ntf_subscriptions_created " <> mshow _subCreated <> "\n# subCreated\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_deleted Deleted subscriptions\n\
+      \# TYPE simplex_ntf_subscriptions_deleted counter\n\
+      \simplex_ntf_subscriptions_deleted " <> mshow _subDeleted <> "\n# subDeleted\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_daily Daily subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_daily gauge\n\
+      \simplex_ntf_subscriptions_count_daily " <> mstr (dayCount psSubs) <> "\n# dayCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_weekly Weekly subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_weekly gauge\n\
+      \simplex_ntf_subscriptions_count_weekly " <> mstr (weekCount psSubs) <> "\n# weekCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_count_monthly Monthly subscriptions count\n\
+      \# TYPE simplex_ntf_subscriptions_count_monthly gauge\n\
+      \simplex_ntf_subscriptions_count_monthly " <> mstr (monthCount psSubs) <> "\n# monthCountSub\n\
+      \\n\
+      \# HELP simplex_ntf_subscriptions_approx_total Approximate total number of subscriptions stored.\n\
+      \# TYPE simplex_ntf_subscriptions_approx_total gauge\n\
+      \simplex_ntf_subscriptions_approx_total " <> mshow approxSubCount <> "\n# approxSubCount\n\
+      \\n"
+      <> showSubMetric ntfActiveSubs "simplex_ntf_smp_subscription_active_" "Active"
+      <> showSubMetric ntfPendingSubs "simplex_ntf_smp_subscription_pending_" "Pending"
+    notifications =
+      "# Notifications\n\
+      \# -------------\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_received Received notifications\n\
+      \# TYPE simplex_ntf_notifications_received counter\n\
+      \simplex_ntf_notifications_received " <> mshow _ntfReceived <> "\n# ntfReceived\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_delivered Delivered notifications\n\
+      \# TYPE simplex_ntf_notifications_delivered counter\n\
+      \simplex_ntf_notifications_delivered " <> mshow _ntfDelivered <> "\n# ntfDelivered\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_failed Failed notifications\n\
+      \# TYPE simplex_ntf_notifications_failed counter\n\
+      \simplex_ntf_notifications_failed " <> mshow _ntfFailed <> "\n# ntfFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_periodic_delivered Delivered periodic notifications\n\
+      \# TYPE simplex_ntf_notifications_periodic_delivered counter\n\
+      \simplex_ntf_notifications_periodic_delivered " <> mshow _ntfCronDelivered <> "\n# ntfCronDelivered\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_periodic_failed Failed periodic notifications\n\
+      \# TYPE simplex_ntf_notifications_periodic_failed counter\n\
+      \simplex_ntf_notifications_periodic_failed " <> mshow _ntfCronFailed <> "\n# ntfCronFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_queued Token verifications queued\n\
+      \# TYPE simplex_ntf_notifications_verification_queued counter\n\
+      \simplex_ntf_notifications_verification_queued " <> mshow _ntfVrfQueued <> "\n# ntfVrfQueued\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_delivered Delivered token verifications\n\
+      \# TYPE simplex_ntf_notifications_verification_delivered counter\n\
+      \simplex_ntf_notifications_verification_delivered " <> mshow _ntfVrfDelivered <> "\n# ntfVrfDelivered\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_failed Failed token verification deliveries\n\
+      \# TYPE simplex_ntf_notifications_verification_failed counter\n\
+      \simplex_ntf_notifications_verification_failed " <> mshow _ntfVrfFailed <> "\n# ntfVrfFailed\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_verification_invalid_tkn Invalid token errors while delivering verifications\n\
+      \# TYPE simplex_ntf_notifications_verification_invalid_tkn counter\n\
+      \simplex_ntf_notifications_verification_invalid_tkn " <> mshow _ntfVrfInvalidTkn <> "\n# ntfVrfInvalidTkn\n\
+      \\n\
+      \# HELP simplex_ntf_notifications_total Total number of last notifications stored.\n\
+      \# TYPE simplex_ntf_notifications_total gauge\n\
+      \simplex_ntf_notifications_total " <> mshow lastNtfCount <> "\n# lastNtfCount\n\
+      \\n"
+    info =
+      "# Info\n\
+      \# ----\n\
+      \\n\
+      \# HELP simplex_ntf_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
+      \# TYPE simplex_ntf_info gauge\n\
+      \simplex_ntf_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
+      \\n\
+      \# HELP simplex_ntf_threads_total Thread count\n\
+      \# TYPE simplex_ntf_threads_total gauge\n\
+      \simplex_ntf_threads_total " <> mshow threadsCount <> "\n# threadsCount\n\
+      \\n"
+      <> showWorkerMetric srvSubscribers "simplex_ntf_smp_subscribers_" "SMP subcscribers"
+      <> showWorkerMetric srvClients "simplex_ntf_smp_agent_clients_" "SMP agent clients"
+      <> showWorkerMetric srvSubWorkers "simplex_ntf_smp_agent_sub_workers_" "SMP agent subscription workers"
+      <> "# HELP simplex_ntf_smp_sessions_count SMP sessions count\n\
+      \# TYPE simplex_ntf_smp_sessions_count gauge\n\
+      \simplex_ntf_smp_sessions_count " <> mshow smpSessionCount <> "\n# smpSessionCount\n\
+      \\n\
+      \# HELP simplex_ntf_apns_push_queue_length Count of notifications in push queue\n\
+      \# TYPE simplex_ntf_apns_push_queue_length gauge\n\
+      \simplex_ntf_apns_push_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\
+      \\n"
+    showSubMetric NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} mPfx descrPfx =
+      showOwnSrvSubs <> showOtherSrvSubs
+      where
+        showOwnSrvSubs
+          | M.null ownSrvSubs = showOwn_ "" 0 0
+          | otherwise = T.concat $ map (\(host, cnt) -> showOwn_ (metricHost host) 1 cnt) $ M.assocs ownSrvSubs
+        showOwn_ param srvCnt subCnt =
+          gaugeMetric (mPfx <> "server_count_own") param srvCnt (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server"
+            <> gaugeMetric (mPfx <> "sub_count_own") param subCnt (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count"
+        showOtherSrvSubs =
+          gaugeMetric (mPfx <> "server_count_other") "" otherServers (descrPfx <> " SMP subscriptions, other server count") "otherServers"
+            <> gaugeMetric (mPfx <> "sub_count_other") "" otherSrvSubCount (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount"
+    showWorkerMetric NtfSMPWorkerMetrics {ownServers, otherServers} mPfx descrPfx =
+      showOwnServers <> showOtherServers
+      where
+        showOwnServers
+          | null ownServers = showOwn_ "" 0
+          | otherwise = T.concat $ map (\host -> showOwn_ (metricHost host) 1) ownServers
+        showOwn_ param cnt = gaugeMetric (mPfx <> "count_own") param cnt (descrPfx <> " count for own servers") "ownServers"
+        showOtherServers = gaugeMetric (mPfx <> "count_other") "" otherServers (descrPfx <> " count for other servers") "otherServers"
+    gaugeMetric :: Text -> Text -> Int -> Text -> Text -> Text
+    gaugeMetric name param value descr codeRef =
+      "# HELP " <> name <> " " <> descr <> "\n\
+      \# TYPE " <> name <> " gauge\n\
+      \" <> name <> param <> " " <> mshow value <> "\n# " <> codeRef <> "\n\
+      \\n"
+    metricHost host = "{server=\"" <> host <> "\"}"
+    mstr a = T.pack a <> " " <> tsEpoch
+    mshow :: Show a => a -> Text
+    mshow = mstr . show
+    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    epoch = UTCTime systemEpochDay 0
+{-# FOURMOLU_ENABLE\n#-}

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

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

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

@@ -30,7 +30,7 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
 
-data NtfStore = NtfStore
+data NtfSTMStore = NtfSTMStore
   { tokens :: TMap NtfTokenId NtfTknData,
     -- multiple registrations exist to protect from malicious registrations if token is compromised
     tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
@@ -40,29 +40,29 @@ data NtfStore = NtfStore
     tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
   }
 
-newNtfStore :: IO NtfStore
-newNtfStore = do
+newNtfSTMStore :: IO NtfSTMStore
+newNtfSTMStore = do
   tokens <- TM.emptyIO
   tokenRegistrations <- TM.emptyIO
   subscriptions <- TM.emptyIO
   tokenSubscriptions <- TM.emptyIO
   subscriptionLookup <- TM.emptyIO
   tokenLastNtfs <- TM.emptyIO
-  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
+  pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
 
 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
@@ -80,18 +80,11 @@ data NtfSubData = NtfSubData
 ntfSubServer :: NtfSubData -> SMPServer
 ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
 
-data NtfEntityRec (e :: NtfEntity) where
-  NtfTkn :: NtfTknData -> NtfEntityRec 'Token
-  NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
+stmGetNtfTokenIO :: NtfSTMStore -> NtfTokenId -> IO (Maybe NtfTknData)
+stmGetNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
 
-getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getNtfToken st tknId = TM.lookup tknId (tokens st)
-
-getNtfTokenIO :: NtfStore -> NtfTokenId -> IO (Maybe NtfTknData)
-getNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
-
-addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
-addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
+stmAddNtfToken :: NtfSTMStore -> NtfTokenId -> NtfTknData -> STM ()
+stmAddNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
   TM.insert tknId tkn $ tokens st
   TM.lookup token regs >>= \case
     Just tIds -> TM.insert regKey tknId tIds
@@ -102,16 +95,8 @@ addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
 
-getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
-getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
-  TM.lookup token (tokenRegistrations st)
-    $>>= TM.lookup regKey
-    $>>= (`TM.lookup` tokens st)
-  where
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
-removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
+stmRemoveInactiveTokenRegistrations :: NtfSTMStore -> NtfTknData -> STM [NtfTokenId]
+stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
   TM.lookup token (tokenRegistrations st)
     >>= maybe (pure []) removeRegs
   where
@@ -125,8 +110,8 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
         void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
-removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
-removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
+stmRemoveTokenRegistration :: NtfSTMStore -> NtfTknData -> STM ()
+stmRemoveTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
   TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
   where
     removeReg regs =
@@ -134,8 +119,8 @@ removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
         >>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
     k = C.toPubKey C.pubKeyBytes tknVerifyKey
 
-deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
-deleteNtfToken st tknId = do
+stmDeleteNtfToken :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
+stmDeleteNtfToken st tknId = do
   void $
     TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} ->
       TM.lookup token regs $>>= \tIds ->
@@ -147,7 +132,7 @@ deleteNtfToken st tknId = do
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes
 
-deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
+deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
 deleteTokenSubs st tknId = do
   qs <-
     TM.lookupDelete tknId (tokenSubscriptions st)
@@ -159,32 +144,11 @@ deleteTokenSubs st tknId = do
         $>>= \NtfSubData {smpQueue} ->
           TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
 
-getNtfSubscriptionIO :: NtfStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
-getNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
+stmGetNtfSubscriptionIO :: NtfSTMStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
+stmGetNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
 
-findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
-findNtfSubscription st smpQueue = do
-  TM.lookup smpQueue (subscriptionLookup st)
-    $>>= \subId -> TM.lookup subId (subscriptions st)
-
-findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
-findNtfSubscriptionToken st smpQueue = do
-  findNtfSubscription st smpQueue
-    $>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
-
-getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getActiveNtfToken st tknId =
-  getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
-    tStatus <- readTVar tknStatus
-    pure $ if tStatus == NTActive then Just tkn else Nothing
-
-mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
-mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
-  subStatus <- newTVar NSNew
-  pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
-
-addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
-addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
+stmAddNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
+stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
   TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
   where
     newTokenSub = do
@@ -198,8 +162,8 @@ addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
       -- return Nothing if subscription existed before
       pure $ Just ()
 
-deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
-deleteNtfSubscription st subId = do
+stmDeleteNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> STM ()
+stmDeleteNtfSubscription st subId = do
   TM.lookupDelete subId (subscriptions st)
     >>= mapM_
       ( \NtfSubData {smpQueue, tokenId} -> do
@@ -208,32 +172,10 @@ deleteNtfSubscription st subId = do
           forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
       )
 
-addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData)
-addTokenLastNtf st tknId newNtf =
-  TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf)
-  where
-    maybeNewTokenLastNtfs =
-      TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf
-    newTokenLastNtfs = do
-      v <- newTVar [newNtf]
-      TM.insert tknId v $ tokenLastNtfs st
-      pure [newNtf]
-    addNtf v =
-      stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs')
-      where
-        rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData
-        rebuildList = foldr keepPrevNtf [newNtf]
-          where
-            PNMessageData {smpQueue = newNtfQ} = newNtf
-            keepPrevNtf ntf@PNMessageData {smpQueue} ntfs
-              | smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs
-              | otherwise = ntfs
-        maxNtfs = 6
-
 -- This function is expected to be called after store log is read,
 -- as it checks for token existence when adding last notification.
-storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO ()
-storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do
+stmStoreTokenLastNtf :: NtfSTMStore -> NtfTokenId -> PNMessageData -> IO ()
+stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
   TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|))
   where
     newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|))

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

@@ -0,0 +1,81 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Notifications.Server.Store.Migrations where
+
+import Data.List (sortOn)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Messaging.Agent.Store.Shared
+import Text.RawString.QQ (r)
+
+ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
+ntfServerSchemaMigrations =
+  [ ("20250417_initial", m20250417_initial, Nothing)
+  ]
+
+-- | The list of migrations in ascending order by date
+ntfServerMigrations :: [Migration]
+ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up, down = down}
+
+m20250417_initial :: Text
+m20250417_initial =
+  T.pack
+    [r|
+CREATE TABLE tokens(
+  token_id BYTEA NOT NULL,
+  push_provider TEXT NOT NULL,
+  push_provider_token BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  verify_key BYTEA NOT NULL,
+  dh_priv_key BYTEA NOT NULL,
+  dh_secret BYTEA NOT NULL,
+  reg_code BYTEA NOT NULL,
+  cron_interval BIGINT NOT NULL, -- minutes
+  cron_sent_at BIGINT, -- seconds
+  updated_at BIGINT,
+  PRIMARY KEY (token_id)
+);
+
+CREATE UNIQUE INDEX idx_tokens_push_provider_token ON tokens(push_provider, push_provider_token, verify_key);
+CREATE INDEX idx_tokens_status_cron_interval_sent_at ON tokens(status, cron_interval, (cron_sent_at + cron_interval * 60));
+
+CREATE TABLE smp_servers(
+  smp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  smp_host TEXT NOT NULL,
+  smp_port TEXT NOT NULL,
+  smp_keyhash BYTEA NOT NULL
+);
+
+CREATE UNIQUE INDEX idx_smp_servers ON smp_servers(smp_host, smp_port, smp_keyhash);
+
+CREATE TABLE subscriptions(
+  subscription_id BYTEA NOT NULL,
+  token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
+  smp_server_id BIGINT REFERENCES smp_servers ON DELETE RESTRICT ON UPDATE RESTRICT,
+  smp_notifier_id BYTEA NOT NULL,
+  smp_notifier_key BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  PRIMARY KEY (subscription_id)
+);
+
+CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON subscriptions(smp_server_id, smp_notifier_id);
+CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
+CREATE INDEX idx_subscriptions_token_id ON subscriptions(token_id);
+
+CREATE TABLE last_notifications(
+  token_ntf_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
+  subscription_id BYTEA NOT NULL REFERENCES subscriptions ON DELETE CASCADE ON UPDATE RESTRICT,
+  sent_at TIMESTAMPTZ NOT NULL,
+  nmsg_nonce BYTEA NOT NULL,
+  nmsg_data BYTEA NOT NULL
+);
+
+CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token_id, sent_at);
+CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id);
+
+CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
+    |]

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

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

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

@@ -0,0 +1,111 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Notifications.Server.Store.Types where
+
+import Control.Applicative (optional)
+import Control.Concurrent.STM
+import qualified Data.ByteString.Char8 as B
+import Data.Word (Word16)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
+import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..))
+import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
+
+data NtfTknRec = NtfTknRec
+  { ntfTknId :: NtfTokenId,
+    token :: DeviceToken,
+    tknStatus :: NtfTknStatus,
+    tknVerifyKey :: NtfPublicAuthKey,
+    tknDhPrivKey :: C.PrivateKeyX25519,
+    tknDhSecret :: C.DhSecretX25519,
+    tknRegCode :: NtfRegCode,
+    tknCronInterval :: Word16,
+    tknUpdatedAt :: Maybe RoundedSystemTime
+  }
+  deriving (Show)
+
+mkTknData :: NtfTknRec -> IO NtfTknData
+mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- newTVarIO status
+  tknCronInterval <- newTVarIO cronInt
+  tknUpdatedAt <- newTVarIO updatedAt
+  let tknDhKeys = (C.publicKey pk, pk)
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+mkTknRec :: NtfTknData -> IO NtfTknRec
+mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys = (_, tknDhPrivKey), tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- readTVarIO status
+  tknCronInterval <- readTVarIO cronInt
+  tknUpdatedAt <- readTVarIO updatedAt
+  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+instance StrEncoding NtfTknRec where
+  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
+    B.unwords
+      [ "tknId=" <> strEncode ntfTknId,
+        "token=" <> strEncode token,
+        "tokenStatus=" <> strEncode tknStatus,
+        "verifyKey=" <> strEncode tknVerifyKey,
+        "dhKeys=" <> strEncode (C.publicKey pk, pk),
+        "dhSecret=" <> strEncode tknDhSecret,
+        "regCode=" <> strEncode tknRegCode,
+        "cron=" <> strEncode tknCronInterval
+      ]
+      <> maybe "" updatedAtStr tknUpdatedAt
+    where
+      updatedAtStr t = " updatedAt=" <> strEncode t
+  strP = do
+    ntfTknId <- "tknId=" *> strP_
+    token <- "token=" *> strP_
+    tknStatus <- "tokenStatus=" *> strP_
+    tknVerifyKey <- "verifyKey=" *> strP_
+    (_ :: C.PublicKeyX25519, tknDhPrivKey) <- "dhKeys=" *> strP_
+    tknDhSecret <- "dhSecret=" *> strP_
+    tknRegCode <- "regCode=" *> strP_
+    tknCronInterval <- "cron=" *> strP
+    tknUpdatedAt <- optional $ " updatedAt=" *> strP
+    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
+
+data NtfSubRec = NtfSubRec
+  { ntfSubId :: NtfSubscriptionId,
+    smpQueue :: SMPQueueNtf,
+    notifierKey :: NtfPrivateAuthKey,
+    tokenId :: NtfTokenId,
+    subStatus :: NtfSubStatus
+  }
+  deriving (Show)
+
+type ServerNtfSub = (NtfSubscriptionId, (NotifierId, NtfPrivateAuthKey))
+
+mkSubData :: NtfSubRec -> IO NtfSubData
+mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
+  subStatus <- newTVarIO status
+  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
+
+mkSubRec :: NtfSubData -> IO NtfSubRec
+mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
+  subStatus <- readTVarIO status
+  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
+
+instance StrEncoding NtfSubRec where
+  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
+    B.unwords
+      [ "subId=" <> strEncode ntfSubId,
+        "smpQueue=" <> strEncode smpQueue,
+        "notifierKey=" <> strEncode notifierKey,
+        "tknId=" <> strEncode tokenId,
+        "subStatus=" <> strEncode subStatus
+      ]
+  strP = do
+    ntfSubId <- "subId=" *> strP_
+    smpQueue <- "smpQueue=" *> strP_
+    notifierKey <- "notifierKey=" *> strP_
+    tokenId <- "tknId=" *> strP_
+    subStatus <- "subStatus=" *> strP
+    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}

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

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

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

@@ -10,7 +10,7 @@
 module Simplex.Messaging.Notifications.Server.StoreLog
   ( StoreLog,
     NtfStoreLogRecord (..),
-    readWriteNtfStore,
+    readWriteNtfSTMStore,
     logCreateToken,
     logTokenStatus,
     logUpdateToken,
@@ -24,23 +24,19 @@ module Simplex.Messaging.Notifications.Server.StoreLog
   )
 where
 
-import Control.Applicative (optional)
 import Control.Concurrent.STM
-import Control.Logger.Simple
 import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Base64.URL as B64
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.Text as T
 import Data.Word (Word16)
-import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
+import Simplex.Messaging.Notifications.Server.Store.Types
+import Simplex.Messaging.Protocol (EntityId (..))
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.IO
 
 data NtfStoreLogRecord
@@ -55,52 +51,6 @@ data NtfStoreLogRecord
   | DeleteSubscription NtfSubscriptionId
   deriving (Show)
 
-data NtfTknRec = NtfTknRec
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: NtfTknStatus,
-    tknVerifyKey :: C.APublicAuthKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: Word16,
-    tknUpdatedAt :: Maybe RoundedSystemTime
-  }
-  deriving (Show)
-
-mkTknData :: NtfTknRec -> IO NtfTknData
-mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
-  tknStatus <- newTVarIO status
-  tknCronInterval <- newTVarIO cronInt
-  tknUpdatedAt <- newTVarIO updatedAt
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-mkTknRec :: NtfTknData -> IO NtfTknRec
-mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
-  tknStatus <- readTVarIO status
-  tknCronInterval <- readTVarIO cronInt
-  tknUpdatedAt <- readTVarIO updatedAt
-  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-data NtfSubRec = NtfSubRec
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateAuthKey,
-    tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus
-  }
-  deriving (Show)
-
-mkSubData :: NtfSubRec -> IO NtfSubData
-mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- newTVarIO status
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-mkSubRec :: NtfSubData -> STM NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- readTVar status
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
 instance StrEncoding NtfStoreLogRecord where
   strEncode = \case
     CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
@@ -125,56 +75,12 @@ instance StrEncoding NtfStoreLogRecord where
         "SDELETE " *> (DeleteSubscription <$> strP)
       ]
 
-instance StrEncoding NtfTknRec where
-  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
-    B.unwords
-      [ "tknId=" <> strEncode ntfTknId,
-        "token=" <> strEncode token,
-        "tokenStatus=" <> strEncode tknStatus,
-        "verifyKey=" <> strEncode tknVerifyKey,
-        "dhKeys=" <> strEncode tknDhKeys,
-        "dhSecret=" <> strEncode tknDhSecret,
-        "regCode=" <> strEncode tknRegCode,
-        "cron=" <> strEncode tknCronInterval
-      ]
-      <> maybe "" updatedAtStr tknUpdatedAt
-    where
-      updatedAtStr t = " updatedAt=" <> strEncode t
-  strP = do
-    ntfTknId <- "tknId=" *> strP_
-    token <- "token=" *> strP_
-    tknStatus <- "tokenStatus=" *> strP_
-    tknVerifyKey <- "verifyKey=" *> strP_
-    tknDhKeys <- "dhKeys=" *> strP_
-    tknDhSecret <- "dhSecret=" *> strP_
-    tknRegCode <- "regCode=" *> strP_
-    tknCronInterval <- "cron=" *> strP
-    tknUpdatedAt <- optional $ " updatedAt=" *> strP
-    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
-
-instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
-    B.unwords
-      [ "subId=" <> strEncode ntfSubId,
-        "smpQueue=" <> strEncode smpQueue,
-        "notifierKey=" <> strEncode notifierKey,
-        "tknId=" <> strEncode tokenId,
-        "subStatus=" <> strEncode subStatus
-      ]
-  strP = do
-    ntfSubId <- "subId=" *> strP_
-    smpQueue <- "smpQueue=" *> strP_
-    notifierKey <- "notifierKey=" *> strP_
-    tokenId <- "tknId=" *> strP_
-    subStatus <- "subStatus=" *> strP
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
 logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
 logNtfStoreRecord = writeStoreLogRecord
 {-# INLINE logNtfStoreRecord #-}
 
-logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
-logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< mkTknRec tkn
+logCreateToken :: StoreLog 'WriteMode -> NtfTknRec -> IO ()
+logCreateToken s = logNtfStoreRecord s . CreateToken
 
 logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
 logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
@@ -191,8 +97,8 @@ logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
 logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
 logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
 
-logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
-logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
+logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()
+logCreateSubscription s = logNtfStoreRecord s . CreateSubscription
 
 logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
 logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
@@ -200,49 +106,54 @@ logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStat
 logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
 logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
 
-readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
-readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore
+readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
+readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore
 
-readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
+readNtfStore :: Bool -> FilePath -> NtfSTMStore -> IO ()
+readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
   where
-    addNtfLogRecord s = case strDecode s of
-      Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
-      Right lr -> case lr of
-        CreateToken r@NtfTknRec {ntfTknId} -> do
-          tkn <- mkTknData r
-          atomically $ addNtfToken st ntfTknId tkn
-        TokenStatus tknId status -> do
-          tkn_ <- getNtfTokenIO st tknId
-          forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
-            atomically $ writeTVar tknStatus status
-            when (status == NTActive) $ void $ atomically $ removeInactiveTokenRegistrations st tkn
-        UpdateToken tknId token' tknRegCode -> do
-          getNtfTokenIO st tknId
-            >>= mapM_
-              ( \tkn@NtfTknData {tknStatus} -> do
-                  atomically $ removeTokenRegistration st tkn
-                  atomically $ writeTVar tknStatus NTRegistered
-                  atomically $ addNtfToken st tknId tkn {token = token', tknRegCode}
-              )
-        TokenCron tknId cronInt ->
-          getNtfTokenIO st tknId
-            >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
-        DeleteToken tknId ->
-          atomically $ void $ deleteNtfToken st tknId
-        UpdateTokenTime tknId t ->
-          getNtfTokenIO st tknId
-            >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
-        CreateSubscription r@NtfSubRec {ntfSubId} -> do
-          sub <- mkSubData r
-          void $ atomically $ addNtfSubscription st ntfSubId sub
-        SubscriptionStatus subId status -> do
-          getNtfSubscriptionIO st subId
-            >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
-        DeleteSubscription subId ->
-          atomically $ deleteNtfSubscription st subId
+    processLine s = either printError procNtfLogRecord (strDecode s)
+      where
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> B.take 100 s
+        procNtfLogRecord = \case
+          CreateToken r@NtfTknRec {ntfTknId} -> do
+            tkn <- mkTknData r
+            atomically $ stmAddNtfToken st ntfTknId tkn
+          TokenStatus tknId status -> do
+            tkn_ <- stmGetNtfTokenIO st tknId
+            forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
+              atomically $ writeTVar tknStatus status
+              when (status == NTActive) $ void $ atomically $ stmRemoveInactiveTokenRegistrations st tkn
+          UpdateToken tknId token' tknRegCode -> do
+            stmGetNtfTokenIO st tknId
+              >>= mapM_
+                ( \tkn@NtfTknData {tknStatus} -> do
+                    atomically $ stmRemoveTokenRegistration st tkn
+                    atomically $ writeTVar tknStatus NTRegistered
+                    atomically $ stmAddNtfToken st tknId tkn {token = token', tknRegCode}
+                )
+          TokenCron tknId cronInt ->
+            stmGetNtfTokenIO st tknId
+              >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
+          DeleteToken tknId ->
+            atomically $ void $ stmDeleteNtfToken st tknId
+          UpdateTokenTime tknId t ->
+            stmGetNtfTokenIO st tknId
+              >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
+          CreateSubscription r@NtfSubRec {tokenId, ntfSubId} -> do
+            sub <- mkSubData r
+            atomically (stmAddNtfSubscription st ntfSubId sub) >>= \case
+              Just () -> pure ()
+              Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId
+            where
+              enc = B64.encode . unEntityId
+          SubscriptionStatus subId status -> do
+            stmGetNtfSubscriptionIO st subId
+              >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
+          DeleteSubscription subId ->
+            atomically $ stmDeleteNtfSubscription st subId
 
-writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
-writeNtfStore s NtfStore {tokens, subscriptions} = do
-  mapM_ (logCreateToken s) =<< readTVarIO tokens
-  mapM_ (logCreateSubscription s) =<< readTVarIO subscriptions
+writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO ()
+writeNtfStore s NtfSTMStore {tokens, subscriptions} = do
+  mapM_ (logCreateToken s <=< mkTknRec) =<< readTVarIO tokens
+  mapM_ (logCreateSubscription s <=< mkSubRec) =<< readTVarIO subscriptions

src/Simplex/Messaging/Notifications/Transport.hs

@@ -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,7 +126,7 @@ 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 :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
 ntfClientHandshake c keyHash ntfVRange _proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
@@ -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_
@@ -148,7 +148,7 @@ ntfThHandleServer th v vr pk =
   let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
    in ntfThHandle_ th v vr (Just thAuth)
 
-ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (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_
    in ntfThHandle_ th v vr thAuth
@@ -160,7 +160,7 @@ ntfThHandle_ th@THandle {params} v vr thAuth =
       params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
    in (th :: THandleNTF c p) {params = params'}
 
-ntfTHandle :: Transport c => c -> THandleNTF c p
+ntfTHandle :: Transport c => c p -> THandleNTF c p
 ntfTHandle c = THandle {connection = c, params}
   where
     v = VersionNTF 0

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

@@ -220,7 +220,6 @@ 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
@@ -305,7 +304,7 @@ data SParty :: Party -> Type where
   SRecipient :: SParty Recipient
   SSender :: SParty Sender
   SNotifier :: SParty Notifier
-  SSenderLink :: SParty LinkClient 
+  SSenderLink :: SParty LinkClient
   SProxiedClient :: SParty ProxiedClient
 
 instance TestEquality SParty where
@@ -575,7 +574,7 @@ 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
@@ -1466,7 +1465,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
 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 :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
@@ -1629,7 +1628,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       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_
@@ -1671,7 +1670,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     LNK_ -> LNK <$> _smpP <*> 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

src/Simplex/Messaging/Server.hs

@@ -79,6 +79,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
 import Data.Typeable (cast)
+import qualified Data.X509 as X
 import GHC.Conc.Signal
 import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
@@ -87,7 +88,7 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
 import qualified Network.TLS as TLS
 import Numeric.Natural (Natural)
 import Simplex.Messaging.Agent.Lock
-import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError)
+import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, nonBlockingWriteTBQueue, smpProxyError, temporaryClientError)
 import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -114,6 +115,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import System.Environment (lookupEnv)
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
@@ -161,8 +163,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
     stopServer s
     liftIO $ exitSuccess
   raceAny_
-    ( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub
-        : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ())
+    ( serverThread "server subscribers" s subscribers subscriptions cancelSub
+        : serverThread "server ntfSubscribers" s ntfSubscribers ntfSubscriptions (\_ -> pure ())
         : deliverNtfsThread s
         : sendPendingEvtsThread s
         : receiveFromProxyAgent pa
@@ -176,28 +178,27 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
     )
     `finally` stopServer s
   where
-    runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
+    runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, addHTTP) = do
-      smpCreds <- asks tlsServerCreds
+      smpCreds@(srvCert, srvKey) <- asks tlsServerCreds
       httpCreds_ <- asks httpServerCreds
       ss <- liftIO newSocketState
       asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
-      serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
+      srvSignKey <- either fail pure $ C.x509ToPrivate' srvKey
       env <- ask
       liftIO $ case (httpCreds_, attachHTTP_) of
         (Just httpCreds, Just attachHTTP) | addHTTP ->
           runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h ->
             case cast h of
-              Just TLS {tlsContext} | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
-              _ -> runClient serverSignKey t h `runReaderT` env
+              Just (TLS {tlsContext} :: TLS 'TServer) | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
+              _ -> runClient srvCert srvSignKey t h `runReaderT` env
           where
             chooseCreds = maybe smpCreds (\_host -> httpCreds)
             combinedALPNs = supportedSMPHandshakes <> httpALPN
             httpALPN :: [ALPN]
             httpALPN = ["h2", "http/1.1"]
         _ ->
-          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
-    fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
+          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
 
     sigIntHandlerThread :: M ()
     sigIntHandlerThread = do
@@ -207,14 +208,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           sigIntHandler = Just (sigIntAction, toDyn ())
       void $ liftIO $ setHandler sigINT sigIntHandler
       atomically $ readTMVar flagINT
-      logInfo "Received SIGINT, stopping server..."
+      logNote "Received SIGINT, stopping server..."
 
     stopServer :: Server -> M ()
     stopServer s = do
       asks serverActive >>= atomically . (`writeTVar` False)
-      logInfo "Saving server state..."
+      logNote "Saving server state..."
       withLock' (savingLock s) "final" $ saveServer True >> closeServer
-      logInfo "Server stopped"
+      logNote "Server stopped"
 
     saveServer :: Bool -> M ()
     saveServer drainMsgs = do
@@ -228,66 +229,63 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
 
     serverThread ::
       forall s.
-      Server ->
       String ->
-      (Server -> TQueue (QueueId, ClientId, Subscribed)) ->
-      (Server -> TMap QueueId (TVar AClient)) ->
-      (Server -> TVar (IM.IntMap AClient)) ->
-      (Server -> TVar (IM.IntMap (NonEmpty (QueueId, Subscribed)))) ->
+      Server ->
+      (Server -> ServerSubscribers) ->
       (forall st. Client st -> TMap QueueId s) ->
       (s -> IO ()) ->
       M ()
-    serverThread s label subQ subs subClnts pendingEvts clientSubs unsub = do
+    serverThread label srv srvSubscribers clientSubs unsub = do
       labelMyThread label
-      cls <- asks clients
-      liftIO . forever $
-        (atomically (readTQueue $ subQ s) >>= atomically . updateSubscribers cls)
+      liftIO . forever $ do
+        -- Reading clients outside of `updateSubscribers` transaction to avoid transaction re-evaluation on each new connected client.
+        -- In case client disconnects during the transaction (its `connected` property is read),
+        -- the transaction will still be re-evaluated, and the client won't be stored as subscribed.
+        sub@(_, clntId, _) <- atomically $ readTQueue subQ
+        c_ <- getServerClient clntId srv
+        atomically (updateSubscribers c_ sub)
           $>>= endPreviousSubscriptions
           >>= mapM_ unsub
       where
-        updateSubscribers :: TVar (IM.IntMap (Maybe AClient)) -> (QueueId, ClientId, Subscribed) -> STM (Maybe ((QueueId, Subscribed), AClient))
-        updateSubscribers cls (qId, clntId, subscribed) =
-          -- Client lookup by ID is in the same STM transaction.
-          -- In case client disconnects during the transaction,
-          -- it will be re-evaluated, and the client won't be stored as subscribed.
-          (readTVar cls >>= updateSub . IM.lookup clntId)
-            $>>= clientToBeNotified
+        ServerSubscribers {subQ, queueSubscribers, subClients, pendingEvents} = srvSubscribers srv
+        updateSubscribers :: Maybe AClient -> (QueueId, ClientId, Subscribed) -> STM (Maybe ((QueueId, BrokerMsg), AClient))
+        updateSubscribers c_ (qId, clntId, subscribed) = updateSub $>>= clientToBeNotified
           where
-            ss = subs s
-            updateSub = \case
-              Just (Just clnt)
-                | subscribed -> do
-                    modifyTVar' (subClnts s) $ IM.insert clntId clnt -- add client to server's subscribed cients
-                    TM.lookup qId ss >>= -- insert subscribed and current client
-                      maybe
-                        (newTVar clnt >>= \cv -> TM.insert qId cv ss $> Nothing)
-                        (\cv -> Just <$> swapTVar cv clnt)
-                | otherwise -> do
-                    removeWhenNoSubs clnt
-                    TM.lookupDelete qId ss >>= mapM readTVar
-              -- This case catches Just Nothing - it cannot happen here.
-              -- Nothing is there only before client thread is started.
-              _ -> TM.lookup qId ss >>= mapM readTVar -- do not insert client if it is already disconnected, but send END to any other client
-            clientToBeNotified ac@(AClient _ _ c')
-              | clntId == clientId c' = pure Nothing
-              | otherwise = (\yes -> if yes then Just ((qId, subscribed), ac) else Nothing) <$> readTVar (connected c')
-        endPreviousSubscriptions :: ((QueueId, Subscribed), AClient) -> IO (Maybe s)
-        endPreviousSubscriptions (qEvt@(qId, _), ac@(AClient _ _ c)) = do
-          atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qEvt] (qEvt <|)) (clientId c)
+            updateSub = case c_ of
+              Just c@(AClient _ _ Client {connected}) -> ifM (readTVar connected) (updateSubConnected c) updateSubDisconnected
+              Nothing -> updateSubDisconnected
+            updateSubConnected c
+              | subscribed = do
+                  modifyTVar' subClients $ IS.insert clntId -- add client to server's subscribed cients
+                  upsertSubscribedClient qId c queueSubscribers
+              | otherwise = do
+                  removeWhenNoSubs c
+                  lookupDeleteSubscribedClient qId queueSubscribers
+            -- do not insert client if it is already disconnected, but send END to any other client
+            updateSubDisconnected = lookupDeleteSubscribedClient qId queueSubscribers
+            clientToBeNotified ac@(AClient _ _ Client {clientId, connected})
+              | clntId == clientId = pure Nothing
+              | otherwise = (\yes -> if yes then Just ((qId, subEvt), ac) else Nothing) <$> readTVar connected
+              where
+                subEvt = if subscribed then END else DELD
+        endPreviousSubscriptions :: ((QueueId, BrokerMsg), AClient) -> IO (Maybe s)
+        endPreviousSubscriptions (evt@(qId, _), ac@(AClient _ _ c)) = do
+          atomically $ modifyTVar' pendingEvents $ IM.alter (Just . maybe [evt] (evt <|)) (clientId c)
           atomically $ do
             sub <- TM.lookupDelete qId (clientSubs c)
             removeWhenNoSubs ac $> sub
         -- remove client from server's subscribed cients
-        removeWhenNoSubs (AClient _ _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c)
+        removeWhenNoSubs (AClient _ _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' subClients $ IS.delete (clientId c)
 
     deliverNtfsThread :: Server -> M ()
-    deliverNtfsThread Server {ntfSubClients} = do
+    deliverNtfsThread srv@Server {ntfSubscribers} = do
       ntfInt <- asks $ ntfDeliveryInterval . config
       NtfStore ns <- asks ntfStore
       stats <- asks serverStats
       liftIO $ forever $ do
         threadDelay ntfInt
-        readTVarIO ntfSubClients >>= mapM_ (deliverNtfs ns stats)
+        cIds <- IS.toList <$> readTVarIO (subClients ntfSubscribers)
+        forM_ cIds $ \cId -> getServerClient cId srv >>= mapM_ (deliverNtfs ns stats)
       where
         deliverNtfs ns stats (AClient _ _ Client {clientId, ntfSubscriptions, sndQ, connected}) =
           whenM (currentClient readTVarIO) $ do
@@ -307,7 +305,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 writeTBQueue sndQ ts
               pure $ length ts_
             currentClient :: Monad m => (forall a. TVar a -> m a) -> m Bool
-            currentClient rd = (&&) <$> rd connected <*> (IM.member clientId <$> rd ntfSubClients)
+            currentClient rd = (&&) <$> rd connected <*> (IS.member clientId <$> rd (subClients ntfSubscribers))
             addNtfs :: [Transmission BrokerMsg] -> (NotifierId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg]
             addNtfs acc (nId, v) =
               readTVar v >>= \case
@@ -323,37 +321,30 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               atomicModifyIORef'_ (msgNtfsB stats) (+ (len `div` 80 + 1)) -- up to 80 NMSG in the batch
 
     sendPendingEvtsThread :: Server -> M ()
-    sendPendingEvtsThread s = do
+    sendPendingEvtsThread srv@Server {subscribers, ntfSubscribers} = do
       endInt <- asks $ pendingENDInterval . config
-      cls <- asks clients
-      forever $ do
+      stats <- asks serverStats
+      liftIO $ forever $ do
         threadDelay endInt
-        sendPending cls $ pendingSubEvents s
-        sendPending cls $ pendingNtfSubEvents s
+        sendPending subscribers stats
+        sendPending ntfSubscribers stats
       where
-        sendPending cls ref = do
-          ends <- atomically $ swapTVar ref IM.empty
-          unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qEvts) ->
-            mapM_ (queueEvts qEvts) . join . IM.lookup cId =<< readTVarIO cls
-        queueEvts qEvts (AClient _ _ c@Client {connected, sndQ = q}) =
-          whenM (readTVarIO connected) $ do
-            sent <- atomically $ tryWriteTBQueue q ts
-            if sent
-              then updateEndStats
-              else -- if queue is full it can block
-                forkClient c ("sendPendingEvtsThread.queueEvts") $
-                  atomically (writeTBQueue q ts) >> updateEndStats
+        sendPending ServerSubscribers {pendingEvents} stats = do
+          pending <- atomically $ swapTVar pendingEvents IM.empty
+          unless (null pending) $ forM_ (IM.assocs pending) $ \(cId, evts) ->
+            getServerClient cId srv >>= mapM_ (enqueueEvts evts)
           where
-            ts = L.map (\(qId, subscribed) -> (CorrId "", qId, evt subscribed)) qEvts
-            evt True = END
-            evt False = DELD
-            -- this accounts for both END and DELD events
-            updateEndStats = do
-              stats <- asks serverStats
-              let len = L.length qEvts
-              when (len > 0) $ liftIO $ do
-                atomicModifyIORef'_ (qSubEnd stats) (+ len)
-                atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch
+            enqueueEvts evts (AClient _ _ Client {connected, sndQ}) =
+              whenM (readTVarIO connected) $
+                nonBlockingWriteTBQueue sndQ ts >> updateEndStats
+              where
+                ts = L.map (\(qId, evt) -> (CorrId "", qId, evt)) evts
+                -- this accounts for both END and DELD events
+                updateEndStats = do
+                  let len = L.length evts
+                  when (len > 0) $ do
+                    atomicModifyIORef'_ (qSubEnd stats) (+ len)
+                    atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch
 
     receiveFromProxyAgent :: ProxyAgent -> M ()
     receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} =
@@ -382,9 +373,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
         expire :: forall s. MsgStoreClass s => s -> ServerStats -> Int64 -> IO ()
         expire ms stats interval = do
           threadDelay' interval
-          logInfo "Started expiring messages..."
+          logNote "Started expiring messages..."
           n <- compactQueues @(StoreQueue s) $ queueStore ms
-          when (n > 0) $ logInfo $ "Removed " <> tshow n <> " old deleted queues from the database."
+          when (n > 0) $ logNote $ "Removed " <> tshow n <> " old deleted queues from the database."
           now <- systemSeconds <$> getSystemTime
           tryAny (expireOldMessages False ms now ttl) >>= \case
             Right msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} -> do
@@ -562,45 +553,49 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       AMS _ _ st <- asks msgStore
       ss <- asks serverStats
       env <- ask
+      rtsOpts <- liftIO $ maybe ("set " <> rtsOptionsEnv) T.pack <$> lookupEnv (T.unpack rtsOptionsEnv)
       let interval = 1000000 * saveInterval
       liftIO $ forever $ do
         threadDelay interval
         ts <- getCurrentTime
-        sm <- getServerMetrics st ss
+        sm <- getServerMetrics st ss rtsOpts
         rtm <- getRealTimeMetrics env
         T.writeFile metricsFile $ prometheusMetrics sm rtm ts
 
-    getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> IO ServerMetrics
-    getServerMetrics st ss = do
+    getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> Text -> IO ServerMetrics
+    getServerMetrics st ss rtsOptions = do
       d <- getServerStatsData ss
       let ps = periodStatDataCounts $ _activeQueues d
           psNtf = periodStatDataCounts $ _activeQueuesNtf d
       QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st
-      pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount}
+      pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount, rtsOptions}
 
     getRealTimeMetrics :: Env -> IO RealTimeMetrics
-    getRealTimeMetrics Env {clients, sockets, msgStore = AMS _ _ ms, server = Server {subscribers, notifiers, subClients, ntfSubClients}} = do
+    getRealTimeMetrics Env {sockets, msgStore = AMS _ _ ms, server = srv@Server {subscribers, ntfSubscribers}} = do
       socketStats <- mapM (traverse getSocketStats) =<< readTVarIO sockets
 #if MIN_VERSION_base(4,18,0)
       threadsCount <- length <$> listThreads
 #else
       let threadsCount = 0
 #endif
-      clientsCount <- IM.size <$> readTVarIO clients
-      smpSubsCount <- M.size <$> readTVarIO subscribers
-      smpSubClientsCount <- IM.size <$> readTVarIO subClients
-      ntfSubsCount <- M.size <$> readTVarIO notifiers
-      ntfSubClientsCount <- IM.size <$> readTVarIO ntfSubClients
+      clientsCount <- IM.size <$> getServerClients srv
+      smpSubs <- getSubscribersMetrics subscribers
+      ntfSubs <- getSubscribersMetrics ntfSubscribers
       loadedCounts <- loadedQueueCounts ms
-      pure RealTimeMetrics {socketStats, threadsCount, clientsCount, smpSubsCount, smpSubClientsCount, ntfSubsCount, ntfSubClientsCount, loadedCounts}
+      pure RealTimeMetrics {socketStats, threadsCount, clientsCount, smpSubs, ntfSubs, loadedCounts}
+      where
+        getSubscribersMetrics ServerSubscribers {queueSubscribers, subClients} = do
+          subsCount <- M.size <$> getSubscribedClients queueSubscribers
+          subClientsCount <- IS.size <$> readTVarIO subClients
+          pure RTSubscriberMetrics {subsCount, subClientsCount}
 
-    runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
-    runClient signKey tp h = do
+    runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
+    runClient srvCert srvSignKey tp h = do
       kh <- asks serverIdentity
       ks <- atomically . C.generateKeyPair =<< asks random
       ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
       labelMyThread $ "smp handshake for " <> transportName tp
-      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case
+      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange) >>= \case
         Just (Right th) -> runClientTransport th
         _ -> pure ()
 
@@ -651,9 +646,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               CPSuspend -> withAdminRole $ hPutStrLn h "suspend not implemented"
               CPResume -> withAdminRole $ hPutStrLn h "resume not implemented"
               CPClients -> withAdminRole $ do
-                active <- unliftIO u (asks clients) >>= readTVarIO
+                cls <- getServerClients srv
                 hPutStrLn h "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions"
-                forM_ (IM.toList active) $ \(cid, cl) -> forM_ cl $ \(AClient _ _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
+                forM_ (IM.toList cls) $ \(cid, (AClient _ _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions})) -> do
                   connected' <- bshow <$> readTVarIO connected
                   rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt
                   sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt
@@ -765,8 +760,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
 #else
                   hPutStrLn h "Threads: not available on GHC 8.10"
 #endif
-                  Env {clients, server = Server {subscribers, notifiers, subClients, ntfSubClients}} <- unliftIO u ask
-                  activeClients <- readTVarIO clients
+                  let Server {subscribers, ntfSubscribers} = srv
+                  activeClients <- getServerClients srv
                   hPutStrLn h $ "Clients: " <> show (IM.size activeClients)
                   when (r == CPRAdmin) $ do
                     clQs <- clientTBQueueLengths' activeClients
@@ -780,30 +775,25 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                     hPutStrLn h $ "Ntf subscriptions (via clients): " <> show ntfSubCnt
                     hPutStrLn h $ "Ntf subscribed clients (via clients): " <> show ntfClCnt
                     hPutStrLn h $ "Ntf subscribed clients queues (via clients, rcvQ, sndQ, msgQ): " <> show ntfClQs
-                  putActiveClientsInfo "SMP" subscribers False
-                  putActiveClientsInfo "Ntf" notifiers True
-                  putSubscribedClients "SMP" subClients False
-                  putSubscribedClients "Ntf" ntfSubClients True
+                  putSubscribersInfo "SMP" subscribers False
+                  putSubscribersInfo "Ntf" ntfSubscribers True
                   where
-                    putActiveClientsInfo :: String -> TMap QueueId (TVar AClient) -> Bool -> IO ()
-                    putActiveClientsInfo protoName clients showIds = do
-                      activeSubs <- readTVarIO clients
+                    putSubscribersInfo :: String -> ServerSubscribers -> Bool -> IO ()
+                    putSubscribersInfo protoName ServerSubscribers {queueSubscribers, subClients} showIds = do
+                      activeSubs <- getSubscribedClients queueSubscribers
                       hPutStrLn h $ protoName <> " subscriptions: " <> show (M.size activeSubs)
                       clnts <- countSubClients activeSubs
                       hPutStrLn h $ protoName <> " subscribed clients: " <> show (IS.size clnts) <> (if showIds then " " <> show (IS.toList clnts) else "")
+                      clnts' <- readTVarIO subClients
+                      hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (IS.size clnts') <> (if showIds then " " <> show clnts' else "")
                       where
-                        countSubClients :: M.Map QueueId (TVar AClient) -> IO IS.IntSet
-                        countSubClients = foldM (\ !s c -> (`IS.insert` s) . clientId' <$> readTVarIO c) IS.empty
-                    putSubscribedClients :: String -> TVar (IM.IntMap AClient) -> Bool -> IO ()
-                    putSubscribedClients protoName subClnts showIds = do
-                      clnts <- readTVarIO subClnts
-                      hPutStrLn h $ protoName <> " subscribed clients count 2: " <> show (IM.size clnts) <> (if showIds then " " <> show (IM.keys clnts) else "")
-                    countClientSubs :: (forall s. Client s -> TMap QueueId a) -> Maybe (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap (Maybe AClient) -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
+                        countSubClients :: M.Map QueueId (TVar (Maybe AClient)) -> IO IS.IntSet
+                        countSubClients = foldM (\ !s c -> maybe s ((`IS.insert` s) . clientId') <$> readTVarIO c) IS.empty
+                    countClientSubs :: (forall s. Client s -> TMap QueueId a) -> Maybe (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap AClient -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
                     countClientSubs subSel countSubs_ = foldM addSubs (0, (0, 0, 0, 0), 0, (0, 0, 0))
                       where
-                        addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Maybe AClient -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
-                        addSubs acc Nothing = pure acc
-                        addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) (Just acl@(AClient _ _ cl)) = do
+                        addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> AClient -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
+                        addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) acl@(AClient _ _ cl) = do
                           subs <- readTVarIO $ subSel cl
                           cnts' <- case countSubs_ of
                             Nothing -> pure cnts
@@ -814,8 +804,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                               clCnt' = if cnt == 0 then clCnt else clCnt + 1
                           qs' <- if cnt == 0 then pure qs else addQueueLengths qs acl
                           pure (subCnt + cnt, cnts', clCnt', qs')
-                    clientTBQueueLengths' :: Foldable t => t (Maybe AClient) -> IO (Natural, Natural, Natural)
-                    clientTBQueueLengths' = foldM (\acc -> maybe (pure acc) (addQueueLengths acc)) (0, 0, 0)
+                    clientTBQueueLengths' :: Foldable t => t AClient -> IO (Natural, Natural, Natural)
+                    clientTBQueueLengths' = foldM addQueueLengths (0, 0, 0)
                     addQueueLengths (!rl, !sl, !ml) (AClient _ _ cl) = do
                       (rl', sl', ml') <- queueLengths cl
                       pure (rl + rl', sl + sl', ml + ml')
@@ -894,30 +884,28 @@ runClientTransport :: Transport c => THandleSMP c 'TServer -> M ()
 runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessionId}} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
-  active <- asks clients
   nextClientId <- asks clientSeq
   clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1)
-  atomically $ modifyTVar' active $ IM.insert clientId Nothing
   AMS qt mt ms <- asks msgStore
   c <- liftIO $ newClient qt mt clientId q thVersion sessionId ts
-  runClientThreads qt mt ms active c clientId `finally` clientDisconnected c
+  runClientThreads qt mt ms c `finally` clientDisconnected c
   where
-    runClientThreads :: MsgStoreClass (MsgStore qs ms) => SQSType qs -> SMSType ms -> MsgStore qs ms -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore qs ms) -> IS.Key -> M ()
-    runClientThreads qt mt ms active c clientId = do
-      atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient qt mt c)
+    runClientThreads :: MsgStoreClass (MsgStore qs ms) => SQSType qs -> SMSType ms -> MsgStore qs ms -> Client (MsgStore qs ms) -> M ()
+    runClientThreads qt mt ms c = do
       s <- asks server
-      expCfg <- asks $ inactiveClientExpiration . config
-      th <- newMVar h -- put TH under a fair lock to interleave messages and command responses
-      labelMyThread . B.unpack $ "client $" <> encode sessionId
-      raceAny_ $ [liftIO $ send th c, liftIO $ sendMsg th c, client thParams s ms c, receive h ms c] <> disconnectThread_ c s expCfg
+      whenM (liftIO $ insertServerClient (AClient qt mt c) s) $ do
+        expCfg <- asks $ inactiveClientExpiration . config
+        th <- newMVar h -- put TH under a fair lock to interleave messages and command responses
+        labelMyThread . B.unpack $ "client $" <> encode sessionId
+        raceAny_ $ [liftIO $ send th c, liftIO $ sendMsg th c, client thParams s ms c, receive h ms c] <> disconnectThread_ c s expCfg
     disconnectThread_ :: Client s -> Server -> Maybe ExpirationConfig -> [M ()]
     disconnectThread_ c s (Just expCfg) = [liftIO $ disconnectTransport h (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c s)]
     disconnectThread_ _ _ _ = []
-    noSubscriptions Client {clientId} s = do
-      hasSubs <- IM.member clientId <$> readTVarIO (subClients s)
+    noSubscriptions Client {clientId} Server {subscribers, ntfSubscribers} = do
+      hasSubs <- IS.member clientId <$> readTVarIO (subClients subscribers)
       if hasSubs
         then pure False
-        else not . IM.member clientId <$> readTVarIO (ntfSubClients s)
+        else not . IS.member clientId <$> readTVarIO (subClients ntfSubscribers)
 
 clientDisconnected :: Client s -> M ()
 clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connected, sessionId, endThreads} = do
@@ -929,26 +917,17 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connecte
   ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty
   liftIO $ mapM_ cancelSub subs
   whenM (asks serverActive >>= readTVarIO) $ do
-    Server {subscribers, notifiers, subClients, ntfSubClients} <- asks server
+    srv@Server {subscribers, ntfSubscribers} <- asks server
     liftIO $ updateSubscribers subs subscribers
-    liftIO $ updateSubscribers ntfSubs notifiers
-    asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
-    atomically $ modifyTVar' subClients $ IM.delete clientId
-    atomically $ modifyTVar' ntfSubClients $ IM.delete clientId
+    liftIO $ updateSubscribers ntfSubs ntfSubscribers
+    liftIO $ deleteServerClient clientId srv
   tIds <- atomically $ swapTVar endThreads IM.empty
   liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds
   where
-    updateSubscribers :: M.Map QueueId a -> TMap QueueId (TVar AClient) -> IO ()
-    updateSubscribers subs srvSubs =
-      forM_ (M.keys subs) $ \qId ->
-        -- 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.
-        TM.lookupIO qId srvSubs >>=
-          mapM_ (\c' -> atomically $ whenM (sameClientId c <$> readTVar c') $ TM.delete qId srvSubs)
-
-sameClientId :: Client s -> AClient -> Bool
-sameClientId Client {clientId} ac = clientId == clientId' ac
+    updateSubscribers :: M.Map QueueId a -> ServerSubscribers -> IO ()
+    updateSubscribers subs ServerSubscribers {queueSubscribers, subClients} = do
+      mapM_ (\qId -> deleteSubcribedClient qId c queueSubscribers) (M.keys subs)
+      atomically $ modifyTVar' subClients $ IS.delete clientId
 
 cancelSub :: Sub -> IO ()
 cancelSub s = case subThread s of
@@ -1069,7 +1048,7 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd =
     Cmd SSender PING -> pure $ VRVerified Nothing
     Cmd SSender RFWD {} -> pure $ VRVerified Nothing
     Cmd SSenderLink (LKEY k) -> verifySecure SSenderLink k
-    Cmd SSenderLink LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink
+    Cmd SSenderLink LGET -> verifyQueue (\q -> if isContactQueue (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink
     -- NSUB will not be accepted without authorization
     Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier
     Cmd SProxiedClient _ -> pure $ VRVerified Nothing
@@ -1087,12 +1066,20 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd =
     allowedKey k = \case
       QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey
       _ -> False
-    isContact = \case
-      QueueRec {queueMode = Just QMContact} -> True
-      _ -> False
     get :: DirectParty p => SParty p -> M (Either ErrorType (StoreQueue s, QueueRec))
     get party = liftIO $ getQueueRec ms party queueId
 
+isContactQueue :: QueueRec -> Bool
+isContactQueue QueueRec {queueMode, senderKey} = case queueMode of
+  Just QMMessaging -> False
+  Just QMContact -> True
+  Nothing -> isNothing senderKey -- for backward compatibility with pre-SKEY contact addresses
+
+isSecuredMsgQueue :: QueueRec -> Bool
+isSecuredMsgQueue QueueRec {queueMode, senderKey} = case queueMode of
+  Just QMContact -> False
+  _ -> isJust senderKey
+
 verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
 verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
   where
@@ -1149,7 +1136,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
 client :: forall s. MsgStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M ()
 client
   thParams'
-  Server {subscribedQ, ntfSubscribedQ, subscribers}
+  Server {subscribers, ntfSubscribers}
   ms
   clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} = do
     labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
@@ -1251,7 +1238,7 @@ client
         RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
       Cmd SSenderLink command -> Just <$> case command of
         LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
-        LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr
+        LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
       Cmd SNotifier NSUB -> Just <$> subscribeNotifications
       Cmd SRecipient command ->
         Just <$> case command of
@@ -1267,13 +1254,14 @@ client
           KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey
           RKEY rKeys -> withQueue $ \q qr -> checkMode QMContact qr $ OK <$$ liftIO (updateKeys (queueStore ms) q rKeys)
           LSET lnkId d ->
-            withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of
-              Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH
-              _ -> OK <$$ addQueueLinkData (queueStore ms) q lnkId d
+            withQueue $ \q qr -> case queueData qr of
+              _ | isSecuredMsgQueue qr -> pure $ err AUTH
+              Just (lnkId', _) | lnkId' /= lnkId -> pure $ err AUTH -- can't change link ID
+              _ -> liftIO $ either err (const ok) <$> addQueueLinkData (queueStore ms) q lnkId d
           LDEL ->
-            withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of
-              Just _ -> OK <$$ deleteQueueLinkData (queueStore ms) q
-              Nothing -> pure $ Right OK
+            withQueue $ \q qr -> case queueData qr of
+              Just _ -> liftIO $ either err (const ok) <$> deleteQueueLinkData (queueStore ms) q
+              Nothing -> pure ok
           NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey
           NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q
           OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_
@@ -1341,6 +1329,13 @@ client
                         pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData} -- , serverNtfCreds = snd <$> ntf
           (corrId,entId,) <$> tryCreate (3 :: Int)
 
+        -- this check allows to support contact queues created prior to SKEY,
+        -- using `queueMode == Just QMContact` would prevent it, as they have queueMode `Nothing`.
+        checkContact :: QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg)
+        checkContact qr a =
+          either err (corrId,entId,)
+            <$> if isContactQueue qr then a else pure $ Left AUTH
+
         checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg)
         checkMode qm QueueRec {queueMode} a =
           either err (corrId,entId,)
@@ -1370,7 +1365,7 @@ client
                 Left e -> pure $ ERR e
                 Right nId_ -> do
                   incStat . ntfCreated =<< asks serverStats
-                  forM_ nId_ $ \nId -> atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
+                  forM_ nId_ $ \nId -> atomically $ writeTQueue (subQ ntfSubscribers) (nId, clientId, False)
                   pure $ NID notifierId rcvPublicDhKey
 
         deleteQueueNotifier_ :: StoreQueue s -> M (Transmission BrokerMsg)
@@ -1381,7 +1376,7 @@ client
               stats <- asks serverStats
               deleted <- asks ntfStore >>= liftIO . (`deleteNtfs` nId)
               when (deleted > 0) $ liftIO $ atomicModifyIORef'_ (ntfCount stats) (subtract deleted)
-              atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
+              atomically $ writeTQueue (subQ ntfSubscribers) (nId, clientId, False)
               incStat $ ntfDeleted stats
               pure ok
             Right Nothing -> pure ok
@@ -1392,7 +1387,7 @@ client
 
         subscribeQueue :: StoreQueue s -> QueueRec -> M (Transmission BrokerMsg)
         subscribeQueue q qr =
-          atomically (TM.lookup rId subscriptions) >>= \case
+          liftIO (TM.lookupIO rId subscriptions) >>= \case
             Nothing -> newSub >>= deliver True
             Just s@Sub {subThread} -> do
               stats <- asks serverStats
@@ -1408,7 +1403,7 @@ client
             rId = recipientId q
             newSub :: M Sub
             newSub = time "SUB newSub" . atomically $ do
-              writeTQueue subscribedQ (rId, clientId, True)
+              writeTQueue (subQ subscribers) (rId, clientId, True)
               sub <- newSubscription NoSub
               TM.insert rId sub subscriptions
               pure sub
@@ -1484,7 +1479,7 @@ client
           pure ok
           where
             newSub = do
-              writeTQueue ntfSubscribedQ (entId, clientId, True)
+              writeTQueue (subQ ntfSubscribers) (entId, clientId, True)
               TM.insert entId () ntfSubscriptions
 
         acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M (Transmission BrokerMsg)
@@ -1520,7 +1515,7 @@ client
                 incStat $ msgRecv stats
                 if isGet
                   then incStat $ msgRecvGet stats
-                  else pure () -- TODO skip notification delivery for delivered message  
+                  else pure () -- TODO skip notification delivery for delivered message
                   -- skipping delivery fails tests, it should be counted in msgNtfSkipped
                   -- forM_ (notifierId <$> notifier qr) $ \nId -> do
                   --   ns <- asks ntfStore
@@ -1551,6 +1546,8 @@ client
                   case C.maxLenBS msgBody of
                     Left _ -> pure $ err LARGE_MSG
                     Right body -> do
+                      when (isJust (queueData qr) && isSecuredMsgQueue qr) $ void $ liftIO $
+                        deleteQueueLinkData (queueStore ms) q
                       ServerConfig {messageExpiration, msgIdBytes} <- asks config
                       msgId <- randomId' msgIdBytes
                       msg_ <- liftIO $ time "SEND" $ runExceptT $ do
@@ -1593,18 +1590,19 @@ client
             -- - nothing was delivered to this subscription (to avoid race conditions with the recipient).
             tryDeliverMessage :: Message -> IO ()
             tryDeliverMessage msg =
-              -- the subscription is checked outside of STM to avoid transaction cost
+              -- the subscribed client var is read outside of STM to avoid transaction cost
               -- in case no client is subscribed.
-              whenM (TM.memberIO rId subscribers) $
-                atomically deliverToSub >>= mapM_ forkDeliver
+              getSubscribedClient rId (queueSubscribers subscribers)
+                $>>= atomically . deliverToSub
+                >>= mapM_ forkDeliver
               where
                 rId = recipientId q
-                deliverToSub =
-                  -- lookup has ot be in the same transaction,
+                deliverToSub rcv =
+                  -- reading client TVar in the same transaction,
                   -- so that if subscription ends, it re-evalutates
                   -- and delivery is cancelled -
                   -- the new client will receive message in response to SUB.
-                  (TM.lookup rId subscribers >>= mapM readTVar)
+                  readTVar rcv
                     $>>= \rc@(AClient _ _ Client {subscriptions = subs, sndQ = sndQ'}) -> TM.lookup rId subs
                     $>>= \s@Sub {subThread, delivered} -> case subThread of
                       ProhibitSub -> pure Nothing
@@ -1633,9 +1631,9 @@ client
                       labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " deliver/SEND"
                       -- lookup can be outside of STM transaction,
                       -- as long as the check that it is the same client is inside.
-                      TM.lookupIO rId subscribers >>= mapM_ deliverIfSame
-                    deliverIfSame rc' = time "deliver" . atomically $
-                      whenM (sameClientId rc <$> readTVar rc') $
+                      getSubscribedClient rId (queueSubscribers subscribers) >>= mapM_ deliverIfSame
+                    deliverIfSame rcv = time "deliver" . atomically $
+                      whenM (sameClient rc rcv) $
                         tryTakeTMVar delivered >>= \case
                           Just _ -> pure () -- if a message was already delivered, should not deliver more
                           Nothing -> do
@@ -1748,7 +1746,7 @@ client
             Right qr -> do
               -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
               atomically $ do
-                writeTQueue subscribedQ (entId, clientId, False)
+                writeTQueue (subQ subscribers) (entId, clientId, False)
                 -- queue is usually deleted by the same client that is currently subscribed,
                 -- we delete subscription here, so the client with no subscriptions can be disconnected.
                 TM.delete entId subscriptions
@@ -1758,7 +1756,7 @@ client
                 stats <- asks serverStats
                 deleted <- asks ntfStore >>= liftIO . (`deleteNtfs` nId)
                 when (deleted > 0) $ liftIO $ atomicModifyIORef'_ (ntfCount stats) (subtract deleted)
-                atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
+                atomically $ writeTQueue (subQ ntfSubscribers) (nId, clientId, False)
               updateDeletedStats qr
               pure ok
             Left e -> pure $ err e
@@ -1825,15 +1823,15 @@ saveServerMessages :: Bool -> AMsgStore -> IO ()
 saveServerMessages drainMsgs = \case
   AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
     Just f -> exportMessages False ms f drainMsgs
-    Nothing -> logInfo "undelivered messages are not saved"
-  AMS _ SMSJournal _ -> logInfo "closed journal message storage"
+    Nothing -> logNote "undelivered messages are not saved"
+  AMS _ SMSJournal _ -> logNote "closed journal message storage"
 
 exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
 exportMessages tty ms f drainMsgs = do
-  logInfo $ "saving messages to file " <> T.pack f
+  logNote $ "saving messages to file " <> T.pack f
   liftIO $ withFile f WriteMode $ \h ->
     tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case
-      Right (Sum total) -> logInfo $ "messages saved: " <> tshow total
+      Right (Sum total) -> logNote $ "messages saved: " <> tshow total
       Left e -> do
         logError $ "error exporting messages: " <> tshow e
         exitFailure
@@ -1862,10 +1860,10 @@ processServerMessages StartOptions {skipWarnings} = do
       processJournalMessages old_ expire ms
         | expire = Just <$> case old_ of
             Just old -> do
-              logInfo "expiring journal store messages..."
+              logNote "expiring journal store messages..."
               run $ processExpireQueue old
             Nothing -> do
-              logInfo "validating journal store messages..."
+              logNote "validating journal store messages..."
               run processValidateQueue
         | otherwise = logWarn "skipping message expiration" $> Nothing
         where
@@ -1883,7 +1881,7 @@ processServerMessages StartOptions {skipWarnings} = do
 
 importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
 importMessages tty ms f old_ skipWarnings  = do
-  logInfo $ "restoring messages from file " <> T.pack f
+  logNote $ "restoring messages from file " <> T.pack f
   (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <-
     foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty))
   renameFile f $ f <> ".bak"
@@ -1948,17 +1946,17 @@ importMessages tty ms f old_ skipWarnings  = do
 
 printMessageStats :: T.Text -> MessageStats -> IO ()
 printMessageStats name MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} =
-  logInfo $ name <> " stored: " <> tshow storedMsgsCount <> ", expired: " <> tshow expiredMsgsCount <> ", queues: " <> tshow storedQueues
+  logNote $ name <> " stored: " <> tshow storedMsgsCount <> ", expired: " <> tshow expiredMsgsCount <> ", queues: " <> tshow storedQueues
 
 saveServerNtfs :: M ()
 saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs
   where
     saveNtfs f = do
-      logInfo $ "saving notifications to file " <> T.pack f
+      logNote $ "saving notifications to file " <> T.pack f
       NtfStore ns <- asks ntfStore
       liftIO . withFile f WriteMode $ \h ->
         readTVarIO ns >>= mapM_ (saveQueueNtfs h) . M.assocs
-      logInfo "notifications saved"
+      logNote "notifications saved"
       where
         -- reverse on save, to save notifications in order, will become reversed again when restoring.
         saveQueueNtfs h (nId, v) = BLD.hPutBuilder h . encodeNtfs nId . reverse =<< readTVarIO v
@@ -1971,7 +1969,7 @@ restoreServerNtfs =
     Nothing -> pure newMessageStats
   where
     restoreNtfs f = do
-      logInfo $ "restoring notifications from file " <> T.pack f
+      logNote $ "restoring notifications from file " <> T.pack f
       ns <- asks ntfStore
       old <- asks (notificationExpiration . config) >>= liftIO . expireBeforeEpoch
       liftIO $
@@ -1983,7 +1981,7 @@ restoreServerNtfs =
             renameFile f $ f <> ".bak"
             let NtfStore ns' = ns
             storedQueues <- M.size <$> readTVarIO ns'
-            logInfo $ "notifications restored, " <> tshow lineCount <> " lines processed" 
+            logNote $ "notifications restored, " <> tshow lineCount <> " lines processed"
             pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues}
       where
         restoreNtf :: NtfStore -> Int64 -> (Int, Int, Int) -> LB.ByteString -> ExceptT String IO (Int, Int, Int)
@@ -2004,15 +2002,15 @@ saveServerStats =
     >>= mapM_ (\f -> asks serverStats >>= liftIO . getServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
+      logNote $ "saving server stats to file " <> T.pack f
       B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
+      logNote "server stats saved"
 
 restoreServerStats :: Maybe MessageStats -> MessageStats -> M ()
 restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
+      logNote $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do
           s <- asks serverStats
@@ -2024,12 +2022,12 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >>
               _msgNtfExpired' = _msgNtfExpired d + expiredMsgsCount ntfStats
           liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired', _msgNtfExpired = _msgNtfExpired'}
           renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
+          logNote "server stats restored"
           compareCounts "Queue" statsQCount _qCount
           compareCounts "Message" statsMsgCount _msgCount
           compareCounts "Notification" statsNtfCount _ntfCount
         Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
+          logNote $ "error restoring server stats: " <> T.pack e
           liftIO exitFailure
     compareCounts name statsCnt storeCnt =
       when (statsCnt /= storeCnt) $ logWarn $ name <> " count differs: stats: " <> tshow statsCnt <> ", store: " <> tshow storeCnt

src/Simplex/Messaging/Server/CLI.hs

@@ -12,6 +12,7 @@
 
 module Simplex.Messaging.Server.CLI where
 
+import Control.Logger.Simple (LogLevel (..))
 import Control.Monad
 import Data.ASN1.Types (asn1CharacterToString)
 import Data.ByteString.Char8 (ByteString)
@@ -28,11 +29,12 @@ import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
-import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), 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)
@@ -174,6 +176,88 @@ certOptionsP = do
         )
   pure CertOptions {signAlgorithm_, commonName_}
 
+dbOptsP :: DBOpts -> Parser DBOpts
+dbOptsP DBOpts {connstr = defDBConnStr, schema = defDBSchema, poolSize = defDBPoolSize} = do
+  connstr <-
+    strOption
+      ( long "database"
+          <> short 'd'
+          <> metavar "DB_CONN"
+          <> help "Database connection string"
+          <> value defDBConnStr
+          <> showDefault
+      )
+  schema <-
+    strOption
+      ( long "schema"
+          <> metavar "DB_SCHEMA"
+          <> help "Database schema"
+          <> value defDBSchema
+          <> showDefault
+      )
+  poolSize <-
+    option
+      auto
+      ( long "pool-size"
+          <> metavar "POOL_SIZE"
+          <> help "Database pool size"
+          <> value defDBPoolSize
+          <> showDefault
+      )
+  pure DBOpts {connstr, schema, poolSize, createSchema = False}
+
+startOptionsP :: Parser StartOptions
+startOptionsP = do
+  maintenance <-
+    switch
+      ( long "maintenance"
+          <> short 'm'
+          <> help "Do not start the server, only perform start and stop tasks"
+      )
+  compactLog <-
+    switch
+      ( long "compact-log"
+          <> help "Compact store log (always enabled with `memory` storage for queues)"
+      )
+  logLevel <-
+    option
+      parseLogLevel
+      ( long "log-level"
+          <> metavar "LOG_LEVEL"
+          <> help "Logging level"
+          <> value LogInfo
+      )
+  skipWarnings <-
+    switch
+      ( long "skip-warnings"
+          <> help "Start the server with non-critical start warnings"
+      )
+  confirmMigrations <-
+    option
+      parseConfirmMigrations
+      ( long "confirm-migrations"
+          <> metavar "CONFIRM_MIGRATIONS"
+          <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
+          <> value MCConsole
+      )
+  pure StartOptions {maintenance, compactLog, logLevel, skipWarnings, confirmMigrations}
+    where
+      parseConfirmMigrations :: ReadM MigrationConfirmation
+      parseConfirmMigrations = eitherReader $ \case
+        "up" -> Right MCYesUp
+        "down" -> Right MCYesUpDown
+        _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
+
+parseLogLevel :: ReadM LogLevel
+parseLogLevel = eitherReader $ \case
+  "trace" -> Right LogTrace
+  "debug" -> Right LogDebug
+  "info" -> Right LogInfo
+  "note" -> Right LogNote
+  "warn" -> Right LogWarn
+  "error" -> Right LogError
+  _ -> Left "Invalid log level"
+
 genOnline :: FilePath -> CertOptions -> IO ()
 genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do
   (signAlgorithm, commonName) <-
@@ -279,7 +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
@@ -289,36 +373,45 @@ iniTransports ini =
         | otherwise = ports ws \\ smpPorts
    in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
   where
-    ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
+    ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
     ts t = map (\port -> (port, t, webPort == Just port))
     webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
     ports = map T.unpack . T.splitOn ","
 
-printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
-printServerConfig transports logFile = do
+iniDBOptions :: Ini -> DBOpts -> DBOpts
+iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
+  DBOpts
+    { connstr = either (const connstr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
+      schema = either (const schema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
+      poolSize = readIniDefault poolSize "STORE_LOG" "db_pool_size" ini,
+      createSchema = False
+    }
+
+printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
+printServerConfig protocol transports logFile = do
   putStrLn $ case logFile of
     Just f -> "Store log: " <> f
     _ -> "Store log disabled."
-  printServerTransports transports
+  printServerTransports protocol transports
 
-printServerTransports :: [(ServiceName, ATransport, AddHTTP)] -> IO ()
-printServerTransports ts = do
+printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
+printServerTransports protocol ts = do
   forM_ ts $ \(p, ATransport t, addHTTP) -> do
     let descr = p <> " (" <> transportName t <> ")..."
-    putStrLn $ "Serving SMP protocol on port " <> descr
+    putStrLn $ "Serving " <> protocol <> " protocol on port " <> descr
     when addHTTP $ putStrLn $ "Serving static site on port " <> descr
   unless (any (\(p, _, _) -> p == "443") ts) $
     putStrLn
       "\nWARNING: the clients will use port 443 by default soon.\n\
       \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
 
-printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
+printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> AServerStoreCfg -> IO ()
 printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
-  SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
-  SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile
+  SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile
   SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
     B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
-    printServerTransports transports
+    printServerTransports "SMP" transports
 
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

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

@@ -18,7 +18,59 @@
 #endif
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
-module Simplex.Messaging.Server.Env.STM where
+module Simplex.Messaging.Server.Env.STM
+  ( ServerConfig (..),
+    ServerStoreCfg (..),
+    AServerStoreCfg (..),
+    StorePaths (..),
+    StartOptions (..),
+    Env (..),
+    Server (..),
+    ServerSubscribers (..),
+    SubscribedClients,
+    ProxyAgent (..),
+    Client (..),
+    AClient (..),
+    ClientId,
+    Subscribed,
+    Sub (..),
+    ServerSub (..),
+    SubscriptionThread (..),
+    MsgStore,
+    AMsgStore (..),
+    AStoreType (..),
+    newEnv,
+    mkJournalStoreConfig,
+    newClient,
+    getServerClients,
+    getServerClient,
+    insertServerClient,
+    deleteServerClient,
+    getSubscribedClients,
+    getSubscribedClient,
+    upsertSubscribedClient,
+    lookupDeleteSubscribedClient,
+    deleteSubcribedClient,
+    sameClientId,
+    sameClient,
+    clientId',
+    newSubscription,
+    newProhibitedSub,
+    defaultMsgQueueQuota,
+    defMsgExpirationDays,
+    defNtfExpirationHours,
+    defaultMessageExpiration,
+    defaultNtfExpiration,
+    defaultInactiveClientExpiration,
+    defaultProxyClientConcurrency,
+    defaultMaxJournalMsgCount,
+    defaultMaxJournalStateLines,
+    defaultIdleQueueInterval,
+    journalMsgStoreDepth,
+    readWriteQueueStore,
+    noPostgresExit,
+  )
+where
 
 import Control.Concurrent (ThreadId)
 import Control.Logger.Simple
@@ -29,9 +81,12 @@ 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,8 +119,9 @@ 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, VersionRangeSMP, VersionSMP)
 import Simplex.Messaging.Transport.Server
+import Simplex.Messaging.Util (ifM, whenM, ($>>=))
 import System.Directory (doesFileExist)
 import System.Exit (exitFailure)
 import System.IO (IOMode (..))
@@ -73,7 +129,7 @@ import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
-  { transports :: [(ServiceName, ATransport, AddHTTP)],
+  { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     msgQueueQuota :: Int,
@@ -136,6 +192,7 @@ data ServerConfig = ServerConfig
 data StartOptions = StartOptions
   { maintenance :: Bool,
     compactLog :: Bool,
+    logLevel :: LogLevel,
     skipWarnings :: Bool,
     confirmMigrations :: MigrationConfirmation
   }
@@ -202,7 +259,6 @@ data Env = Env
     serverStats :: ServerStats,
     sockets :: TVar [(ServiceName, SocketState)],
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe AClient)),
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
@@ -235,17 +291,72 @@ data AMsgStore =
 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))),
+  { clients :: ServerClients,
+    subscribers :: ServerSubscribers,
+    ntfSubscribers :: ServerSubscribers,
     savingLock :: Lock
   }
 
+-- not exported, to prevent concurrent IntMap lookups inside STM transactions.
+newtype ServerClients = ServerClients {serverClients :: TVar (IntMap AClient)}
+
+data ServerSubscribers = ServerSubscribers
+  { subQ :: TQueue (QueueId, ClientId, Subscribed),
+    queueSubscribers :: SubscribedClients,
+    subClients :: TVar IntSet,
+    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 = SubscribedClients (TMap EntityId (TVar (Maybe AClient)))
+
+getSubscribedClients :: SubscribedClients -> IO (Map EntityId (TVar (Maybe AClient)))
+getSubscribedClients (SubscribedClients cs) = readTVarIO cs
+
+getSubscribedClient :: EntityId -> SubscribedClients -> IO (Maybe (TVar (Maybe AClient)))
+getSubscribedClient entId (SubscribedClients cs) = TM.lookupIO entId cs
+{-# INLINE getSubscribedClient #-}
+
+-- insert subscribed and current client, return previously subscribed client if it is different
+upsertSubscribedClient :: EntityId -> AClient -> SubscribedClients -> STM (Maybe AClient)
+upsertSubscribedClient entId ac@(AClient _ _ c) (SubscribedClients cs) =
+  TM.lookup entId cs >>= \case
+    Nothing -> Nothing <$ TM.insertM entId (newTVar (Just ac)) cs
+    Just cv ->
+      readTVar cv >>= \case
+        Just c' | sameClientId c c' -> pure Nothing
+        c_ -> c_ <$ writeTVar cv (Just ac)
+
+-- lookup and delete currently subscribed client
+lookupDeleteSubscribedClient :: EntityId -> SubscribedClients -> STM (Maybe AClient)
+lookupDeleteSubscribedClient entId (SubscribedClients cs) =
+  TM.lookupDelete entId cs $>>= (`swapTVar` Nothing)
+
+deleteSubcribedClient :: EntityId -> Client s -> SubscribedClients -> IO ()
+deleteSubcribedClient entId c (SubscribedClients cs) =
+  -- lookup of the subscribed client TVar can be in separate transaction,
+  -- as long as the client is read in the same transaction -
+  -- 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 -> AClient -> Bool
+sameClientId Client {clientId} ac = clientId == clientId' ac
+{-# INLINE sameClientId #-}
+
+sameClient :: Client s -> TVar (Maybe AClient) -> STM Bool
+sameClient c cv = maybe False (sameClientId c) <$> readTVar cv
+{-# INLINE sameClient #-}
+
 newtype ProxyAgent = ProxyAgent
   { smpAgent :: SMPClientAgent
   }
@@ -287,16 +398,40 @@ data Sub = Sub
 
 newServer :: IO Server
 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}
+
+getServerClients :: Server -> IO (IntMap AClient)
+getServerClients = readTVarIO . serverClients . clients
+{-# INLINE getServerClients #-}
+
+getServerClient :: ClientId -> Server -> IO (Maybe AClient)
+getServerClient cId s = IM.lookup cId <$> getServerClients s
+{-# INLINE getServerClient #-}
+
+insertServerClient :: AClient -> Server -> IO Bool
+insertServerClient ac@(AClient _ _ Client {clientId, connected}) Server {clients} =
+  atomically $
+    ifM
+      (readTVar connected)
+      (True <$ modifyTVar' (serverClients clients) (IM.insert clientId ac))
+      (pure False)
+{-# INLINE insertServerClient #-}
+
+deleteServerClient :: ClientId -> Server -> IO ()
+deleteServerClient cId Server {clients} = atomically $ modifyTVar' (serverClients clients) $ IM.delete cId
+{-# INLINE deleteServerClient #-}
+
+newServerSubscribers :: IO ServerSubscribers
+newServerSubscribers = do
+  subQ <- newTQueueIO
+  queueSubscribers <- SubscribedClients <$> TM.emptyIO
+  subClients <- newTVarIO IS.empty
+  pendingEvents <- newTVarIO IM.empty
+  pure ServerSubscribers {subQ, queueSubscribers, subClients, pendingEvents}
 
 newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms))
 newClient _ _ clientId qSize thVersion sessionId createdAt = do
@@ -311,7 +446,24 @@ 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,
+        rcvQ,
+        sndQ,
+        msgQ,
+        procThreads,
+        endThreads,
+        endThreadSeq,
+        thVersion,
+        sessionId,
+        connected,
+        createdAt,
+        rcvActiveAt,
+        sndActiveAt
+      }
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
@@ -361,18 +513,34 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
   serverStats <- newServerStats =<< getCurrentTime
   sockets <- newTVarIO []
   clientSeq <- newTVarIO 0
-  clients <- newTVarIO mempty
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure
+    Env
+      { serverActive,
+        config,
+        serverInfo,
+        server,
+        serverIdentity,
+        msgStore,
+        ntfStore,
+        random,
+        tlsServerCreds,
+        httpServerCreds,
+        serverStats,
+        sockets,
+        clientSeq,
+        proxyAgent
+      }
   where
     loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
     loadStoreLog mkQ f st = do
-      logInfo $ "restoring queues from file " <> T.pack f
+      logNote $ "restoring queues from file " <> T.pack f
       sl <- readWriteQueueStore False mkQ f st
       setStoreLog st sl
+#if defined(dbServerPostgres)
     compactDbStoreLog = \case
       Just f -> do
-        logInfo $ "compacting queues in file " <> T.pack f
+        logNote $ "compacting queues in file " <> T.pack f
         st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota}
         -- we don't need to have locks in the map
         sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st)
@@ -381,6 +549,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
       Nothing -> do
         logError "Error: `--compact-log` used without `db_store_log` INI option"
         exitFailure
+#endif
     getCredentials protocol creds = do
       files <- missingCreds
       unless (null files) $ do

src/Simplex/Messaging/Server/Main.hs

@@ -247,13 +247,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       where
         iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
         iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
-    iniDBOptions ini =
-      DBOpts
-        { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
-          schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
-          poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini,
-          createSchema = False
-        }
     iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
     defaultStaticPath = combine logPath "www"
     enableStoreLog' = settingIsOn "STORE_LOG" "enable"
@@ -327,6 +320,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               SPRandom -> BasicAuth <$> randomBase64 32
             randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
     runServer startOptions ini = do
+      setLogLevel $ logLevel startOptions
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
@@ -411,7 +405,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
                 ASType SQSPostgres SMSJournal ->
                   let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
-                      storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+                      storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
                    in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir},
               storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
               -- allow creating new queues by default
@@ -512,7 +506,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
 #if defined(dbServerPostgres)
               SQSPostgres -> do
-                let DBOpts {connstr, schema} = iniDBOptions ini
+                let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
                 schemaExists <- checkSchemaExists connstr schema
                 case enableDbStoreLog' ini of
                   Just ()
@@ -657,7 +651,7 @@ data CliCommand
   | Start StartOptions
   | Delete
   | Journal StoreCmd
-  | Database StoreCmd DBOpts
+  | Database StoreCmd DBOpts 
 
 data StoreCmd = SCImport | SCExport | SCDelete
 
@@ -669,7 +663,7 @@ cliCommandP cfgPath logPath iniFile =
         <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
         <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
-        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -684,7 +678,7 @@ cliCommandP cfgPath logPath iniFile =
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"
             )
-      dbOptions <- dbOptsP
+      dbOptions <- dbOptsP defaultDBOpts
       logStats <-
         switch
           ( long "daily-stats"
@@ -815,32 +809,6 @@ cliCommandP cfgPath logPath iniFile =
             disableWeb,
             scripted
           }
-    startOptionsP = do
-      maintenance <-
-        switch
-          ( long "maintenance"
-              <> short 'm'
-              <> help "Do not start the server, only perform start and stop tasks"
-          )
-      compactLog <-
-        switch
-          ( long "compact-log"
-              <> help "Compact store log (always enabled with `memory` storage for queues)"
-          )
-      skipWarnings <-
-        switch
-          ( long "skip-warnings"
-              <> help "Start the server with non-critical start warnings"
-          )
-      confirmMigrations <-
-        option
-          parseConfirmMigrations
-          ( long "confirm-migrations"
-              <> metavar "CONFIRM_MIGRATIONS"
-              <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
-              <> value MCConsole
-          )
-      pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations}
     journalCmdP = storeCmdP "message log file" "journal storage"
     databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
     storeCmdP src dest =
@@ -849,39 +817,6 @@ cliCommandP cfgPath logPath iniFile =
             <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
             <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
         )
-    dbOptsP = do
-      connstr <-
-        strOption
-          ( long "database"
-              <> short 'd'
-              <> metavar "DB_CONN"
-              <> help "Database connection string"
-              <> value defaultDBConnStr
-              <> showDefault
-          )
-      schema <-
-        strOption
-          ( long "schema"
-              <> metavar "DB_SCHEMA"
-              <> help "Database schema"
-              <> value defaultDBSchema
-              <> showDefault
-          )
-      poolSize <-
-        option
-          auto
-          ( long "pool-size"
-              <> metavar "POOL_SIZE"
-              <> help "Database pool size"
-              <> value defaultDBPoolSize
-              <> showDefault
-          )
-      pure DBOpts {connstr, schema, poolSize, createSchema = False}
-    parseConfirmMigrations :: ReadM MigrationConfirmation
-    parseConfirmMigrations = eitherReader $ \case
-      "up" -> Right MCYesUp
-      "down" -> Right MCYesUpDown
-      _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
@@ -901,5 +836,6 @@ cliCommandP cfgPath logPath iniFile =
             <> metavar (metavar' <> "_COUNTRY")
             <> help (help' <> " country")
         )
-    strParse :: StrEncoding a => ReadM a
-    strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack
+
+strParse :: StrEncoding a => ReadM a
+strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack

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

@@ -4,11 +4,9 @@
 
 module Simplex.Messaging.Server.Main.Init where
 
-import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isNothing)
-import Numeric.Natural (Natural)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
@@ -27,14 +25,14 @@ import System.FilePath ((</>))
 defaultControlPort :: Int
 defaultControlPort = 5224
 
-defaultDBConnStr :: ByteString
-defaultDBConnStr = "postgresql://smp@/smp_server_store"
-
-defaultDBSchema :: ByteString
-defaultDBSchema = "smp_server"
-
-defaultDBPoolSize :: Natural
-defaultDBPoolSize = 10
+defaultDBOpts :: DBOpts
+defaultDBOpts =
+  DBOpts
+    { connstr = "postgresql://smp@/smp_server_store",
+      schema = "smp_server",
+      poolSize = 10,
+      createSchema = False
+    }
 
 -- time to retain deleted queues in the database (days), for debugging
 defaultDeletedTTL :: Int64
@@ -77,13 +75,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
         \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\
         \store_queues: memory\n\n\
         \# Database connection settings for PostgreSQL database (`store_queues: database`).\n"
-    <> (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n")
-    <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n")
-    <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n")
+    <> iniDbOpts dbOptions defaultDBOpts
     <> "# Write database changes to store log file\n\
         \# db_store_log: off\n\n\
         \# Time to retain deleted queues in the database, days.\n"
-    <> ("db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
+    <> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
     <> "# Message storage mode: `memory` or `journal`.\n\
         \store_messages: memory\n\n\
         \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
@@ -164,7 +160,6 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
     <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
   where
     InitOptions {enableStoreLog, dbOptions, socksProxy, ownDomains, controlPort, webStaticPath, disableWeb, logStats} = opts
-    DBOpts {connstr, schema, poolSize} = dbOptions
     defaultServerPorts = "5223,443"
     defaultStaticPath = logPath </> "www"
     httpsCertFile = cfgPath </> "web.crt"
@@ -221,6 +216,12 @@ informationIniContent InitOptions {sourceCode, serverInfo} =
         <> "\n"
         <> countryStr optName (country =<< entity)
 
+iniDbOpts :: DBOpts -> DBOpts -> Text
+iniDbOpts DBOpts {connstr, schema, poolSize} DBOpts {connstr = defConnstr, schema = defSchema, poolSize = defPoolSize} =
+  (optDisabled' (connstr == defConnstr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n")
+    <> (optDisabled' (schema == defSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n")
+    <> (optDisabled' (poolSize == defPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n")
+
 optDisabled :: Maybe a -> Text
 optDisabled = optDisabled' . isNothing
 {-# INLINE optDisabled #-}

src/Simplex/Messaging/Server/NtfStore.hs

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

src/Simplex/Messaging/Server/Prometheus.hs

@@ -14,6 +14,7 @@ import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
 import Simplex.Messaging.Server.MsgStore.Types (LoadedQueueCounts (..))
 import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Server (SocketStats (..))
 
 data ServerMetrics = ServerMetrics
@@ -21,34 +22,39 @@ data ServerMetrics = ServerMetrics
     activeQueueCounts :: PeriodStatCounts,
     activeNtfCounts :: PeriodStatCounts,
     queueCount :: Int,
-    notifierCount :: Int
+    notifierCount :: Int,
+    rtsOptions :: Text
   }
 
+rtsOptionsEnv :: Text
+rtsOptionsEnv = "SMP_RTS_OPTIONS"
+
 data RealTimeMetrics = RealTimeMetrics
   { socketStats :: [(ServiceName, SocketStats)],
     threadsCount :: Int,
     clientsCount :: Int,
-    smpSubsCount :: Int,
-    smpSubClientsCount :: Int,
-    ntfSubsCount :: Int,
-    ntfSubClientsCount :: Int,
+    smpSubs :: RTSubscriberMetrics,
+    ntfSubs :: RTSubscriberMetrics,
     loadedCounts :: LoadedQueueCounts
   }
 
+data RTSubscriberMetrics = RTSubscriberMetrics
+  { subsCount :: Int,
+    subClientsCount :: Int
+  }
+
 {-# FOURMOLU_DISABLE\n#-}
 prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
 prometheusMetrics sm rtm ts =
   time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info
   where
-    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} = sm
+    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount, rtsOptions} = sm
     RealTimeMetrics
       { socketStats,
         threadsCount,
         clientsCount,
-        smpSubsCount,
-        smpSubClientsCount,
-        ntfSubsCount,
-        ntfSubClientsCount,
+        smpSubs,
+        ntfSubs,
         loadedCounts
       } = rtm
     ServerStatsData
@@ -87,10 +93,8 @@ prometheusMetrics sm rtm ts =
         _msgGetDuplicate,
         _msgGetProhibited,
         _msgExpired,
-        _activeQueues,
         _msgSentNtf,
         _msgRecvNtf,
-        _activeQueuesNtf,
         _msgNtfs,
         _msgNtfsB,
         _msgNtfNoSub,
@@ -347,6 +351,10 @@ prometheusMetrics sm rtm ts =
     info =
       "# Info\n\
       \# ----\n\
+      \\n\
+      \# HELP simplex_smp_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
+      \# TYPE simplex_smp_info gauge\n\
+      \simplex_smp_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
       \\n"
       <> socketsMetric socketsAccepted "simplex_smp_sockets_accepted" "Accepted sockets"
       <> socketsMetric socketsClosed "simplex_smp_sockets_closed" "Closed sockets"
@@ -360,21 +368,21 @@ 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\
+      \# HELP simplex_smp_subscribtion_total Total SMP subscriptions\n\
       \# TYPE simplex_smp_subscribtion_total gauge\n\
-      \simplex_smp_subscribtion_total " <> mshow smpSubsCount <> "\n# smpSubs\n\
+      \simplex_smp_subscribtion_total " <> mshow (subsCount smpSubs) <> "\n# smp.subsCount\n\
       \\n\
-      \# HELP simplex_smp_subscribtion_clients_total Subscribed clients, first counting method\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_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_loaded_queues_queue_count Total loaded queues count (all queues for memory/journal storage)\n\
       \# TYPE simplex_smp_loaded_queues_queue_count gauge\n\

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

@@ -23,6 +23,9 @@ module Simplex.Messaging.Server.QueueStore.Postgres
     PostgresStoreCfg (..),
     batchInsertQueues,
     foldQueueRecs,
+    handleDuplicate,
+    withLog_,
+    withDB',
   )
 where
 
@@ -56,6 +59,7 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import GHC.IO (catchAny)
 import Simplex.Messaging.Agent.Client (withLockMap)
 import Simplex.Messaging.Agent.Lock (Lock)
+import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
@@ -135,7 +139,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
           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) AS queue_count,
               (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count
           |]
       pure QueueCounts {queueCount, notifierCount}
@@ -218,7 +222,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))
@@ -332,7 +336,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} ->
@@ -530,8 +534,12 @@ withDB op st action =
         err = op <> ", withDB, " <> show e
 
 withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
-withLog op PostgresQueueStore {dbStoreLog} action =
-  forM_ dbStoreLog $ \sl -> liftIO $ action sl `catchAny` \e ->
+withLog op PostgresQueueStore {dbStoreLog} = withLog_ op dbStoreLog
+{-# INLINE withLog #-}
+
+withLog_ :: MonadIO m => String -> Maybe (StoreLog 'WriteMode) -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog_ op sl_ action =
+  forM_ sl_ $ \sl -> liftIO $ action sl `catchAny` \e ->
     logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e)
 
 handleDuplicate :: SqlError -> IO ErrorType
@@ -541,15 +549,15 @@ handleDuplicate e = case constraintViolation e of
 
 -- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL
 
-instance ToField EntityId where toField (EntityId s) = toField $ Binary s
-
-deriving newtype instance FromField EntityId
-
 instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary . smpEncode
 
 instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode
 
 #if !defined(dbPostgres)
+instance ToField EntityId where toField (EntityId s) = toField $ Binary s
+
+deriving newtype instance FromField EntityId
+
 instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
 
 instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode

src/Simplex/Messaging/Server/StoreLog.hs

@@ -267,7 +267,7 @@ readWriteStoreLog readStore writeStore f st =
       logWarn $ "Server terminated abnormally on last start, restoring state from " <> T.pack tempBackup
       whenM (doesFileExist f) $ do
         renameFile f (f <> ".bak")
-        logInfo $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
+        logNote $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
       renameFile tempBackup f
     readWriteLog = do
       -- log backup is made in two steps to mitigate the crash during the compacting.
@@ -280,14 +280,14 @@ readWriteStoreLog readStore writeStore f st =
       pure s
     writeLog msg = do
       s <- openWriteStoreLog False f
-      logInfo msg
+      logNote msg
       writeStore s st
       pure s
     renameBackup = do
       ts <- getCurrentTime
       let timedBackup = f <> "." <> iso8601Show ts
       renameFile tempBackup timedBackup
-      logInfo $ "original state preserved as " <> T.pack timedBackup
+      logNote $ "original state preserved as " <> T.pack timedBackup
 
 removeStoreLogBackups :: FilePath -> IO ()
 removeStoreLogBackups f = do

src/Simplex/Messaging/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

@@ -61,7 +61,10 @@ module Simplex.Messaging.Transport
     Transport (..),
     TProxy (..),
     ATransport (..),
+    ASrvTransport,
     TransportPeer (..),
+    STransportPeer (..),
+    TransportPeerI (..),
     getServerVerifyKey,
 
     -- * TLS Transport
@@ -78,6 +81,7 @@ module Simplex.Messaging.Transport
     THandle (..),
     THandleParams (..),
     THandleAuth (..),
+    CertChainPubKey (..),
     TSbChainKeys (..),
     TransportError (..),
     HandshakeError (..),
@@ -100,13 +104,14 @@ 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)
@@ -241,68 +246,78 @@ 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 -> 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
-
-  -- | 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)
+  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,
+    tlsPeerCert :: X.CertificateChain,
     tlsTransportConfig :: TransportConfig
   }
 
@@ -317,21 +332,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 -> X.CertificateChain -> T.Context -> IO (TLS p)
+getTLS cfg 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, 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 +391,31 @@ 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 #-}
+  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 +428,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
   }
 
@@ -435,7 +456,7 @@ data THandleParams v p = THandleParams
 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
+      serverCertKey :: CertChainPubKey, -- the key here is serverPeerPubKey signed with server certificate
       sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
     } ->
     THandleAuth 'TClient
@@ -453,15 +474,15 @@ data TSbChainKeys = TSbChainKeys
 -- | TLS-unique channel binding
 type SessionId = ByteString
 
-data ServerHandshake = ServerHandshake
+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
+data SMPClientHandshake = SMPClientHandshake
   { -- | agreed SMP server protocol version
     smpVersion :: VersionSMP,
     -- | server identity - CA certificate fingerprint
@@ -474,8 +495,8 @@ data ClientHandshake = ClientHandshake
     proxyServer :: Bool
   }
 
-instance Encoding ClientHandshake where
-  smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
+instance Encoding SMPClientHandshake where
+  smpEncode SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
     smpEncode (v, keyHash)
       <> encodeAuthEncryptCmds v authPubKey
       <> ifHasProxy v (smpEncode proxyServer) ""
@@ -484,28 +505,35 @@ instance Encoding ClientHandshake where
     -- 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}
+    pure SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
 
 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} =
+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
@@ -587,15 +615,14 @@ 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
+smpServerHandshake :: forall c. Transport c => X.CertificateChain -> C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
+smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange = do
   let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
-      sk = C.signX509 serverSignKey $ C.publicToX509 k
-      certChain = getServerCerts c
+      sk = C.signX509 srvSignKey $ C.publicToX509 k
       smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
-  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
+  sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = Just (CertChainPubKey srvCert sk)}
   getHandshake th >>= \case
-    ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
+    SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
       | keyHash /= kh ->
           throwE $ TEHandshake IDENTITY
       | otherwise ->
@@ -606,10 +633,10 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
 -- | 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 :: forall c. Transport c => c 'TClient -> 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
+  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,16 +657,15 @@ 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 (X.CertificateChain cert) exact) ->
         liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
           case cert of
             [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca 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}
+      sendHandshake th $ SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
       liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer
     Nothing -> throwE TEVersion
 
@@ -649,7 +675,7 @@ smpTHandleServer th v vr pk k_ proxyServer = do
   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 :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> 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_
   be <- blockEncryption th v proxyServer thAuth
@@ -673,8 +699,8 @@ smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
    in (th :: THandleSMP c p) {params = params'}
 
 {-# 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
+forceCertChain :: CertChainPubKey -> CertChainPubKey
+forceCertChain cert@(CertChainPubKey (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_.
@@ -689,7 +715,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

src/Simplex/Messaging/Transport/Client.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -124,7 +125,7 @@ data TransportClientConfig = TransportClientConfig
     tcpConnectTimeout :: Int,
     tcpKeepAlive :: Maybe KeepAliveOpts,
     logTLSErrors :: Bool,
-    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
+    clientCredentials :: Maybe T.Credential,
     alpn :: Maybe [ALPN],
     useSNI :: Bool
   }
@@ -142,10 +143,10 @@ 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 :: 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, alpn, useSNI} socksCreds host port keyHash client = do
   serverCert <- newEmptyTMVarIO
   let hostName = B.unpack $ strEncode host
@@ -165,7 +166,7 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
           logError "onServerCertificate didn't fire or failed to get cert chain"
           closeTLS tls >> error "onServerCertificate failed"
         Just c -> pure c
-    getClientConnection tCfg chain tls
+    getTransportConnection tCfg chain tls
   client c `E.finally` closeConnection c
   where
     hostAddr = \case
@@ -264,7 +265,7 @@ 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 :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe T.Credential -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
 mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ sni serverCerts =
   (T.defaultParamsClient host p)
     { T.clientUseServerNameIndication = sni,

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)
@@ -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
@@ -67,10 +68,11 @@ runHTTP2Server started port bufferSize srvSupported srvCreds alpn_ transportConf
   where
     setup = runTransportServer started port srvSupported srvCreds alpn_ 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,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -87,31 +88,31 @@ 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 :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
 runTransportServer started port srvSupported srvCreds alpn_ cfg server = do
   ss <- newSocketState
   runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server
 
-runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
+runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> 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))
+runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> 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.
-runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
+runTransportServerSocket :: Transport c => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (c 'TServer -> 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 :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
 runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ =
   runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams
   where
     srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_
 
 -- | 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_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> T.Credential) -> T.ServerParams -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
 runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do
   labelMyThread $ "transport server for " <> threadLabel
   runTCPServerSocket ss started getSocket $ \conn ->
@@ -121,7 +122,7 @@ runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvPara
     setup conn = timeout (tlsSetupTimeout cfg) $ do
       labelMyThread $ threadLabel <> "/setup"
       tls <- connectTLS Nothing tCfg srvParams conn
-      getServerConnection tCfg (fst $ srvCreds Nothing) tls
+      getTransportConnection tCfg (fst $ srvCreds Nothing) tls
 
 -- | Run TCP server without TLS
 runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
@@ -202,7 +203,7 @@ startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStart
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       setSocketOption sock ReuseAddr 1
       withFdSocket sock setCloseOnExecIfNeeded
-      logInfo $ "binding to " <> tshow (addrAddress addr)
+      logNote $ "binding to " <> tshow (addrAddress addr)
       bind sock $ addrAddress addr
       listen sock 1024
       pure sock

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,13 @@ 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
+    wsPeerCert :: X.CertificateChain
   }
 
 websocketsOpts :: ConnectionOptions
@@ -46,61 +51,50 @@ 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 #-}
+  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 -> X.CertificateChain -> T.Context -> IO (WS p)
+getWS cfg 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, 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

@@ -224,6 +224,7 @@ groupOn = groupBy . eqOn
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f
 
+-- n must be > 0
 toChunks :: Int -> [a] -> [NonEmpty a]
 toChunks _ [] = []
 toChunks n xs =

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,7 +23,7 @@ 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)
@@ -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 ->

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

@@ -12,12 +12,12 @@ import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
 import AgentTests.MigrationTests (migrationTests)
-import AgentTests.NotificationTests (notificationTests)
 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
 import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
@@ -25,6 +25,12 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
 import AgentTests.SQLiteTests (storeTests)
 #endif
 
+#if defined(dbServerPostgres)
+import AgentTests.NotificationTests (notificationTests)
+import SMPClient (postgressBracket)
+import NtfClient (ntfTestServerDBConnectInfo)
+#endif
+
 agentCoreTests :: Spec
 agentCoreTests = do
   describe "Migration tests" migrationTests
@@ -32,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
@@ -41,7 +47,10 @@ agentTests ps = do
 #endif
     describe "Functional API" $ functionalAPITests ps
     describe "Chosen servers" serverChoiceTests
-    describe "Notification tests" $ notificationTests ps
+#if defined(dbServerPostgres)
+    around_ (postgressBracket ntfTestServerDBConnectInfo) $
+      describe "Notification tests" $ notificationTests ps
+#endif
 #if !defined(dbPostgres)
   describe "SQLite store" storeTests
 #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

@@ -22,8 +22,6 @@ deriving instance Eq (StoredRcvQueue q)
 
 deriving instance Eq (StoredSndQueue q)
 
-deriving instance Eq (DBQueueId q)
-
 deriving instance Eq ClientNtfCreds
 
 deriving instance Eq ShortLinkCreds

tests/AgentTests/FunctionalAPITests.hs

@@ -71,18 +71,20 @@ 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 SMPClient
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, 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.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
@@ -102,19 +104,28 @@ import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..),
 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, supportedSMPHandshakes, 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)
 
@@ -267,7 +278,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
@@ -320,6 +331,7 @@ functionalAPITests ps = 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,7 +498,7 @@ 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}
       canCreate1 = canCreateQueue allowNewQueues srv clnt1
@@ -503,7 +515,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 +524,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 +537,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,17 +553,17 @@ 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
@@ -564,13 +576,13 @@ testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do
     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 +596,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
@@ -1047,7 +1059,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 +1075,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 +1085,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
@@ -1129,6 +1142,10 @@ 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
@@ -1200,16 +1217,16 @@ testContactShortLink viaProxy a b =
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
     let updatedData = "updated user data"
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    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 ()
 
@@ -1219,7 +1236,7 @@ testAddContactShortLink viaProxy a b =
     (contactId, CCLink connReq0 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
+    shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
@@ -1247,13 +1264,13 @@ testAddContactShortLink viaProxy a b =
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
     let updatedData = "updated user data"
-    shortLink' <- runRight $ setContactShortLink a contactId updatedData
+    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 $
@@ -1265,7 +1282,7 @@ 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 $
@@ -1278,19 +1295,19 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
     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
     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"
   withSmpServer ps $ do
@@ -1299,14 +1316,57 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
     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) <- 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 = "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 = "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 +1431,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 +1461,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 +1487,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 +1518,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 +1570,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
@@ -1561,7 +1621,7 @@ testSkippedMessages (t, msType) = do
   where
     cfg' = (cfgMS msType) {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ 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 +1639,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 +1667,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 +1683,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,7 +1722,7 @@ withUP a bId p =
         \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
       ]
 
-testExpireMessageQuota :: HasCallStack => (ATransport, AStoreType) -> IO ()
+testExpireMessageQuota :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1688,7 +1748,7 @@ testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msg
     ackMessage b' aId 4 Nothing
   disposeAgentClient a
 
-testExpireManyMessagesQuota :: (ATransport, AStoreType) -> IO ()
+testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO ()
 testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1725,7 +1785,7 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType)
     ackMessage b' aId 4 Nothing
   disposeAgentClient a
 
-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 +1859,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 +1885,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 +1910,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 +1939,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
@@ -1946,7 +2006,7 @@ testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProx
 getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a
 getMsg c cId action = do
   liftIO $ noMessages c "nothing should be delivered before GET"
-  [Just _] <- lift $ getConnectionMessages c [cId]
+  [Right (Just _)] <- lift $ getConnectionMessages c [ConnMsgReq cId 1 Nothing]
   action
 
 getMSGNTF :: AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
@@ -2006,7 +2066,7 @@ 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}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2016,7 +2076,7 @@ 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}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2027,7 +2087,7 @@ 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}}
   withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2070,7 +2130,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 +2161,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 +2180,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
@@ -2312,7 +2372,7 @@ 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
@@ -2363,7 +2423,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 +2439,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 +2467,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 +2521,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 +2564,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 +2604,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,7 +2650,7 @@ 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 ->
@@ -2635,7 +2695,7 @@ 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 ->
@@ -2702,7 +2762,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
@@ -3137,7 +3197,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
           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
     -- initially passed server is not running
@@ -3172,7 +3232,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,7 +3285,7 @@ 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
     withAgentClients2 $ \a b -> do
@@ -3577,7 +3637,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

@@ -53,13 +53,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, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'')
+import SMPClient (cfgJ2QS, cfgMS, cfgVPrev, ntfTestPort, ntfTestPort2, testServerStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 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)
@@ -73,21 +72,24 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Server.Store.Postgres (closeNtfDbStore, newNtfDbStore, withDB')
 import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
+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 Test.Hspec
+import Simplex.Messaging.Transport (ASrvTransport)
+import System.Process (callCommand)
+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" $
@@ -120,10 +122,10 @@ notificationTests ps@(t, _) = do
     it "should keep working with active token until replaced" $
       withAPNSMockServer $ \apns ->
         testNtfTokenChangeServers t apns
-    xit'' "should re-register token in NTInvalid status after register attempt" $
+    it "should re-register token in NTInvalid status after register attempt" $
       withAPNSMockServer $ \apns ->
         testNtfTokenReRegisterInvalid t apns
-    xit'' "should re-register token in NTInvalid status after checking token" $
+    it "should re-register token in NTInvalid status after checking token" $
       withAPNSMockServer $ \apns ->
         testNtfTokenReRegisterInvalidOnCheck t apns
   describe "notification server tests" $ do
@@ -152,10 +154,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 ->
@@ -163,15 +165,15 @@ notificationTests ps@(t, _) = do
   it "should keep sending notifications for old token" $
     withSmpServer ps $
       withAPNSMockServer $ \apns ->
-        withNtfServerOn t ntfTestPort $
+        withNtfServer t $
           testNotificationsOldToken apns
   it "should update server from new token" $
     withSmpServer ps $
       withAPNSMockServer $ \apns ->
-        withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
+        withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 . withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
           testNotificationsNewToken apns ntf
 
-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
@@ -188,9 +190,9 @@ 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 -> ServerConfig -> 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}
+  let smpCfg' = smpCfg {serverStoreCfg = testServerStoreConfig msType}
   withSmpServerConfigOn t smpCfg' testPort $ \_ ->
     withAPNSMockServer $ \apns ->
       withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ ->
@@ -223,8 +225,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
@@ -244,8 +244,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
@@ -274,11 +272,11 @@ 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 ->
-    withNtfServerStoreLog t $ \_ -> runRight $ do
+    withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
         getMockNotification apns tkn
@@ -288,18 +286,18 @@ testNtfTokenServerRestart t apns = do
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
     -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
     -- so that repeat verification happens without restarting the clients, when notification arrives
-    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       verification <- ntfData .-> "verification"
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       verifyNtfToken a' tkn nonce verification
       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
-    ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do
+    ntfData <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
         getMockNotification apns tkn
@@ -309,20 +307,20 @@ testNtfTokenServerRestartReverify t apns = do
       nonce <- C.cbNonce <$> ntfData .-> "nonce"
       Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification
       pure ()
-  threadDelay 1000000
+  threadDelay 1500000
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
     -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
     -- so that repeat verification happens without restarting the clients, when notification arrives
-    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       NTActive <- registerNtfToken a' tkn NMPeriodic
       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
-    (nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do
+    (nonce, verification) <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
         getMockNotification apns tkn
@@ -344,20 +342,20 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
         (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString)
     Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
     pure ()
-  threadDelay 1000000
+  threadDelay 1500000
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
     -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
     -- so that repeat verification happens without restarting the clients, when notification arrives
-    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       NTActive <- registerNtfToken a' tkn NMPeriodic
       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 ->
-    withNtfServerStoreLog t $ \_ -> runRight $ do
+    withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <-
         getMockNotification apns tkn
@@ -367,7 +365,7 @@ testNtfTokenServerRestartReregister t apns = do
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
     -- server stopped before token is verified, and client might have lost verification notification.
     -- so that repeat registration happens when client is restarted.
-    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       NTRegistered <- registerNtfToken a' tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
         getMockNotification apns tkn
@@ -377,11 +375,11 @@ 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
-    withNtfServerStoreLog t $ \_ -> runRight $ do
+    withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <-
         getMockNotification apns tkn
@@ -402,7 +400,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do
   withAgent 2 agentCfg initAgentServers testDB $ \a' ->
     -- server stopped before token is verified, and client might have lost verification notification.
     -- so that repeat registration happens when client is restarted.
-    withNtfServerStoreLog t $ \_ -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       NTRegistered <- registerNtfToken a' tkn NMPeriodic
       APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
         getMockNotification apns tkn
@@ -418,12 +416,12 @@ 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 ->
-    withNtfServerThreadOn t ntfTestPort $ \ntf ->
-      withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
+    withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
+      withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do
         -- register a new token, the agent picks a server and stores its choice
         NTRegistered <- registerNtfToken a tkn NMPeriodic
         APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
@@ -442,9 +440,9 @@ testNtfTokenMultipleServers t apns = do
         Left _ <- tryError (checkNtfToken a tkn)
         pure ()
 
-testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
+testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenChangeServers t apns =
-  withNtfServerThreadOn t ntfTestPort $ \ntf -> do
+  withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do
     tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
       tkn <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn
@@ -467,14 +465,14 @@ testNtfTokenChangeServers t apns =
         Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apns -- ok, it's down for now
         getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
       killThread ntf
-      withNtfServerOn t ntfTestPort2 $ runRight_ $ do
+      withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 $ runRight_ $ do
         liftIO $ threadDelay 1000000 -- for notification server to reconnect
         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 <- withNtfServerStoreLog t $ \_ -> do
+  tkn <- withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
       tkn <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn
@@ -482,28 +480,24 @@ testNtfTokenReRegisterInvalid t apns = do
 
   threadDelay 250000
   -- start server to compact
-  withNtfServerStoreLog t $ \_ -> pure ()
+  withNtfServer t $ pure ()
 
   threadDelay 250000
-  replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID"
+  st <- newNtfDbStore ntfTestDBCfg
+  Right 1 <- withDB' "test" st $ \db -> PSQL.execute db "UPDATE tokens SET status = ? WHERE status = ?" (NTInvalid Nothing, NTActive)
+  closeNtfDbStore st
 
   threadDelay 250000
-  withNtfServerStoreLog t $ \_ -> do
+  withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
       NTInvalid Nothing <- registerNtfToken a tkn NMInstant
       tkn1 <- registerTestToken a "abcd" NMInstant apns
       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 <- withNtfServerStoreLog t $ \_ -> do
+  tkn <- withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
       tkn <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn
@@ -511,22 +505,24 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
 
   threadDelay 250000
   -- start server to compact
-  withNtfServerStoreLog t $ \_ -> pure ()
+  withNtfServer t $ pure ()
 
   threadDelay 250000
-  replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID"
+  st <- newNtfDbStore ntfTestDBCfg
+  Right 1 <- withDB' "test" st $ \db -> PSQL.execute db "UPDATE tokens SET status = ? WHERE status = ?" (NTInvalid Nothing, NTActive)
+  closeNtfDbStore st
 
   threadDelay 250000
-  withNtfServerStoreLog t $ \_ -> do
+  withNtfServer t $ do
     withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
       NTInvalid Nothing <- checkNtfToken a tkn
       tkn1 <- registerTestToken a "abcd" NMInstant apns
       NTActive <- checkNtfToken a tkn1
       pure ()
 
-testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
+testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
 testRunNTFServerTests t srv =
-  withNtfServerOn t ntfTestPort $
+  withNtfServer t $
     withAgent 1 agentCfg initAgentServers testDB $ \a ->
       testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
 
@@ -551,32 +547,28 @@ 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
     (nonce, message) <- messageNotification apns tkn
     pure (bobId, aliceId, nonce, message)
 
-  Right [NotificationInfo {ntfConnId = cId}] <- runExceptT $ getNotificationConns alice nonce message
+  Right [NotificationInfo {ntfConnId = cId, ntfMsgMeta = Just NMsgMeta {msgTs}}] <- runExceptT $ getNotificationConns alice nonce message
   cId `shouldBe` bobId
   -- alice client already has subscription for the connection,
-  -- so get fails with CMD PROHIBITED (transformed into Nothing in catch)
-  [Nothing] <- getConnectionMessages alice [cId]
+  [Left (CMD PROHIBITED _)] <- getConnectionMessages alice [ConnMsgReq cId 1 $ Just $ systemToUTCTime msgTs]
 
-  threadDelay 500000
+  threadDelay 1000000
   suspendAgent alice 0
   closeDBStore store
-  threadDelay 1000000
-  putStrLn "before opening the database from another agent"
+  threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
   withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> do
-    (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId]
+    (Right (Just SMPMsgMeta {msgFlags = MsgFlags True})) :| _ <- getConnectionMessages aliceNtf [ConnMsgReq cId 1 $ Just $ systemToUTCTime msgTs]
     pure ()
 
-  threadDelay 1000000
-  putStrLn "after closing the database in another agent"
+  threadDelay 1000000 >> callCommand "sync" >> threadDelay 1000000
   reopenDBStore store
   foregroundAgent alice
   threadDelay 500000
@@ -750,10 +742,10 @@ 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) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
+    (aliceId, bobId) <- withNtfServer t $ runRight $ do
       (aliceId, bobId) <- makeConnection alice bob
       _ <- registerTestToken alice "abcd" NMInstant apns
       liftIO $ threadDelay 250000
@@ -762,19 +754,17 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
       void $ messageNotificationData alice apns
       get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
       ackMessage alice bobId 2 Nothing
-      liftIO $ killThread threadId
       pure (aliceId, bobId)
 
     liftIO $ threadDelay 250000
 
-    withNtfServerStoreLog t $ \threadId -> runRight_ $ do
+    withNtfServer t $ runRight_ $ do
       liftIO $ threadDelay 250000
       3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
       get bob ##> ("", aliceId, SENT 3)
       void $ messageNotificationData alice apns
       get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
       ackMessage alice bobId 3 Nothing
-      liftIO $ killThread threadId
 
     runRight_ $ do
       4 <- sendMessage bob aliceId (SMP.MsgFlags True) "message 4"
@@ -784,10 +774,10 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
       noNotifications apns
 
   withSmpServerStoreMsgLogOn ps testPort $ \_ ->
-    withNtfServerStoreLog t $ \_ -> runRight_ $ 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
@@ -815,7 +805,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

tests/AgentTests/SQLiteTests.hs

@@ -52,11 +52,13 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), 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"
@@ -229,7 +231,7 @@ rcvQueue1 =
       queueMode = Just QMMessaging,
       shortLink = Nothing,
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = DBNewEntity,
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,
@@ -251,7 +253,7 @@ sndQueue1 =
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New,
-      dbQueueId = DBNewQueue,
+      dbQueueId = DBNewEntity,
       primary = True,
       dbReplaceQueueId = Nothing,
       sndSwchStatus = Nothing,
@@ -270,11 +272,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 +288,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 +306,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 +322,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 +413,7 @@ testUpgradeRcvConnToDuplex =
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = DBNewEntity,
               sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
@@ -442,7 +444,7 @@ testUpgradeSndConnToDuplex =
               queueMode = Just QMMessaging,
               shortLink = Nothing,
               status = New,
-              dbQueueId = DBNewQueue,
+              dbQueueId = DBNewEntity,
               rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,

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
@@ -61,7 +62,8 @@ initServers =
     { smp = M.fromList [(1, testSMPServers)],
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
-      netCfg = defaultNetworkConfig
+      netCfg = defaultNetworkConfig,
+      presetDomains = []
     }
 
 testChooseDifferentOperator :: IO ()

tests/AgentTests/ShortLinkTests.hs

@@ -11,7 +11,8 @@ import Control.Monad.Except
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), 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
 

tests/CLITests.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module CLITests where
 
@@ -7,6 +10,7 @@ import AgentTests.FunctionalAPITests (runRight_)
 import Control.Logger.Simple
 import Control.Monad
 import qualified Crypto.PubKey.RSA as RSA
+import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as HM
 import Data.Ini (Ini (..), lookupValue, readIniFile, writeIniFile)
@@ -19,9 +23,8 @@ import qualified Network.HTTP.Client as H1
 import qualified Network.HTTP2.Client as H2
 import Simplex.FileTransfer.Server.Main (xftpServerCLI)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Server.Main
 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
@@ -33,12 +36,22 @@ 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
+import Database.PostgreSQL.Simple.Types (Query (..))
+import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts)
+import SMPClient (postgressBracket)
+import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
+import Simplex.Messaging.Notifications.Server.Main
+#endif
 
 cfgPath :: FilePath
 cfgPath = "tests/tmp/cli/etc/opt/simplex"
@@ -70,9 +83,12 @@ cliTests = do
       it "no store log, no password" $ smpServerTest False False
       it "with store log, no password" $ smpServerTest True False
       it "static files" smpServerTestStatic
-  describe "Ntf server CLI" $ do
-    it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
-    it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
+#if defined(dbServerPostgres)
+  around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestStoreDBOpts) $
+    describe "Ntf server CLI" $ do
+      it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
+      it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
+#endif
   describe "XFTP server CLI" $ do
     it "should initialize, start and delete the server (no store log)" $ xftpServerTest False
     it "should initialize, start and delete the server (with store log)" $ xftpServerTest True
@@ -177,14 +193,21 @@ smpServerTestStatic = do
       runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False
     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)
+createNtfSchema :: PSQL.ConnectInfo -> DBOpts -> IO ()
+createNtfSchema connInfo DBOpts {schema} = do
+  db <- PSQL.connect connInfo
+  void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
+  PSQL.close db
+
 ntfServerTest :: Bool -> IO ()
 ntfServerTest storeLog = do
-  capture_ (withArgs (["init"] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
+  capture_ (withArgs (["init", "--database=" <> B.unpack ntfTestServerDBConnstr] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
     >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
   Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini"
   lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
@@ -195,10 +218,11 @@ ntfServerTest storeLog = do
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
   r `shouldContain` ["SMP notifications server v" <> simplexMQVersion]
   r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
-  r `shouldContain` ["Serving SMP protocol on port 443 (TLS)..."]
+  r `shouldContain` ["Serving NTF protocol on port 443 (TLS)..."]
   capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
     >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
+#endif
 
 xftpServerTest :: Bool -> IO ()
 xftpServerTest storeLog = do

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
@@ -392,7 +393,7 @@ testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
     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)
+    let serverCertKey = CertChainPubKey (X.CertificateChain [serverCert, ca]) (C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
     pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
   _ -> pure Nothing
 

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
@@ -256,7 +257,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 +267,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 +342,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

tests/CoreTests/StoreLogTests.hs

@@ -29,7 +29,8 @@ 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 Test.Hspec hiding (fit, it)
+import Util
 
 testPublicAuthKey :: C.APublicAuthKey
 testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
@@ -81,19 +82,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],

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
@@ -200,7 +202,7 @@ dummyRQ userId server connId rcvId =
       queueMode = Just QMMessaging,
       shortLink = 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

@@ -28,12 +28,15 @@ import qualified Data.ByteString.Char8 as B
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
+import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
-import SMPClient (prevRange, serverBracket)
+import SMPClient (defaultStartOptions, ntfTestPort, prevRange, serverBracket)
+import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
@@ -45,13 +48,14 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 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
@@ -60,12 +64,6 @@ import UnliftIO.STM
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
-ntfTestPort :: ServiceName
-ntfTestPort = "6001"
-
-ntfTestPort2 :: ServiceName
-ntfTestPort2 = "6002"
-
 apnsTestPort :: ServiceName
 apnsTestPort = "6010"
 
@@ -75,9 +73,49 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 ntfTestStoreLogFile :: FilePath
 ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
+ntfTestStoreLogFile2 :: FilePath
+ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2"
+
 ntfTestStoreLastNtfsFile :: FilePath
 ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log"
 
+ntfTestPrometheusMetricsFile :: FilePath
+ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt"
+
+ntfTestStoreDBOpts :: DBOpts
+ntfTestStoreDBOpts =
+  DBOpts
+    { connstr = ntfTestServerDBConnstr,
+      schema = "ntf_server",
+      poolSize = 3,
+      createSchema = True
+    }
+
+ntfTestStoreDBOpts2 :: DBOpts
+ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = "smp_server2"}
+
+ntfTestServerDBConnstr :: ByteString
+ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db"
+
+ntfTestServerDBConnectInfo :: ConnectInfo
+ntfTestServerDBConnectInfo =
+  defaultConnectInfo
+    { connectUser = "ntf_test_server_user",
+      connectDatabase = "ntf_test_server_db"
+    }
+
+ntfTestDBCfg :: PostgresStoreCfg
+ntfTestDBCfg =
+  PostgresStoreCfg
+    { dbOpts = ntfTestStoreDBOpts,
+      dbStoreLogPath = Just ntfTestStoreLogFile,
+      confirmMigrations = MCYesUp,
+      deletedTTL = 86400
+    }
+
+ntfTestDBCfg2 :: PostgresStoreCfg
+ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2}
+
 testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
@@ -96,7 +134,6 @@ ntfServerCfg =
       subIdBytes = 24,
       regCodeBytes = 32,
       clientQSize = 2,
-      subQSize = 2,
       pushQSize = 2,
       smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
       apnsConfig =
@@ -106,21 +143,24 @@ ntfServerCfg =
           },
       subsBatchSize = 900,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
-      storeLogFile = Nothing,
-      storeLastNtfsFile = Nothing,
+      dbStoreConfig = ntfTestDBCfg,
       ntfCredentials =
         ServerCredentials
           { caCertificateFile = Just "tests/fixtures/ca.crt",
             privateKeyFile = "tests/fixtures/server.key",
             certificateFile = "tests/fixtures/server.crt"
           },
+      periodicNtfsInterval = 1,
       -- stats config
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/ntf-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
+      prometheusInterval = Nothing,
+      prometheusMetricsFile = ntfTestPrometheusMetricsFile,
       ntfServerVRange = supportedServerNTFVRange,
-      transportConfig = defaultTransportServerConfig
+      transportConfig = defaultTransportServerConfig,
+      startOptions = defaultStartOptions
     }
 
 ntfServerCfgVPrev :: NtfServerConfig
@@ -134,11 +174,9 @@ ntfServerCfgVPrev =
     smpCfg' = smpCfg smpAgentCfg'
     serverVRange' = serverVRange smpCfg'
 
-withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
-withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, storeLastNtfsFile = Just ntfTestStoreLastNtfsFile, transports = [(ntfTestPort, t, False)]}
-
-withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]}
+withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
+withNtfServerThreadOn t port' dbStoreConfig =
+  withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
 
 withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a
 withNtfServerCfg cfg@NtfServerConfig {transports} =
@@ -149,11 +187,11 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
         (\started -> runNtfServerBlocking started cfg)
         (pure ())
 
-withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => IO a) -> IO a
-withNtfServerOn t port' = withNtfServerThreadOn t port' . const
+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 t = withNtfServerOn t ntfTestPort
+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
 runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
@@ -161,7 +199,7 @@ runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 ntfServerTest ::
   forall c smp.
   (Transport c, Encoding smp) =>
-  TProxy c ->
+  TProxy c 'TServer ->
   (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
   IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
 ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
@@ -175,7 +213,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
       [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet 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

tests/NtfServerTests.hs

@@ -43,16 +43,18 @@ import Simplex.Messaging.Notifications.Transport (THandleNTF)
 import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
 import Simplex.Messaging.Transport
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.STM
+import Util
 
-ntfServerTests :: ATransport -> Spec
+ntfServerTests :: ASrvTransport -> Spec
 ntfServerTests 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
 
-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
@@ -95,7 +97,7 @@ v .-> key =
   let J.Object o = v
    in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
 
-testNotificationSubscription :: ATransport -> CreateQueueFunc -> Spec
+testNotificationSubscription :: ASrvTransport -> CreateQueueFunc -> Spec
 testNotificationSubscription (ATransport t) createQueue =
   it "should create notification subscription and notify when message is received" $ do
     g <- C.newRandom
@@ -113,9 +115,20 @@ testNotificationSubscription (ATransport t) createQueue =
           APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
             getMockNotification apns tkn
           let dhSecret = C.dh' ntfDh dhPriv
-              Right verification = ntfData .-> "verification"
-              Right nonce = C.cbNonce <$> ntfData .-> "nonce"
-              Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
+              decryptCode nd =
+                let Right verification = nd .-> "verification"
+                    Right nonce = C.cbNonce <$> nd .-> "nonce"
+                    Right pt = C.cbDecrypt dhSecret nonce verification
+                 in NtfRegCode pt
+          let code = decryptCode ntfData
+          -- test repeated request - should return the same token ID
+          RespNtf "1a" NoEntity (NRTknId tId1 ntfDh1) <- signSendRecvNtf nh tknKey ("1a", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
+          tId1 `shouldBe` tId
+          ntfDh1 `shouldBe` ntfDh
+          APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData1}} <-
+            getMockNotification apns tkn
+          let code1 = decryptCode ntfData1
+          code `shouldBe` code1
           RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
           RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
           -- ntf server subscribes to queue notifications
@@ -167,6 +180,38 @@ testNotificationSubscription (ATransport t) createQueue =
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId
 
+testRetriedNtfSubscription :: ASrvTransport -> Spec
+testRetriedNtfSubscription (ATransport t) =
+  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 ->
+        ntfTest t $ \nh -> do
+          ((_sId, _rId, _rKey, _rcvDhSecret), nId, _rcvNtfDhSecret) <- createNtfQueueNKEY h sPub nPub
+          (tknKey, _dhSecret, tId, regCode) <- registerToken nh apns "abcd"
+          let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
+              q = SMPQueueNtf srv nId
+          -- fails creating subscription until token is verified
+          RespNtf "2" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("2", NoEntity, SNEW $ NewNtfSub tId q nKey)
+          -- verify token
+          RespNtf "3" tId1 NROk <- signSendRecvNtf nh tknKey ("3", tId, TVFY regCode)
+          tId1 `shouldBe` tId
+          -- create subscription
+          RespNtf "4" NoEntity (NRSubId subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey)
+          -- allow retry
+          RespNtf "4a" NoEntity (NRSubId subId') <- signSendRecvNtf nh tknKey ("4a", NoEntity, SNEW $ NewNtfSub tId q nKey)
+          subId' `shouldBe` subId
+          -- fail with another key
+          (_nPub, nKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+          RespNtf "5" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("5", NoEntity, SNEW $ NewNtfSub tId q nKey')
+          -- fail with another token
+          (tknKey', _dhSecret, tId', regCode') <- registerToken nh apns "efgh"
+          RespNtf "6" _ NROk <- signSendRecvNtf nh tknKey' ("6", tId', TVFY regCode')
+          RespNtf "7" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey' ("7", NoEntity, SNEW $ NewNtfSub tId' q nKey)
+          pure ()
+
 type CreateQueueFunc =
   forall c.
   Transport c =>
@@ -185,6 +230,24 @@ createNtfQueueNKEY h sPub nPub = do
   let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
   pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret)
 
+registerToken :: Transport c => THandleNTF c 'TClient -> APNSMockServer -> ByteString -> IO (C.APrivateAuthKey, C.DhSecretX25519, NtfEntityId, NtfRegCode)
+registerToken nh apns token = do
+  g <- C.newRandom
+  (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+  let tkn = DeviceToken PPApnsTest token
+  RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
+  APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
+    getMockNotification apns tkn
+  let dhSecret = C.dh' ntfDh dhPriv
+      decryptCode nd =
+        let Right verification = nd .-> "verification"
+            Right nonce = C.cbNonce <$> nd .-> "nonce"
+            Right pt = C.cbDecrypt dhSecret nonce verification
+         in NtfRegCode pt
+  let code = decryptCode ntfData
+  pure (tknKey, dhSecret, tId, code)
+
 -- TODO [notifications]
 -- createNtfQueueNEW :: CreateQueueFunc
 -- createNtfQueueNEW h sPub nPub = do

tests/PostgresSchemaDump.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module PostgresSchemaDump (postgresSchemaDumpTest) where
+
+import Control.Concurrent (threadDelay)
+import Control.DeepSeq
+import Control.Monad (unless, void)
+import qualified Data.ByteString.Char8 as B
+import Data.List (dropWhileEnd)
+import Data.Maybe (fromJust, isJust)
+import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
+import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Util (ifM, whenM)
+import System.Directory (doesFileExist, removeFile)
+import System.Environment (lookupEnv)
+import System.Process (readCreateProcess, shell)
+import Test.Hspec hiding (fit, it)
+import Util
+
+testSchemaPath :: FilePath
+testSchemaPath = "tests/tmp/test_schema.sql"
+
+postgresSchemaDumpTest :: [Migration] -> [String] -> DBOpts -> FilePath -> Spec
+postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBOpts {connstr, schema = testDBSchema} srcSchemaPath = do
+  it "verify and overwrite schema dump" testVerifySchemaDump
+  it "verify schema down migrations" testSchemaMigrations
+  where
+    testVerifySchemaDump = do
+      savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "")
+      savedSchema `deepseq` pure ()
+      void $ createDBStore testDBOpts migrations MCConsole
+      getSchema srcSchemaPath `shouldReturn` savedSchema
+
+    testSchemaMigrations = do
+      let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations
+      Right st <- createDBStore testDBOpts noDownMigrations MCError
+      mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations
+      closeDBStore st
+      whenM (doesFileExist testSchemaPath) $ removeFile testSchemaPath
+      where
+        testDownMigration st m = do
+          putStrLn $ "down migration " <> name m
+          let downMigr = fromJust $ toDownMigration m
+          schema <- getSchema testSchemaPath
+          Migrations.run st $ MTRUp [m]
+          schema' <- getSchema testSchemaPath
+          schema' `shouldNotBe` schema
+          Migrations.run st $ MTRDown [downMigr]
+          unless (name m `elem` skipComparisonForDownMigrations) $ do
+            schema'' <- getSchema testSchemaPath
+            schema'' `shouldBe` schema
+          Migrations.run st $ MTRUp [m]
+          schema''' <- getSchema testSchemaPath
+          schema''' `shouldBe` schema'
+
+    getSchema :: FilePath -> IO String
+    getSchema schemaPath = do
+      ci <- (Just "true" ==) <$> lookupEnv "CI"
+      let cmd =
+            ("pg_dump " <> B.unpack connstr <> " --schema " <> B.unpack testDBSchema)
+              <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > "
+              <> schemaPath
+      void $ readCreateProcess (shell cmd) ""
+      threadDelay 20000
+      let sed = (if ci then "sed -i" else "sed -i ''")
+      void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) ""
+      sch <- readFile schemaPath
+      sch `deepseq` pure sch

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

tests/SMPAgentClient.hs

@@ -15,8 +15,7 @@ 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 NtfClient (ntfTestPort)
-import SMPClient (proxyVRangeV8, testPort)
+import SMPClient (proxyVRangeV8, ntfTestPort, testPort)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
@@ -65,7 +64,8 @@ initAgentServers =
     { smp = userServers [testSMPServer],
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
-      netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
+      netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000},
+      presetDomains = []
     }
 
 initAgentServers2 :: InitialAgentServers

tests/SMPClient.hs

@@ -37,7 +37,7 @@ import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
 import System.Environment (lookupEnv)
 import System.Info (os)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar)
@@ -45,7 +45,12 @@ import UnliftIO.Timeout (timeout)
 import Util
 
 #if defined(dbServerPostgres)
-import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
+import Database.PostgreSQL.Simple (defaultConnectInfo)
+#endif
+
+#if defined(dbPostgres) || defined(dbServerPostgres)
+import Database.PostgreSQL.Simple (ConnectInfo (..))
+import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser)
 #endif
 
 testHost :: NonEmpty TransportHost
@@ -60,6 +65,12 @@ testPort = "5001"
 testPort2 :: ServiceName
 testPort2 = "5002"
 
+ntfTestPort :: ServiceName
+ntfTestPort = "6001"
+
+ntfTestPort2 :: ServiceName
+ntfTestPort2 = "6002"
+
 testKeyHash :: C.KeyHash
 testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 
@@ -70,7 +81,7 @@ testStoreLogFile2 :: FilePath
 testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
 
 testStoreDBOpts :: DBOpts
-testStoreDBOpts = 
+testStoreDBOpts =
   DBOpts
     { connstr = testServerDBConnstr,
       schema = "smp_server",
@@ -164,7 +175,7 @@ journalCfg :: ServerConfig -> FilePath -> FilePath -> ServerConfig
 journalCfg cfg' storeLogFile storeMsgsPath = cfg' {serverStoreCfg = ASSCfg SQSMemory SMSJournal SSCMemoryJournal {storeLogFile, storeMsgsPath}}
 
 journalCfgDB :: ServerConfig -> DBOpts -> FilePath -> ServerConfig
-journalCfgDB cfg' dbOpts storeMsgsPath' = 
+journalCfgDB cfg' dbOpts storeMsgsPath' =
   let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400}
    in cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath'}}
 
@@ -179,7 +190,7 @@ cfgMS msType =
       maxJournalStateLines = 2,
       queueIdBytes = 24,
       msgIdBytes = 24,
-      serverStoreCfg = serverStoreConfig msType,
+      serverStoreCfg = testServerStoreConfig msType,
       storeNtfsFile = Nothing,
       allowNewQueues = True,
       newQueueBasicAuth = Nothing,
@@ -212,11 +223,14 @@ cfgMS msType =
       allowSMPProxy = False,
       serverClientConcurrency = 2,
       information = Nothing,
-      startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp}
+      startOptions = defaultStartOptions
     }
 
-serverStoreConfig :: AStoreType -> AServerStoreCfg
-serverStoreConfig = serverStoreConfig_ False
+defaultStartOptions :: StartOptions
+defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = testLogLevel, skipWarnings = False, confirmMigrations = MCYesUp}
+
+testServerStoreConfig :: AStoreType -> AServerStoreCfg
+testServerStoreConfig = serverStoreConfig_ False
 
 serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg
 serverStoreConfig_ useDbStoreLog = \case
@@ -267,20 +281,20 @@ proxyCfgJ2QS = \case
 proxyVRangeV8 :: VersionRangeSMP
 proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion
 
-withSmpServerStoreMsgLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
+withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOn (t, msType) =
   withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerStoreLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
+withSmpServerStoreLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
+withSmpServerConfigOn :: HasCallStack => ASrvTransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerConfigOn t cfg' port' =
   serverBracket
     (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
     (threadDelay 10000)
 
-withSmpServerThreadOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
+withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType)
 
 serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a
@@ -301,19 +315,19 @@ serverBracket process afterProcess f = do
         Nothing -> error $ "server did not " <> s
         _ -> pure ()
 
-withSmpServerOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> IO a -> IO a
+withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
 withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const
 
-withSmpServer :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
+withSmpServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
 withSmpServer ps = withSmpServerOn ps testPort
 
-withSmpServerProxy :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
+withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
 withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const
 
-withSmpServers2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
+withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
 withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const
 
-withSmpServersProxy2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
+withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
 withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const
 
 runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
@@ -332,7 +346,7 @@ runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c
 smpServerTest ::
   forall c smp.
   (Transport c, Encoding smp) =>
-  TProxy c ->
+  TProxy c 'TServer ->
   (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
   IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
 smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h
@@ -346,33 +360,36 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >
       [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
-smpTest :: (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest _ msType test' = runSmpTest msType test' `shouldReturn` ()
 
+smpTest' :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest' = (`smpTest` ASType SQSMemory SMSJournal)
+
 smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
 smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()
 
-smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest2' = (`smpTest2` ASType SQSMemory SMSJournal)
 
-smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t
 
-smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
   where
     _test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest3 _ msType test' = smpTestN msType 3 _test
   where
     _test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
 
-smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
+smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
 smpTest4 _ msType test' = smpTestN msType 4 _test
   where
     _test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
@@ -381,3 +398,11 @@ smpTest4 _ msType test' = smpTestN msType 4 _test
 
 unexpected :: (HasCallStack, Show a) => a -> Expectation
 unexpected r = expectationFailure $ "unexpected response " <> show r
+
+#if defined(dbPostgres) || defined(dbServerPostgres)
+postgressBracket :: ConnectInfo -> IO a -> IO a
+postgressBracket connInfo =
+  E.bracket_
+    (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo)
+    (dropDatabaseAndUser connInfo)
+#endif

tests/SMPProxyTests.hs

@@ -45,7 +45,7 @@ import Simplex.Messaging.Util (bshow, tshow)
 import Simplex.Messaging.Version (mkVersionRange)
 import System.FilePath (splitExtensions)
 import System.Random (randomRIO)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO
 import Util
 #if defined(dbPostgres)
@@ -167,12 +167,12 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
   g <- C.newRandom
   -- set up proxy
   ts <- getCurrentTime
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} Nothing ts (\_ -> pure ())
+  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- set up relay
   msgQ <- newTBQueueIO 1024
-  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ())
+  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} [] (Just msgQ) ts (\_ -> pure ())
   rc <- either (fail . show) pure rc'
   -- prepare receiving queue
   (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
@@ -210,7 +210,7 @@ proxyConnectDeadRelay n d proxyServ = do
   g <- C.newRandom
   -- set up proxy
   ts <- getCurrentTime
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ())
+  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- get proxy session

tests/ServerTests.hs

@@ -17,7 +17,7 @@ module ServerTests where
 
 import Control.Concurrent (ThreadId, killThread, threadDelay)
 import Control.Concurrent.STM
-import Control.Exception (SomeException, try, throwIO)
+import Control.Exception (SomeException, throwIO, try)
 import Control.Monad
 import Control.Monad.IO.Class
 import CoreTests.MsgStoreTests (testJournalStoreCfg)
@@ -39,7 +39,7 @@ import Simplex.Messaging.Server (exportMessages)
 import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..))
-import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
+import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..), newMsgStore)
 import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
 import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
 import Simplex.Messaging.Transport
@@ -50,10 +50,10 @@ import System.IO (IOMode (..), withFile)
 import System.TimeIt (timeItT)
 import System.Timeout
 import Test.HUnit
-import Test.Hspec
-import Util (removeFileIfExists)
+import Test.Hspec hiding (fit, it)
+import Util
 
-serverTests :: SpecWith (ATransport, AStoreType)
+serverTests :: SpecWith (ASrvTransport, AStoreType)
 serverTests = do
   describe "SMP queues" $ do
     describe "NEW and KEY commands, SEND messages" testCreateSecure
@@ -147,7 +147,7 @@ decryptMsgV3 dhShared nonce body =
     Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota"
     Left e -> Left e
 
-testCreateSecure :: SpecWith (ATransport, AStoreType)
+testCreateSecure :: SpecWith (ASrvTransport, AStoreType)
 testCreateSecure =
   it "should create (NEW) and secure (KEY) queue" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \r s -> do
@@ -212,7 +212,7 @@ testCreateSecure =
       Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
       pure ()
 
-testCreateSndSecure :: SpecWith (ATransport, AStoreType)
+testCreateSndSecure :: SpecWith (ASrvTransport, AStoreType)
 testCreateSndSecure =
   it "should create (NEW) and secure (SKEY) queue by sender" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \r s -> do
@@ -259,7 +259,7 @@ testCreateSndSecure =
       Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
       pure ()
 
-testSndSecureProhibited :: SpecWith (ATransport, AStoreType)
+testSndSecureProhibited :: SpecWith (ASrvTransport, AStoreType)
 testSndSecureProhibited =
   it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \r s -> do
@@ -274,7 +274,7 @@ testSndSecureProhibited =
       (sId2, sId) #== "secures queue, same queue ID in response"
       (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command"
 
-testCreateUpdateKeys :: SpecWith (ATransport, AStoreType)
+testCreateUpdateKeys :: SpecWith (ASrvTransport, AStoreType)
 testCreateUpdateKeys =
   it "should create (NEW) and updated recipient keys (RKEY)" $ \(ATransport t, msType) ->
     smpTest t msType $ \h -> do
@@ -306,7 +306,7 @@ testCreateUpdateKeys =
       Resp "11" _ (INFO _) <- signSendRecv h rKey' ("11", rId, QUE)
       pure ()
 
-testCreateDelete :: SpecWith (ATransport, AStoreType)
+testCreateDelete :: SpecWith (ASrvTransport, AStoreType)
 testCreateDelete =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \rh sh -> do
@@ -377,7 +377,7 @@ testCreateDelete =
       Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB)
       (err10, ERR AUTH) #== "rejects SUB when deleted"
 
-stressTest :: SpecWith (ATransport, AStoreType)
+stressTest :: SpecWith (ASrvTransport, AStoreType)
 stressTest =
   it "should create many queues, disconnect and re-connect" $ \(ATransport t, msType) ->
     smpTest3 t msType $ \h1 h2 h3 -> do
@@ -395,9 +395,9 @@ stressTest =
       closeConnection $ connection h2
       subscribeQueues h3
 
-testAllowNewQueues :: SpecWith (ATransport, AStoreType)
+testAllowNewQueues :: SpecWith (ASrvTransport, AStoreType)
 testAllowNewQueues =
-  it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c), msType) ->
+  it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c 'TServer), msType) ->
     withSmpServerConfigOn (ATransport t) (cfgMS msType) {allowNewQueues = False} testPort $ \_ ->
       testSMPClient @c $ \h -> do
         g <- C.newRandom
@@ -406,7 +406,7 @@ testAllowNewQueues =
         Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
         pure ()
 
-testDuplex :: SpecWith (ATransport, AStoreType)
+testDuplex :: SpecWith (ASrvTransport, AStoreType)
 testDuplex =
   it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \alice bob -> do
@@ -461,7 +461,7 @@ testDuplex =
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
       (bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
 
-testSwitchSub :: SpecWith (ATransport, AStoreType)
+testSwitchSub :: SpecWith (ASrvTransport, AStoreType)
 testSwitchSub =
   it "should create simplex connections and switch subscription to another TCP connection" $ \(ATransport t, msType) ->
     smpTest3 t msType $ \rh1 rh2 sh -> do
@@ -506,9 +506,9 @@ testSwitchSub =
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
 
-testGetCommand :: SpecWith (ATransport, AStoreType)
+testGetCommand :: SpecWith (ASrvTransport, AStoreType)
 testGetCommand =
-  it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c), msType) -> do
+  it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     smpTest t msType $ \sh -> do
@@ -525,7 +525,7 @@ testGetCommand =
         Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET)
         pure ()
 
-testGetSubCommands :: SpecWith (ATransport, AStoreType)
+testGetSubCommands :: SpecWith (ASrvTransport, AStoreType)
 testGetSubCommands =
   it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ \(ATransport t, msType) -> do
     g <- C.newRandom
@@ -575,9 +575,9 @@ testGetSubCommands =
       Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
       pure ()
 
-testExceedQueueQuota :: SpecWith (ATransport, AStoreType)
+testExceedQueueQuota :: SpecWith (ASrvTransport, AStoreType)
 testExceedQueueQuota =
-  it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c), msType) -> do
+  it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     withSmpServerConfigOn (ATransport t) (cfgMS msType) {msgQueueQuota = 2} testPort $ \_ ->
       testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do
         g <- C.newRandom
@@ -602,7 +602,7 @@ testExceedQueueQuota =
         Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
         pure ()
 
-testWithStoreLog :: SpecWith (ATransport, AStoreType)
+testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
 testWithStoreLog =
   it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do
     g <- C.newRandom
@@ -678,16 +678,16 @@ testWithStoreLog =
     logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6)
     removeFile testStoreLogFile
   where
-    runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
+    runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
       killThread server
 
-    runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
+    runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
 serverStoreLogCfg :: AStoreType -> (ServerConfig, Bool)
-serverStoreLogCfg msType = 
+serverStoreLogCfg msType =
   let serverStoreCfg = serverStoreConfig_ True msType
       cfg' = (cfgMS msType) {serverStoreCfg, storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
       compacting = case msType of
@@ -705,7 +705,7 @@ logSize f = go (10 :: Int)
           | n > 0 -> threadDelay 100000 >> go (n - 1)
           | otherwise -> throwIO e
 
-testRestoreMessages :: SpecWith (ATransport, AStoreType)
+testRestoreMessages :: SpecWith (ASrvTransport, AStoreType)
 testRestoreMessages =
   it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
     removeFileIfExists testStoreLogFile
@@ -783,12 +783,12 @@ testRestoreMessages =
     whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
     removeFile testServerStatsBackupFile
   where
-    runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
+    runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
       killThread server
 
-    runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
+    runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
 checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
@@ -807,7 +807,7 @@ checkStats s qs sent received = do
   IS.toList _week `shouldBe` map (hash . unEntityId) qs
   IS.toList _month `shouldBe` map (hash . unEntityId) qs
 
-testRestoreExpireMessages :: SpecWith (ATransport, AStoreType)
+testRestoreExpireMessages :: SpecWith (ASrvTransport, AStoreType)
 testRestoreExpireMessages =
   it "should store messages on exit and restore on start (old / v2)" $ \(at@(ATransport t), msType) -> do
     g <- C.newRandom
@@ -869,15 +869,15 @@ testRestoreExpireMessages =
           removeFileIfExists testStoreMsgsFile
           exportMessages False ms testStoreMsgsFile False
           closeMsgStore ms
-    runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
+    runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
       killThread server
 
-    runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
+    runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
-testPrometheusMetrics :: SpecWith (ATransport, AStoreType)
+testPrometheusMetrics :: SpecWith (ASrvTransport, AStoreType)
 testPrometheusMetrics =
   it "should save Prometheus metrics" $ \(at, msType) -> do
     let cfg' = (cfgMS msType) {prometheusInterval = Just 1}
@@ -895,7 +895,7 @@ createAndSecureQueue h sPub = do
   (rId', rId) #== "same queue ID"
   pure (sId, rId, rKey, dhShared)
 
-testTiming :: SpecWith (ATransport, AStoreType)
+testTiming :: SpecWith (ASrvTransport, AStoreType)
 testTiming =
   describe "should have similar time for auth error, whether queue exists or not, for all key types" $
     forM_ timingTests $ \tst ->
@@ -918,7 +918,9 @@ testTiming =
         (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
       ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.30 -- normally the difference between "no queue" and "wrong key" is less than 5%
+    similarTime t1 t2
+      | t1 <= t2 = abs (1 - t1 / t2) < 0.35 -- normally the difference between "no queue" and "wrong key" is less than 5%
+      | otherwise = similarTime t2 t1
     testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
     testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
       g <- C.newRandom
@@ -965,7 +967,7 @@ testTiming =
             ]
           ok `shouldBe` True
 
-testMessageNotifications :: SpecWith (ATransport, AStoreType)
+testMessageNotifications :: SpecWith (ASrvTransport, AStoreType)
 testMessageNotifications =
   it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do
     g <- C.newRandom
@@ -1005,9 +1007,9 @@ testMessageNotifications =
         Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
 
-testMsgExpireOnSend :: SpecWith (ATransport, AStoreType)
+testMsgExpireOnSend :: SpecWith (ASrvTransport, AStoreType)
 testMsgExpireOnSend =
-  it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c), msType) -> do
+  it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
@@ -1025,10 +1027,10 @@ testMsgExpireOnSend =
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 
-testMsgExpireOnInterval :: SpecWith (ATransport, AStoreType)
+testMsgExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
 testMsgExpireOnInterval =
   -- fails on ubuntu
-  xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> do
+  xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
@@ -1045,9 +1047,9 @@ testMsgExpireOnInterval =
             Nothing -> return ()
             Just _ -> error "nothing should be delivered"
 
-testMsgNOTExpireOnInterval :: SpecWith (ATransport, AStoreType)
+testMsgNOTExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
 testMsgNOTExpireOnInterval =
-  it "should block and unblock message queues" $ \(ATransport (t :: TProxy c), msType) -> do
+  it "should block and unblock message queues" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
@@ -1064,10 +1066,10 @@ testMsgNOTExpireOnInterval =
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 
-testBlockMessageQueue :: SpecWith (ATransport, AStoreType)
+testBlockMessageQueue :: SpecWith (ASrvTransport, AStoreType)
 testBlockMessageQueue =
   -- TODO [postgres]
-  xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c), _) -> do
+  xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c 'TServer), _) -> do
     g <- C.newRandom
     (rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
@@ -1084,15 +1086,15 @@ testBlockMessageQueue =
       Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
       (sId2, sId) #== "same queue ID in response"
   where
-    runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
+    runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
     runTest _ test' server = do
       a <- testSMPClient test'
       killThread server
       pure a
 
-testInvQueueLinkData :: SpecWith (ATransport, AStoreType)
-testInvQueueLinkData = 
-  it "create and access queue short link data for 1-time invitation"  $ \(ATransport t, msType) ->
+testInvQueueLinkData :: SpecWith (ASrvTransport, AStoreType)
+testInvQueueLinkData =
+  it "create and access queue short link data for 1-time invitation" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \r s -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1111,6 +1113,10 @@ testInvQueueLinkData =
       -- can't read link data with LGET
       Resp "2" lnkId' (ERR AUTH) <- sendRecv s ("", "2", lnkId, LGET)
       lnkId' `shouldBe` lnkId
+      -- can update link data before it is secured
+      let newLD = (EncDataBytes "fixed data", EncDataBytes "updated user data")
+      Resp "2a" rId' OK <- signSendRecv r rKey ("2a", rId, LSET lnkId newLD)
+      rId' `shouldBe` rId
 
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
 
@@ -1126,7 +1132,7 @@ testInvQueueLinkData =
       Resp "5" lnkId2 (LNK sId2 ld') <- signSendRecv s sKey ("5", lnkId, LKEY sPub)
       (lnkId2, lnkId) #== "secures queue and returns link data, same link ID in response"
       (sId2, sId) #== "same sender ID in response"
-      (ld', ld) #== "returns stored data"
+      (ld', newLD) #== "returns updated stored data"
 
       (sPub', sKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       Resp "6" _ err4 <- signSendRecv s sKey' ("6", lnkId, LKEY sPub')
@@ -1134,18 +1140,17 @@ testInvQueueLinkData =
 
       Resp "7" _ (LNK sId3 ld2) <- signSendRecv s sKey ("7", lnkId, LKEY sPub)
       sId3 `shouldBe` sId
-      ld2 `shouldBe` ld
+      ld2 `shouldBe` newLD
 
-      let newLD = (EncDataBytes "fixed data", EncDataBytes "updated user data")
-      Resp "8" rId' (ERR AUTH) <- signSendRecv r rKey ("8", rId, LSET lnkId newLD)
-      rId' `shouldBe` rId
-
-      Resp "9" rId2 (ERR AUTH) <- signSendRecv r rKey ("9", rId, LDEL)
+      Resp "8" rId2 (ERR AUTH) <- signSendRecv r rKey ("8", rId, LSET lnkId newLD)
       rId2 `shouldBe` rId
 
-testContactQueueLinkData :: SpecWith (ATransport, AStoreType)
-testContactQueueLinkData = 
-  it "create and access queue short link data for contact address"  $ \(ATransport t, msType) ->
+      Resp "9" rId3 OK <- signSendRecv r rKey ("9", rId, LDEL)
+      rId3 `shouldBe` rId
+
+testContactQueueLinkData :: SpecWith (ASrvTransport, AStoreType)
+testContactQueueLinkData =
+  it "create and access queue short link data for contact address" $ \(ATransport t, msType) ->
     smpTest2 t msType $ \r s -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1222,7 +1227,7 @@ instance Eq C.ASignature where
     Just Refl -> s == s'
     _ -> False
 
-serverSyntaxTests :: ATransport -> Spec
+serverSyntaxTests :: ASrvTransport -> Spec
 serverSyntaxTests (ATransport t) = do
   it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
   describe "NEW" $ do

tests/ServerTests/SchemaDump.hs

@@ -1,98 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module ServerTests.SchemaDump where
-
-import Control.Concurrent (threadDelay)
-import Control.DeepSeq
-import Control.Monad (unless, void)
-import qualified Data.ByteString.Char8 as B
-import Data.List (dropWhileEnd)
-import Data.Maybe (fromJust, isJust)
-import SMPClient
-import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
-import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
-import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
-import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
-import Simplex.Messaging.Util (ifM)
-import System.Directory (doesFileExist, removeFile)
-import System.Environment (lookupEnv)
-import System.Process (readCreateProcess, readCreateProcessWithExitCode, shell)
-import Test.Hspec
-
-testDBSchema :: B.ByteString
-testDBSchema = "smp_server"
-
-serverSchemaPath :: FilePath
-serverSchemaPath = "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
-
-testSchemaPath :: FilePath
-testSchemaPath = "tests/tmp/test_server_schema.sql"
-
-testServerDBOpts :: DBOpts
-testServerDBOpts = 
-  DBOpts
-    { connstr = testServerDBConnstr,
-      schema = testDBSchema,
-      poolSize = 3,
-      createSchema = True
-    }
-
-serverSchemaDumpTest :: Spec
-serverSchemaDumpTest = do
-  it "verify and overwrite schema dump" testVerifySchemaDump
-  it "verify schema down migrations" testSchemaMigrations
-
-testVerifySchemaDump :: IO ()
-testVerifySchemaDump = do
-  savedSchema <- ifM (doesFileExist serverSchemaPath) (readFile serverSchemaPath) (pure "")
-  savedSchema `deepseq` pure ()
-  void $ createDBStore testServerDBOpts serverMigrations MCConsole
-  getSchema serverSchemaPath `shouldReturn` savedSchema
-
-testSchemaMigrations :: IO ()
-testSchemaMigrations = do
-  let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) serverMigrations
-  Right st <- createDBStore testServerDBOpts noDownMigrations MCError
-  mapM_ (testDownMigration st) $ drop (length noDownMigrations) serverMigrations
-  closeDBStore st
-  removeFile testSchemaPath
-  where
-    testDownMigration st m = do
-      putStrLn $ "down migration " <> name m
-      let downMigr = fromJust $ toDownMigration m
-      schema <- getSchema testSchemaPath
-      Migrations.run st $ MTRUp [m]
-      schema' <- getSchema testSchemaPath
-      schema' `shouldNotBe` schema
-      Migrations.run st $ MTRDown [downMigr]
-      unless (name m `elem` skipComparisonForDownMigrations) $ do
-        schema'' <- getSchema testSchemaPath
-        schema'' `shouldBe` schema
-      Migrations.run st $ MTRUp [m]
-      schema''' <- getSchema testSchemaPath
-      schema''' `shouldBe` schema'
-
-skipComparisonForDownMigrations :: [String]
-skipComparisonForDownMigrations =
-  [ -- snd_secure moves to the bottom on down migration
-    "20250320_short_links"
-  ]
-
-getSchema :: FilePath -> IO String
-getSchema schemaPath = do
-  ci <- (Just "true" ==) <$> lookupEnv "CI"
-  let cmd =
-        ("pg_dump " <> B.unpack testServerDBConnstr <> " --schema " <> B.unpack testDBSchema)
-          <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > "
-          <> schemaPath
-  (code, out, err) <- readCreateProcessWithExitCode (shell cmd) ""
-  print code
-  putStrLn $ "out: " <> out
-  putStrLn $ "err: " <> err
-  threadDelay 20000
-  let sed = (if ci then "sed -i" else "sed -i ''")
-  void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) ""
-  sch <- readFile schemaPath
-  sch `deepseq` pure sch

tests/Test.hs

@@ -21,7 +21,6 @@ import CoreTests.VersionRangeTests
 import FileDescriptionTests (fileDescriptionTests)
 import GHC.IO.Exception (IOException (..))
 import qualified GHC.IO.Exception as IOException
-import NtfServerTests (ntfServerTests)
 import RemoteControl (remoteControlTests)
 import SMPProxyTests (smpProxyTests)
 import ServerTests
@@ -31,7 +30,8 @@ import Simplex.Messaging.Transport (TLS, Transport (..))
 -- import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 import XFTPAgent
 import XFTPCLI
 import XFTPServerTests (xftpServerTests)
@@ -43,13 +43,16 @@ import AgentTests.SchemaDump (schemaDumpTest)
 #endif
 
 #if defined(dbServerPostgres)
-import SMPClient (testServerDBConnectInfo)
-import ServerTests.SchemaDump
+import NtfServerTests (ntfServerTests)
+import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts)
+import PostgresSchemaDump (postgresSchemaDumpTest)
+import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
+import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
+import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
 #endif
 
 #if defined(dbPostgres) || defined(dbServerPostgres)
-import Database.PostgreSQL.Simple (ConnectInfo (..))
-import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser)
+import SMPClient (postgressBracket)
 #endif
 
 logCfg :: LogConfig
@@ -57,7 +60,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  setLogLevel LogError -- LogInfo
+  setLogLevel testLogLevel
   withGlobalLogging logCfg $ do
     setEnv "APNS_KEY_ID" "H82WD9K9AQ"
     setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
@@ -92,10 +95,16 @@ main = do
           describe "Agent core tests" agentCoreTests
 #if defined(dbServerPostgres)
         around_ (postgressBracket testServerDBConnectInfo) $
-          describe "Server schema dump" serverSchemaDumpTest
+          describe "SMP server schema dump" $
+            postgresSchemaDumpTest
+              serverMigrations
+              [ "20250320_short_links" -- snd_secure moves to the bottom on down migration
+              ] -- skipComparisonForDownMigrations
+              testStoreDBOpts
+              "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
         aroundAll_ (postgressBracket testServerDBConnectInfo) $
           describe "SMP server via TLS, postgres+jornal message store" $
-              before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
+            before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
 #endif
         describe "SMP server via TLS, jornal message store" $ do
           describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
@@ -105,8 +114,16 @@ main = do
         -- xdescribe "SMP server via WebSockets" $ do
         --   describe "SMP syntax" $ serverSyntaxTests (transport @WS)
         --   before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests
-        describe "Notifications server" $ ntfServerTests (transport @TLS)
 #if defined(dbServerPostgres)
+        around_ (postgressBracket ntfTestServerDBConnectInfo) $
+          describe "Ntf server schema dump" $
+            postgresSchemaDumpTest
+              ntfServerMigrations
+              [] -- skipComparisonForDownMigrations
+              ntfTestStoreDBOpts
+              "src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
+        aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) $ do
+          describe "Notifications server" $ ntfServerTests (transport @TLS)
         aroundAll_ (postgressBracket testServerDBConnectInfo) $ do
           describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
           describe "SMP proxy, postgres+jornal message store" $
@@ -132,11 +149,3 @@ eventuallyRemove path retries = case retries of
       _ -> E.throwIO ioe
   where
     action = removeDirectoryRecursive path
-
-#if defined(dbPostgres) || defined(dbServerPostgres)
-postgressBracket :: ConnectInfo -> IO a -> IO a
-postgressBracket connInfo =
-  E.bracket_
-    (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo)
-    (dropDatabaseAndUser connInfo)
-#endif

tests/Util.hs

@@ -1,12 +1,22 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
 module Util where
 
+import Control.Concurrent.Async
+import Control.Exception as E
+import Control.Logger.Simple
 import Control.Monad (replicateM, when)
 import Data.Either (partitionEithers)
 import Data.List (tails)
 import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
 import System.Directory (doesFileExist, removeFile)
-import Test.Hspec
-import UnliftIO
+import System.Process (callCommand)
+import System.Timeout (timeout)
+import Test.Hspec hiding (fit, it)
+import qualified Test.Hspec as Hspec
+import Test.Hspec.Core.Spec (Example (..), Result (..), ResultStatus (..))
 
 skip :: String -> SpecWith a -> SpecWith a
 skip = before_ . pendingWith
@@ -32,3 +42,40 @@ removeFileIfExists :: FilePath -> IO ()
 removeFileIfExists filePath = do
   fileExists <- doesFileExist filePath
   when fileExists $ removeFile filePath
+
+newtype TestWrapper a = TestWrapper a
+
+-- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs"
+testLogLevel :: LogLevel
+testLogLevel = LogError
+
+instance Example a => Example (TestWrapper a) where
+  type Arg (TestWrapper a) = Arg a
+  evaluateExample (TestWrapper action) params hooks state =
+    runTest `E.catches` [E.Handler onTestFailure, E.Handler onTestException]
+    where
+      tt = 120
+      runTest =
+        timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
+          Just r -> pure r
+          Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
+      onTestFailure :: ResultStatus -> IO Result
+      onTestFailure = \case
+        Failure loc_ reason -> do
+          putStrLn $ "Test failed: location " ++ show loc_ ++ ", reason: " ++ show reason
+          retryTest
+        r -> E.throwIO r
+      onTestException :: SomeException -> IO Result
+      onTestException e = do
+        putStrLn $ "Test exception: " ++ show e
+        retryTest
+      retryTest = do
+        putStrLn "Retrying with more logs..."
+        setLogLevel LogDebug
+        runTest `finally` setLogLevel testLogLevel -- change this to match log level in Test.hs
+
+it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
+it label action = Hspec.it label (TestWrapper action)
+
+fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
+fit = fmap focus . it

tests/XFTPAgent.hs

@@ -42,9 +42,10 @@ import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Util (tshow)
 import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
 import System.FilePath ((</>))
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO
 import UnliftIO.Concurrent
+import Util
 import XFTPCLI
 import XFTPClient
 #if defined(dbPostgres)
@@ -454,7 +455,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
       pure rfd1
 
     -- prefix path should be removed after sending file
-    threadDelay 200000
+    threadDelay 500000
     doesDirectoryExist prefixPath `shouldReturn` False
     doesFileExist encPath `shouldReturn` False
 

tests/XFTPCLI.hs

@@ -9,7 +9,8 @@ import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, r
 import System.Environment (withArgs)
 import System.FilePath ((</>))
 import System.IO.Silently (capture_)
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
+import Util
 import XFTPClient (testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2)
 
 xftpCLITests :: Spec

tests/XFTPClient.hs

@@ -19,7 +19,7 @@ import Simplex.FileTransfer.Transport (supportedFileServerVRange, supportedXFTPh
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Transport.Server
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 
 xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
 xftpTest test = runXFTPTest test `shouldReturn` ()

tests/XFTPServerTests.hs

@@ -32,8 +32,9 @@ import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
-import Test.Hspec
+import Test.Hspec hiding (fit, it)
 import UnliftIO.STM
+import Util
 import XFTPClient
 
 xftpServerTests :: Spec