webpush: small fixes (#1699)

* Fix compilation for client lib

* Print VAPID fp

* Fix VAPID signature

* refactor

---------

Co-authored-by: sim <git@sgougeon.fr>

.github/workflows/build.yml

@@ -177,7 +177,7 @@ jobs:
         if: matrix.should_run == true
         shell: docker exec -t builder sh -eu {0}
         run: |
-          chmod -R 777 dist-newstyle ~/.cabal && git config --global --add safe.directory '*'
+          chmod -fR 777 ~/.cabal ./dist-newstyle || :; git config --global --add safe.directory '*'
           cabal clean
           cabal update
           cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
@@ -265,7 +265,7 @@ jobs:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
       - name: Test
-        if: matrix.should_run == true
+        if: matrix.should_run == true && matrix.arch == 'x86-64'
         timeout-minutes: 120
         shell: bash
         env:

scripts/simplexmq-reproduce-builds.sh

@@ -47,7 +47,7 @@ for os in 22.04 24.04; do
 	docker exec \
 		-t \
 		builder \
-		sh -c 'cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
+		sh -c 'git config --global --add safe.directory \*; cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
 
 	# Copy smp-server postgresql binary and prepare it
 	docker cp \
@@ -133,9 +133,6 @@ done
 
 # If everything is still okay, compute checksums file
 if [ "$bad" = 0 ]; then
-	curl -L "${repo}/archive/refs/tags/${TAG}.tar.gz" -o "$init_dir/$TAG-$repo_name/from-source/source_code.tar.gz"
-	curl -L "${repo}/archive/refs/tags/${TAG}.zip" -o "$init_dir/$TAG-$repo_name/from-source/source_code.zip"
-
 	sha256sum "$path_bin"/from-source/* | sed -e "s|$PWD/||g" -e 's|from-source/||g' -e "s|-$repo_name||g" > "$path_bin/_sha256sums"
 
 	printf 'Checksums computed - %s\n' "$path_bin/_sha256sums"

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           simplexmq
-version:        6.4.5.2
+version:        6.5.0.3
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -103,12 +103,13 @@ library
       Simplex.Messaging.Agent.Store.AgentStore
       Simplex.Messaging.Agent.Store.Common
       Simplex.Messaging.Agent.Store.DB
+      Simplex.Messaging.Agent.Store.Entity
       Simplex.Messaging.Agent.Store.Interface
       Simplex.Messaging.Agent.Store.Migrations
       Simplex.Messaging.Agent.Store.Migrations.App
       Simplex.Messaging.Agent.Store.Postgres.Options
       Simplex.Messaging.Agent.Store.Shared
-      Simplex.Messaging.Agent.TRcvQueues
+      Simplex.Messaging.Agent.TSessionSubs
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Compression
@@ -130,12 +131,13 @@ library
       Simplex.Messaging.Notifications.Types
       Simplex.Messaging.Parsers
       Simplex.Messaging.Protocol
+      Simplex.Messaging.Protocol.Types
       Simplex.Messaging.Server.Expiration
       Simplex.Messaging.Server.QueueStore.Postgres.Config
       Simplex.Messaging.Server.QueueStore.QueueInfo
       Simplex.Messaging.ServiceScheme
       Simplex.Messaging.Session
-      Simplex.Messaging.Agent.Store.Entity
+      Simplex.Messaging.SystemTime
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
@@ -163,6 +165,8 @@ library
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251009_queue_to_subscribe
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notices
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -210,6 +214,8 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251009_queue_to_subscribe
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices
   if flag(client_postgres) || flag(server_postgres)
       exposed-modules:
           Simplex.Messaging.Agent.Store.Postgres
@@ -258,7 +264,9 @@ library
               Simplex.Messaging.Notifications.Server.Env
               Simplex.Messaging.Notifications.Server.Main
               Simplex.Messaging.Notifications.Server.Prometheus
+              Simplex.Messaging.Notifications.Server.Push
               Simplex.Messaging.Notifications.Server.Push.APNS
+              Simplex.Messaging.Notifications.Server.Push.WebPush
               Simplex.Messaging.Notifications.Server.Push.APNS.Internal
               Simplex.Messaging.Notifications.Server.Stats
               Simplex.Messaging.Notifications.Server.Store
@@ -266,6 +274,7 @@ library
               Simplex.Messaging.Notifications.Server.Store.Postgres
               Simplex.Messaging.Notifications.Server.Store.Types
               Simplex.Messaging.Notifications.Server.StoreLog
+              Simplex.Messaging.Server.MsgStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres
               Simplex.Messaging.Server.QueueStore.Postgres.Migrations
   other-modules:
@@ -290,6 +299,7 @@ library
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -302,6 +312,7 @@ library
     , directory ==1.3.*
     , filepath ==1.4.*
     , hourglass ==0.2.*
+    , http-client ==0.7.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
     , iproute ==1.7.*
@@ -333,6 +344,7 @@ library
         case-insensitive ==1.2.*
       , hashable ==1.4.*
       , ini ==0.4.1
+      , http-client-tls ==0.3.6.*
       , optparse-applicative >=0.15 && <0.17
       , process ==1.6.*
       , temporary ==1.3.*
@@ -473,7 +485,7 @@ test-suite simplexmq-test
       CoreTests.RetryIntervalTests
       CoreTests.SOCKSSettings
       CoreTests.StoreLogTests
-      CoreTests.TRcvQueuesTests
+      CoreTests.TSessionSubs
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
@@ -502,6 +514,7 @@ test-suite simplexmq-test
           AgentTests.NotificationTests
           NtfClient
           NtfServerTests
+          NtfWPTests
           PostgresSchemaDump
   hs-source-dirs:
       tests

src/Simplex/FileTransfer/Server.hs

@@ -58,8 +58,9 @@ import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey
 import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
+import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
 import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
@@ -451,7 +452,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
-    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
+    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedFileTime -> M (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts =
       retryAdd n $ \sId -> runExceptT $ do
         ExceptT $ addFile st sId file ts EntityActive
@@ -579,8 +580,8 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
       liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
       liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
-getFileTime :: IO RoundedSystemTime
-getFileTime = getRoundedSystemTime fileTimePrecision
+getFileTime :: IO RoundedFileTime
+getFileTime = getRoundedSystemTime
 
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do

src/Simplex/FileTransfer/Server/Store.hs

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

src/Simplex/FileTransfer/Server/StoreLog.hs

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

src/Simplex/FileTransfer/Types.hs

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

src/Simplex/Messaging/Agent/Client.hs

@@ -48,9 +48,10 @@ module Simplex.Messaging.Agent.Client
     newRcvQueue,
     newRcvQueue_,
     subscribeQueues,
+    subscribeUserServerQueues,
+    processClientNotices,
     getQueueMessage,
     decryptSMPMessage,
-    addSubscription,
     failSubscription,
     addNewQueueSubscription,
     getSubscriptions,
@@ -99,8 +100,10 @@ module Simplex.Messaging.Agent.Client
     logSecret,
     logSecret',
     removeSubscription,
+    removeSubscriptions,
     hasActiveSubscription,
     hasPendingSubscription,
+    hasRemovedSubscription,
     hasGetLock,
     releaseGetLock,
     activeClientSession,
@@ -157,6 +160,8 @@ module Simplex.Messaging.Agent.Client
     withStoreBatch',
     unsafeWithStore,
     storeError,
+    notifySub,
+    notifySub',
     userServers,
     pickServer,
     getNextServer,
@@ -200,15 +205,17 @@ import Data.Bifunctor (bimap, first, second)
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Composition ((.:), (.:.))
+import Data.Containers.ListUtils (nubOrd)
 import Data.Either (isRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find, foldl', partition)
+import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -231,10 +238,12 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.AgentStore (getClientNotices, updateClientNotices)
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
-import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
+import Simplex.Messaging.Agent.Store.Entity
+import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
+import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -281,9 +290,10 @@ import Simplex.Messaging.Protocol
     senderCanSecure,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Session
-import Simplex.Messaging.Agent.Store.Entity
+import Simplex.Messaging.SystemTime
 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, newNtfCredsSMPVersion)
@@ -310,8 +320,6 @@ type NtfClientVar = ClientVar NtfResponse
 
 type XFTPClientVar = ClientVar FileResponse
 
-type SMPTransportSession = TransportSession SMP.BrokerMsg
-
 type NtfTransportSession = TransportSession NtfResponse
 
 type XFTPTransportSession = TransportSession FileResponse
@@ -333,12 +341,14 @@ data AgentClient = AgentClient
     xftpClients :: TMap XFTPTransportSession XFTPClientVar,
     useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
     presetDomains :: [HostName],
+    presetServers :: [SMPServer],
     userNetworkInfo :: TVar UserNetworkInfo,
     userNetworkUpdated :: TVar (Maybe UTCTime),
     subscrConns :: TVar (Set ConnId),
-    activeSubs :: TRcvQueues (SessionId, RcvQueue),
-    pendingSubs :: TRcvQueues RcvQueue,
-    removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
+    currentSubs :: TSessionSubs,
+    removedSubs :: TMap (UserId, SMPServer) (TMap SMP.RecipientId SMPClientError),
+    clientNotices :: TMap (Maybe SMPServer) (Maybe SystemSeconds),
+    clientNoticesLock :: TMVar (),
     workerSeq :: TVar Int,
     smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
     asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
@@ -428,7 +438,7 @@ getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do
 newWorker :: AgentClient -> STM Worker
 newWorker c = do
   workerId <- stateTVar (workerSeq c) $ \next -> (next, next + 1)
-  doWork <- newTMVar ()
+  doWork <- newTMVar () -- new worker is created  with "some work to do" (indicated by () in TMVar)
   action <- newTMVar Nothing
   restarts <- newTVar $ RestartCount 0 0
   pure Worker {workerId, doWork, action, restarts}
@@ -484,8 +494,8 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
   deriving (Eq, Show)
 
 -- | 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, presetDomains} currentTs agentEnv = do
+newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient
+newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomains, presetServers} currentTs notices agentEnv = do
   let cfg = config agentEnv
       qSize = tbqSize cfg
   proxySessTs <- newTVarIO =<< getCurrentTime
@@ -504,9 +514,10 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
   userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True
   userNetworkUpdated <- newTVarIO Nothing
   subscrConns <- newTVarIO S.empty
-  activeSubs <- RQ.empty
-  pendingSubs <- RQ.empty
+  currentSubs <- SS.emptyIO
   removedSubs <- TM.emptyIO
+  clientNotices <- newTVarIO notices
+  clientNoticesLock <- newTMVarIO ()
   workerSeq <- newTVarIO 0
   smpDeliveryWorkers <- TM.emptyIO
   asyncCmdWorkers <- TM.emptyIO
@@ -540,12 +551,14 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
         xftpClients,
         useNetworkConfig,
         presetDomains,
+        presetServers,
         userNetworkInfo,
         userNetworkUpdated,
         subscrConns,
-        activeSubs,
-        pendingSubs,
+        currentSubs,
         removedSubs,
+        clientNotices,
+        clientNoticesLock,
         workerSeq,
         smpDeliveryWorkers,
         asyncCmdWorkers,
@@ -700,40 +713,44 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm
       liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
         ts <- readTVarIO proxySessTs
         smp <- ExceptT $ getProtocolClient g nm tSess cfg presetDomains (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
+        atomically $ SS.setSessionId tSess (sessionId $ thParams smp) $ currentSubs c
         pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
 
 smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
-smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess@(userId, srv, qId) env v prs client = do
+smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess@(userId, srv, cId) env v prs client = do
   removeClientAndSubs >>= serverDown
   logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
   where
     -- we make active subscriptions pending only if the client for tSess was current (in the map) and active,
     -- because we can have a race condition when a new current client could have already
     -- made subscriptions active, and the old client would be processing diconnection later.
-    removeClientAndSubs :: IO ([RcvQueue], [ConnId])
+    removeClientAndSubs :: IO ([RcvQueueSub], [ConnId])
     removeClientAndSubs = atomically $ do
       removeSessVar v tSess smpClients
       ifM (readTVar active) removeSubs (pure ([], []))
       where
         sessId = sessionId $ thParams client
         removeSubs = do
-          (qs, cs) <- RQ.getDelSessQueues tSess sessId $ activeSubs c
-          RQ.batchAddQueues (pendingSubs c) qs
+          mode <- getSessionMode c
+          subs <- SS.setSubsPending mode tSess sessId $ currentSubs c
+          let qs = M.elems subs
+              cs = nubOrd $ map qConnId qs
           -- this removes proxied relays that this client created sessions to
           destSrvs <- M.keys <$> readTVar prs
-          forM_ destSrvs $ \destSrv -> TM.delete (userId, destSrv, qId) smpProxiedRelays
+          forM_ destSrvs $ \destSrv -> TM.delete (userId, destSrv, cId) smpProxiedRelays
           pure (qs, cs)
 
-    serverDown :: ([RcvQueue], [ConnId]) -> IO ()
+    serverDown :: ([RcvQueueSub], [ConnId]) -> IO ()
     serverDown (qs, conns) = whenM (readTVarIO active) $ do
-      notifySub "" $ hostEvent' DISCONNECT client
-      unless (null conns) $ notifySub "" $ DOWN srv conns
+      notifySub c $ hostEvent' DISCONNECT client
+      unless (null conns) $ notifySub c $ DOWN srv conns
       unless (null qs) $ do
-        atomically $ mapM_ (releaseGetLock c) qs
-        runReaderT (resubscribeSMPSession c tSess) env
-
-    notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> IO ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
+        releaseGetLocksIO c qs
+        mode <- getSessionModeIO c
+        let resubscribe
+              | (mode == TSMEntity) == isJust cId = resubscribeSMPSession c tSess
+              | otherwise = void $ subscribeQueues c True qs
+        runReaderT resubscribe env
 
 resubscribeSMPSession :: AgentClient -> SMPTransportSession -> AM' ()
 resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
@@ -742,7 +759,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
   where
     getWorkerVar ts =
       ifM
-        (not <$> RQ.hasSessQueues tSess (pendingSubs c))
+        (not <$> SS.hasPendingSubs tSess (currentSubs c))
         (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
         (Just <$> getSessVar workerSeq tSess smpSubWorkers ts)
     newSubWorker v = do
@@ -751,11 +768,11 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
     runSubWorker = do
       ri <- asks $ reconnectInterval . config
       withRetryForeground ri isForeground (isNetworkOnline c) $ \_ loop -> do
-        pending <- liftIO $ RQ.getSessQueues tSess $ pendingSubs c
-        forM_ (L.nonEmpty pending) $ \qs -> do
+        pending <- atomically $ SS.getPendingSubs tSess $ currentSubs c
+        unless (M.null pending) $ do
           liftIO $ waitUntilForeground c
           liftIO $ waitForUserNetwork c
-          reconnectSMPClient c tSess qs
+          handleNotify $ resubscribeSessQueues c tSess $ M.elems pending
           loop
     isForeground = (ASForeground ==) <$> readTVar (agentState c)
     cleanup :: SessionVar (Async ()) -> STM ()
@@ -764,28 +781,16 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
       -- Not waiting may result in terminated worker remaining in the map.
       whenM (isEmptyTMVar $ sessionVar v) retry
       removeSessVar v tSess smpSubWorkers
-
-reconnectSMPClient :: AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM' ()
-reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
-  cs <- readTVarIO $ RQ.getConnections $ activeSubs c
-  (rs, sessId_) <- subscribeQueues c $ L.toList qs
-  let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
-      conns = filter (`M.notMember` cs) okConns
-  unless (null conns) $ notifySub "" $ UP srv conns
-  let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
-  mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
-  forM_ (listToMaybe tempErrs) $ \(connId, e) -> do
-    when (null okConns && M.null cs && null finalErrs) . liftIO $
-      forM_ sessId_ $ \sessId -> do
-        -- We only close the client session that was used to subscribe.
-        v_ <- atomically $ ifM (activeClientSession c tSess sessId) (TM.lookupDelete tSess $ smpClients c) (pure Nothing)
-        mapM_ (closeClient_ c) v_
-    notifySub connId $ ERR e
-  where
     handleNotify :: AM' () -> AM' ()
-    handleNotify = E.handleAny $ notifySub "" . ERR . INTERNAL . show
-    notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
+    handleNotify = E.handleAny $ notifySub' c "" . ERR . INTERNAL . show
+
+notifySub' :: forall e m. (AEntityI e, MonadIO m) => AgentClient -> ConnId -> AEvent e -> m ()
+notifySub' c connId cmd = liftIO $ nonBlockingWriteTBQueue (subQ c) (B.empty, connId, AEvt (sAEntity @e) cmd)
+{-# INLINE notifySub' #-}
+
+notifySub :: MonadIO m => AgentClient -> AEvent 'AENone -> m ()
+notifySub c = notifySub' c ""
+{-# INLINE notifySub #-}
 
 getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, presetDomains} nm tSess@(_, srv, _) = do
@@ -928,8 +933,7 @@ closeAgentClient c = do
   atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
   clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
   clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
-  atomically . RQ.clear $ activeSubs c
-  atomically . RQ.clear $ pendingSubs c
+  atomically $ SS.clear $ currentSubs c
   clear subscrConns
   clear getMsgLocks
   where
@@ -1070,7 +1074,7 @@ withLogClient c nm tSess entId cmdStr action = withLogClient_ c nm tSess entId c
 
 withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
 withSMPClient c nm q cmdStr action = do
-  tSess <- mkSMPTransportSession c q
+  tSess <- mkSMPTransportSessionIO c q
   withLogClient c nm tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
 
 sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
@@ -1246,7 +1250,7 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
           SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing
           liftError (testErr TSSecureQueue) $
             case queueMode of
-              Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId sKey
+              Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId
               _ -> secureSMPQueue smp nm rpKey rcvId sKey
           liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId
         ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp
@@ -1318,7 +1322,7 @@ runNTFServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
         (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
         (dhKey, _) <- atomically $ C.generateKeyPair g
         r <- runExceptT $ do
-          let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
+          let deviceToken = APNSDeviceToken PPApnsNull "test_ntf_token"
           (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey)
           liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId
         ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf
@@ -1335,14 +1339,18 @@ getXFTPWorkPath = do
   maybe getTemporaryDirectory pure workDir
 
 mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg)
-mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionMode c
+mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionModeIO c
 {-# INLINE mkTransportSession #-}
 
 mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg
 mkTSession userId srv sessEntId mode = (userId, srv, if mode == TSMEntity then Just sessEntId else Nothing)
 {-# INLINE mkTSession #-}
 
-mkSMPTransportSession :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSessionIO :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSessionIO c q = mkSMPTSession q <$> getSessionModeIO c
+{-# INLINE mkSMPTransportSessionIO #-}
+
+mkSMPTransportSession :: SMPQueueRec q => AgentClient -> q -> STM SMPTransportSession
 mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c
 {-# INLINE mkSMPTransportSession #-}
 
@@ -1350,8 +1358,12 @@ mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSessi
 mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 {-# INLINE mkSMPTSession #-}
 
-getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
-getSessionMode = fmap sessionMode . getNetworkConfig
+getSessionModeIO :: MonadIO m => AgentClient -> m TransportSessionMode
+getSessionModeIO = fmap (sessionMode . snd) . readTVarIO . useNetworkConfig
+{-# INLINE getSessionModeIO #-}
+
+getSessionMode :: AgentClient -> STM TransportSessionMode
+getSessionMode = fmap (sessionMode . snd) . readTVar . useNetworkConfig
 {-# INLINE getSessionMode #-}
 
 newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
@@ -1405,6 +1417,8 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
             shortLink,
             clientService = ClientService DBNewEntity <$> serviceId,
             status = New,
+            enableNtfs,
+            clientNoticeId = Nothing,
             dbQueueId = DBNewEntity,
             primary = True,
             dbReplaceQueueId = Nothing,
@@ -1455,17 +1469,39 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
         newErr :: String -> AM (Maybe ShortLinkCreds)
         newErr = throwE . BROKER (B.unpack $ strEncode srv) . UNEXPECTED . ("Create queue: " <>)
 
-processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError (Maybe ServiceId) -> STM ()
-processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
-  Left e ->
-    unless (temporaryClientError e) $ do
-      incSMPServerStat c userId server connSubErrs
-      failSubscription c rq e
-  Right _serviceId -> -- TODO [certs rcv] store association with the service
-    ifM
-      (hasPendingSubscription c connId)
-      (incSMPServerStat c userId server connSubscribed >> addSubscription c sessId rq)
-      (incSMPServerStat c userId server connSubIgnored)
+processSubResults :: AgentClient -> SMPTransportSession -> SessionId -> NonEmpty (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) -> STM [(RcvQueueSub, Maybe ClientNotice)]
+processSubResults c tSess@(userId, srv, _) sessId rs = do
+  pendingSubs <- SS.getPendingSubs tSess $ currentSubs c
+  let (failed, subscribed, notices, ignored) = foldr (partitionResults pendingSubs) (M.empty, [], [], 0) rs
+  unless (M.null failed) $ do
+    incSMPServerStat' c userId srv connSubErrs $ M.size failed
+    failSubscriptions c tSess failed
+  unless (null subscribed) $ do
+    incSMPServerStat' c userId srv connSubscribed $ length subscribed
+    SS.batchAddActiveSubs tSess sessId subscribed $ currentSubs c
+  unless (ignored == 0) $ incSMPServerStat' c userId srv connSubIgnored ignored
+  pure notices
+  where
+    partitionResults ::
+      Map SMP.RecipientId RcvQueueSub ->
+      (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) ->
+      (Map SMP.RecipientId SMPClientError, [RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)], Int) ->
+      (Map SMP.RecipientId SMPClientError, [RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)], Int)
+    partitionResults pendingSubs (rq@RcvQueueSub {rcvId, clientNoticeId}, r) acc@(failed, subscribed, notices, ignored) = case r of
+      Left e -> case smpErrorClientNotice e of
+        Just notice_ -> (failed', subscribed, (rq, notice_) : notices, ignored)
+          where
+            notices' = if isJust notice_ || isJust clientNoticeId then (rq, notice_) : notices else notices
+        Nothing
+          | temporaryClientError e -> acc
+          | otherwise -> (failed', subscribed, notices, ignored)
+        where
+          failed' = M.insert rcvId e failed
+      Right _serviceId -- TODO [certs rcv] store association with the service
+        | rcvId `M.member` pendingSubs -> (failed, rq : subscribed, notices', ignored)
+        | otherwise -> (failed, subscribed, notices', ignored + 1)
+        where
+          notices' = if isJust clientNoticeId then (rq, Nothing) : notices else notices
 
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
@@ -1499,46 +1535,120 @@ serverHostError = \case
       SMP.TRANSPORT TEVersion -> True
       _ -> False
 
--- | Subscribe to queues. The list of results can have a different order.
-subscribeQueues :: AgentClient -> [RcvQueue] -> AM' ([(RcvQueue, Either AgentErrorType (Maybe ServiceId))], Maybe SessionId)
-subscribeQueues c qs = do
-  (errs, qs') <- partitionEithers <$> mapM checkQueue qs
-  atomically $ do
-    modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId qs'))
-    RQ.batchAddQueues (pendingSubs c) qs'
-  env <- ask
-  -- only "checked" queues are subscribed
-  session <- newTVarIO Nothing
-  rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c NRMBackground qs'
-  (errs <> rs,) <$> readTVarIO session
+-- | Batch by transport session and subscribe queues. The list of results can have a different order.
+subscribeQueues :: AgentClient -> Bool -> [RcvQueueSub] -> AM' [(RcvQueueSub, Either AgentErrorType (Maybe ServiceId))]
+subscribeQueues c withEvents qs = do
+  (errs, qs') <- checkQueues c qs
+  atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId qs'))
+  qss <- batchQueues mkSMPTSession qs' <$> getSessionModeIO c
+  mapM_ (addPendingSubs c) qss
+  rs <- mapConcurrently (subscribeQueues_ c withEvents) qss
+  when withEvents $ forM_ (L.nonEmpty errs) $ notifySub c . ERRS . L.map (first qConnId)
+  pure $ map (second Left) errs <> concatMap L.toList rs
+
+addPendingSubs :: AgentClient -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' ()
+addPendingSubs c (tSess, qs') = atomically $ SS.batchAddPendingSubs tSess (L.toList qs') $ currentSubs c
+
+subscribeQueues_ :: AgentClient -> Bool -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' (BatchResponses RcvQueueSub AgentErrorType (Maybe ServiceId))
+subscribeQueues_ c withEvents qs'@(tSess@(_, srv, _), _) = do
+  (rs, active) <- subscribeSessQueues_ c withEvents qs'
+  if active
+    then when (hasTempErrors rs) resubscribe $> rs
+    else do
+      logWarn "subcription batch result for replaced SMP client, resubscribing"
+      -- we use BROKER NETWORK error here instead of the original error, so it becomes temporary.
+      resubscribe $> L.map (second $ Left . toNESubscribeError) rs
+  where
+    -- treating host errors as temporary here as well
+    hasTempErrors = any (either temporaryOrHostError (const False) . snd)
+    toNESubscribeError = BROKER (B.unpack $ strEncode srv) . NETWORK . NESubscribeError . show
+    resubscribe = resubscribeSMPSession c tSess
+
+subscribeUserServerQueues :: AgentClient -> UserId -> SMPServer -> [RcvQueueSub] -> AM' [(RcvQueueSub, Either AgentErrorType (Maybe ServiceId))]
+subscribeUserServerQueues c userId srv qs = do
+  mode <- getSessionModeIO c
+  if mode == TSMEntity
+    then subscribeQueues c True qs
+    else do
+      let tSess = (userId, srv, Nothing)
+      (errs, qs_) <- checkQueues c qs
+      forM_ (L.nonEmpty errs) $ notifySub c . ERRS . L.map (first qConnId)
+      let errs' = map (second Left) errs
+      case L.nonEmpty qs_ of
+        Just qs' -> do
+          atomically $ modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId $ L.toList qs'))
+          addPendingSubs c (tSess, qs')
+          rs <- subscribeQueues_ c True (tSess, qs')
+          pure $ errs' <> L.toList rs
+        Nothing -> pure errs'
+
+-- only "checked" queues are subscribed
+checkQueues :: AgentClient -> [RcvQueueSub] -> AM' ([(RcvQueueSub, AgentErrorType)], [RcvQueueSub])
+checkQueues c = fmap partitionEithers . mapM checkQueue
   where
     checkQueue rq = do
       prohibited <- liftIO $ hasGetLock c rq
-      pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
-    subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError (Maybe ServiceId))
-    subscribeQueues_ env session smp qs' = do
-      let (userId, srv, _) = transportSession' smp
+      pure $ if prohibited then Left (rq, CMD PROHIBITED "checkQueues") else Right rq
+
+-- This function expects that all queues belong to one transport session,
+-- and that they are already added to pending subscriptions.
+resubscribeSessQueues :: AgentClient -> SMPTransportSession -> [RcvQueueSub] -> AM' ()
+resubscribeSessQueues c tSess qs = do
+  (errs, qs_) <- checkQueues c qs
+  forM_ (L.nonEmpty qs_) $ \qs' -> void $ subscribeSessQueues_ c True (tSess, qs')
+  forM_ (L.nonEmpty errs) $ notifySub c . ERRS . L.map (first qConnId)
+
+subscribeSessQueues_ :: AgentClient -> Bool -> (SMPTransportSession, NonEmpty RcvQueueSub) -> AM' (BatchResponses RcvQueueSub AgentErrorType (Maybe ServiceId), Bool)
+subscribeSessQueues_ c withEvents qs = sendClientBatch_ "SUB" False subscribe_ c NRMBackground qs
+  where
+    subscribe_ :: SMPClient -> NonEmpty RcvQueueSub -> IO (BatchResponses RcvQueueSub SMPClientError (Maybe ServiceId), Bool)
+    subscribe_ smp qs' = do
+      let (userId, srv, _) = tSess
       atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
       rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs'
-      active <-
-        atomically $
-          ifM
+      cs_ <-
+        if withEvents
+          then Just . S.fromList . map qConnId . M.elems <$> atomically (SS.getActiveSubs tSess $ currentSubs c)
+          else pure Nothing
+      active <- E.uninterruptibleMask_ $ do
+        (active, notices) <- atomically $ do
+          r@(_, notices) <- ifM
             (activeClientSession c tSess sessId)
-            (writeTVar session (Just sessId) >> processSubResults rs $> True)
-            (incSMPServerStat' c userId srv connSubIgnored (length rs) $> False)
-      if active
-        then when (hasTempErrors rs) resubscribe $> rs
-        else do
-          logWarn "subcription batch result for replaced SMP client, resubscribing"
-          -- TODO we probably use PCENetworkError here instead of the original error, so it becomes temporary.
-          resubscribe $> L.map (second $ Left . PCENetworkError . NESubscribeError . show) rs
+            ((True,) <$> processSubResults c tSess sessId rs)
+            ((False, []) <$ incSMPServerStat' c userId srv connSubIgnored (length rs))
+          unless (null notices) $ takeTMVar $ clientNoticesLock c
+          pure r
+        unless (null notices) $ void $
+          (processClientNotices c tSess notices `runReaderT` agentEnv c)
+            `E.finally` atomically (putTMVar (clientNoticesLock c) ())
+        pure active
+      forM_ cs_ $ \cs -> do
+        let (errs, okConns) = partitionEithers $ map (\(RcvQueueSub {connId}, r) -> bimap (connId,) (const connId) r) $ L.toList rs
+            conns = filter (`S.notMember` cs) okConns
+        unless (null conns) $ notifySub c $ UP srv conns
+        forM_ (L.nonEmpty errs) $ \errs' -> do
+          let noFinalErrs = all (temporaryClientError . snd) errs'
+              addr = B.unpack $ strEncode srv
+          notifySub c $ ERRS $ L.map (second $ protocolClientError SMP addr) errs'
+          when (null okConns && S.null cs && noFinalErrs && active) $ liftIO $ do
+            -- We only close the client session that was used to subscribe.
+            v_ <- atomically $ ifM (activeClientSession c tSess sessId) (TM.lookupDelete tSess $ smpClients c) (pure Nothing)
+            mapM_ (closeClient_ c) v_
+      pure (rs, active)
       where
         tSess = transportSession' smp
         sessId = sessionId $ thParams smp
-        hasTempErrors = any (either temporaryClientError (const False) . snd)
-        processSubResults :: NonEmpty (RcvQueue, Either SMPClientError (Maybe ServiceId)) -> STM ()
-        processSubResults = mapM_ $ uncurry $ processSubResult c sessId
-        resubscribe = resubscribeSMPSession c tSess `runReaderT` env
+
+processClientNotices :: AgentClient -> SMPTransportSession -> [(RcvQueueSub, Maybe ClientNotice)] -> AM' ()
+processClientNotices c@AgentClient {presetServers} tSess notices = do
+  now <- liftIO getSystemSeconds
+  tryAllErrors' (withStore' c $ \db -> (,) <$> updateClientNotices db tSess now notices <*> getClientNotices db presetServers) >>= \case
+    Right (noticeIds, clntNotices) -> atomically $ do
+      SS.updateClientNotices tSess noticeIds $ currentSubs c
+      writeTVar (clientNotices c) clntNotices
+    Left e -> do
+      logError $ "processClientNotices error: " <> tshow e
+      notifySub' c "" $ ERR e
 
 activeClientSession :: AgentClient -> SMPTransportSession -> SessionId -> STM Bool
 activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClients c)
@@ -1551,72 +1661,94 @@ type BatchResponses q e r = NonEmpty (q, Either e r)
 
 -- Please note: this function does not preserve order of results to be the same as the order of arguments,
 -- it includes arguments in the results instead.
-sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)]
-sendTSessionBatches statCmd toRQ action c nm qs =
-  concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
-  where
-    batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
-    batchQueues = do
-      mode <- getSessionMode c
-      pure . M.assocs $ foldr (batch mode) M.empty qs
-      where
-        batch mode q m =
-          let tSess = mkSMPTSession (toRQ q) mode
-           in M.alter (Just . maybe [q] (q <|)) tSess m
-    sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
-    sendClientBatch (tSess@(_, srv, _), qs') =
-      tryAllErrors' (getSMPServerClient c nm tSess) >>= \case
-        Left e -> pure $ L.map (,Left e) qs'
-        Right (SMPConnectedClient smp _) -> liftIO $ do
-          logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
-          L.map agentError <$> action smp qs'
-          where
-            agentError = second . first $ protocolClientError SMP $ clientServer smp
+sendTSessionBatches :: forall q r. ByteString -> (q -> TransportSessionMode -> SMPTransportSession) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)]
+sendTSessionBatches statCmd mkSession action c nm qs = do
+  qs' <- batchQueues mkSession qs <$> getSessionModeIO c
+  concatMap L.toList <$> mapConcurrently (sendClientBatch statCmd action c nm) qs'
 
-sendBatch :: (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
+batchQueues :: (q -> TransportSessionMode -> SMPTransportSession) -> [q] -> TransportSessionMode -> [(SMPTransportSession, NonEmpty q)]
+batchQueues mkSession qs mode = M.assocs $ foldr batch M.empty qs
+  where
+    batch q m =
+      let tSess = mkSession q mode
+       in M.alter (Just . maybe [q] (q <|)) tSess m
+
+sendClientBatch :: ByteString -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
+sendClientBatch statCmd action = fmap fst .:. sendClientBatch_ statCmd () (fmap (,()) .: action)
+{-# INLINE sendClientBatch #-}
+
+sendClientBatch_ :: ByteString -> res -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r, res)) -> AgentClient -> NetworkRequestMode -> (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r, res)
+sendClientBatch_ statCmd errRes action c nm (tSess@(_, srv, _), qs') =
+  tryAllErrors' (getSMPServerClient c nm tSess) >>= \case
+    Left e -> pure (L.map (,Left e) qs', errRes)
+    Right (SMPConnectedClient smp _) -> liftIO $ do
+      logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
+      first (L.map agentError) <$> action smp qs'
+      where
+        agentError = second . first $ protocolClientError SMP $ B.unpack (strEncode srv)
+
+sendBatch :: SomeRcvQueue q => (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty q -> IO (BatchResponses q SMPClientError a)
 sendBatch smpCmdFunc smp nm qs = L.zip qs <$> smpCmdFunc smp nm (L.map queueCreds qs)
   where
-    queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvId, rcvPrivateKey)
+    queueCreds q = (queueId q, rcvAuthKey q)
 
-addSubscription :: AgentClient -> SessionId -> RcvQueue -> STM ()
-addSubscription c sessId rq@RcvQueue {connId} = do
-  modifyTVar' (subscrConns c) $ S.insert connId
-  RQ.addQueue (sessId, rq) $ activeSubs c
-  RQ.deleteQueue rq $ pendingSubs c
+failSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> q -> SMPClientError -> STM ()
+failSubscription c tSess rq e = do
+  let rId = queueId rq
+  TM.insert rId e =<< getRemovedSubs c (qUserId rq, qServer rq)
+  SS.deletePendingSub tSess rId $ currentSubs c
 
-failSubscription :: AgentClient -> RcvQueue -> SMPClientError -> STM ()
-failSubscription c rq e = do
-  RQ.deleteQueue rq (pendingSubs c)
-  TM.insert (RQ.qKey rq) e (removedSubs c)
+failSubscriptions :: AgentClient -> SMPTransportSession -> Map SMP.RecipientId SMPClientError -> STM ()
+failSubscriptions c tSess@(uId, srv, _) qs = do
+  TM.union qs =<< getRemovedSubs c (uId, srv)
+  SS.batchDeletePendingSubs tSess (M.keysSet qs) $ currentSubs c
 
-addPendingSubscription :: AgentClient -> RcvQueue -> STM ()
-addPendingSubscription c rq@RcvQueue {connId} = do
-  modifyTVar' (subscrConns c) $ S.insert connId
-  RQ.addQueue rq $ pendingSubs c
+getRemovedSubs :: AgentClient -> (UserId, SMPServer) -> STM (TMap SMP.RecipientId SMPClientError)
+getRemovedSubs AgentClient {removedSubs} k = TM.lookup k removedSubs >>= maybe new pure
+  where
+    new = do
+      s <- newTVar M.empty
+      TM.insert k s removedSubs
+      pure s
 
 addNewQueueSubscription :: AgentClient -> RcvQueue -> SMPTransportSession -> SessionId -> AM' ()
-addNewQueueSubscription c rq tSess sessId = do
-  same <-
-    atomically $
-      ifM
-        (activeClientSession c tSess sessId)
-        (True <$ addSubscription c sessId rq)
-        (False <$ addPendingSubscription c rq)
+addNewQueueSubscription c rq' tSess sessId = do
+  let rq = rcvQueueSub rq'
+  same <- atomically $ do
+    modifyTVar' (subscrConns c) $ S.insert $ qConnId rq
+    active <- activeClientSession c tSess sessId
+    if active
+      then SS.addActiveSub tSess sessId rq $ currentSubs c
+      else SS.addPendingSub tSess rq $ currentSubs c
+    pure active
   unless same $ resubscribeSMPSession c tSess
 
-hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
-hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c
+hasActiveSubscription :: SomeRcvQueue q => AgentClient -> q -> STM Bool
+hasActiveSubscription c rq = do
+  tSess <- mkSMPTransportSession c rq
+  SS.hasActiveSub tSess (queueId rq) $ currentSubs c
 {-# INLINE hasActiveSubscription #-}
 
-hasPendingSubscription :: AgentClient -> ConnId -> STM Bool
-hasPendingSubscription c connId = RQ.hasConn connId $ pendingSubs c
+hasPendingSubscription :: SomeRcvQueue q => AgentClient -> q -> STM Bool
+hasPendingSubscription c rq = do
+  tSess <- mkSMPTransportSession c rq
+  SS.hasPendingSub tSess (queueId rq) $ currentSubs c
 {-# INLINE hasPendingSubscription #-}
 
-removeSubscription :: AgentClient -> ConnId -> STM ()
-removeSubscription c connId = do
+hasRemovedSubscription :: SomeRcvQueue q => AgentClient -> q -> STM (Maybe SMPClientError)
+hasRemovedSubscription c rq = do
+  TM.lookup (qUserId rq, qServer rq) (removedSubs c) $>>= TM.lookup (queueId rq)
+
+removeSubscription :: SomeRcvQueue q => AgentClient -> SMPTransportSession -> ConnId -> q -> STM ()
+removeSubscription c tSess connId rq = do
   modifyTVar' (subscrConns c) $ S.delete connId
-  RQ.deleteConn connId $ activeSubs c
-  RQ.deleteConn connId $ pendingSubs c
+  SS.deleteSub tSess (queueId rq) $ currentSubs c
+
+removeSubscriptions :: SomeRcvQueue q => AgentClient -> [ConnId] -> [q] -> STM ()
+removeSubscriptions c connIds qs = do
+  unless (null connIds) $ modifyTVar' (subscrConns c) (`S.difference` (S.fromList connIds))
+  qss <- batchQueues mkSMPTSession qs <$> getSessionMode c
+  forM_ qss $ \(tSess, qs') -> SS.batchDeleteSubs tSess (L.toList qs') $ currentSubs c
 
 getSubscriptions :: AgentClient -> IO (Set ConnId)
 getSubscriptions = readTVarIO . subscrConns
@@ -1644,8 +1776,8 @@ logSecret' = B64.encode . B.take 3
 {-# INLINE logSecret' #-}
 
 sendConfirmation :: AgentClient -> NetworkRequestMode -> SndQueue -> ByteString -> AM (Maybe SMPServer)
-sendConfirmation c nm sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
-  let (privHdr, spKey) = if senderCanSecure queueMode then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing)
+sendConfirmation c nm sq@SndQueue {userId, server, connId, sndId, queueMode, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
+  let (privHdr, spKey) = if senderCanSecure queueMode then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation (C.toPublic sndPrivateKey), Nothing)
       clientMsg = SMP.ClientMessage privHdr agentConfirmation
   msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
   sendOrProxySMPMessage c nm userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
@@ -1691,12 +1823,12 @@ secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
     secureSMPQueue smp nm rcvPrivateKey rcvId senderKey
 
 secureSndQueue :: AgentClient -> NetworkRequestMode -> SndQueue -> AM ()
-secureSndQueue c nm SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
+secureSndQueue c nm SndQueue {userId, connId, server, sndId, sndPrivateKey} =
   void $ sendOrProxySMPCommand c nm userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
   where
     -- TODO track statistics
-    secureViaProxy smp proxySess = proxySecureSndSMPQueue smp nm proxySess sndPrivateKey sndId sndPublicKey
-    secureDirectly smp = secureSndSMPQueue smp nm sndPrivateKey sndId sndPublicKey
+    secureViaProxy smp proxySess = proxySecureSndSMPQueue smp nm proxySess sndPrivateKey sndId
+    secureDirectly smp = secureSndSMPQueue smp nm sndPrivateKey sndId
 
 addQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
 addQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
@@ -1707,11 +1839,11 @@ deleteQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
   withSMPClient c nm rq "LDEL" $ \smp -> deleteSMPQueueLink smp nm rcvPrivateKey rcvId
 
 secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
-secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
+secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey} =
   snd <$> sendOrProxySMPCommand c nm userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
   where
-    secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId sndPublicKey
-    secureGetDirectly smp = secureGetSMPQueueLink smp nm sndPrivateKey linkId sndPublicKey
+    secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId
+    secureGetDirectly smp = secureGetSMPQueueLink smp nm sndPrivateKey linkId
 
 getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
 getQueueLink c nm userId server lnkId =
@@ -1733,7 +1865,7 @@ data EnableQueueNtfReq = EnableQueueNtfReq
   }
 
 enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
-enableQueuesNtfs c = sendTSessionBatches "NKEY" eqnrRq enableQueues_ c NRMBackground
+enableQueuesNtfs c = sendTSessionBatches "NKEY" (mkSMPTSession . eqnrRq) enableQueues_ c NRMBackground
   where
     enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
     enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
@@ -1752,7 +1884,7 @@ disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
 type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
 
 disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
-disableQueuesNtfs c = sendTSessionBatches "NDEL" snd disableQueues_ c NRMBackground
+disableQueuesNtfs c = sendTSessionBatches "NDEL" (mkSMPTSession . snd) disableQueues_ c NRMBackground
   where
     disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
     disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
@@ -1764,16 +1896,23 @@ sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
   withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
 
-hasGetLock :: AgentClient -> RcvQueue -> IO Bool
-hasGetLock c RcvQueue {server, rcvId} =
-  TM.memberIO (server, rcvId) $ getMsgLocks c
+hasGetLock :: SomeRcvQueue q => AgentClient -> q -> IO Bool
+hasGetLock c rq =
+  TM.memberIO (qServer rq, queueId rq) $ getMsgLocks c
 {-# INLINE hasGetLock #-}
 
-releaseGetLock :: AgentClient -> RcvQueue -> STM ()
-releaseGetLock c RcvQueue {server, rcvId} =
-  TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
+releaseGetLock :: SomeRcvQueue q => AgentClient -> q -> STM ()
+releaseGetLock c rq =
+  TM.lookup (qServer rq, queueId rq) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
 {-# INLINE releaseGetLock #-}
 
+releaseGetLocksIO :: SomeRcvQueue q => AgentClient -> [q] -> IO ()
+releaseGetLocksIO c rqs = do
+  locks <- readTVarIO $ getMsgLocks c
+  forM_ rqs $ \rq ->
+    forM_ (M.lookup ((qServer rq, queueId rq)) locks) $ \lock ->
+      atomically $ tryPutTMVar lock ()
+
 suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
 suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
   withSMPClient c nm rq "OFF" $ \smp ->
@@ -1785,7 +1924,7 @@ deleteQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = do
     deleteSMPQueue smp nm rcvPrivateKey rcvId
 
 deleteQueues :: AgentClient -> NetworkRequestMode -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
-deleteQueues c nm = sendTSessionBatches "DEL" id deleteQueues_ c nm
+deleteQueues c nm = sendTSessionBatches "DEL" mkSMPTSession deleteQueues_ c nm
   where
     deleteQueues_ smp rqs = do
       let (userId, srv, _) = transportSession' smp
@@ -1876,7 +2015,7 @@ withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
       logServer' "-->" c ntfServer (bshow (length subs) <> " subscriptions") cmdStr
       L.map agentError <$> action ntf ntfPrivKey subs
       where
-        agentError = first $ protocolClientError NTF $ clientServer ntf
+        agentError = first $ protocolClientError NTF $ B.unpack (strEncode ntfServer)
 
 agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM ()
 agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
@@ -2000,9 +2139,7 @@ withWorkItems c doWork getWork action = do
           forM_ criticalErr $ \err -> do
             notifyErr (CRITICAL False) err
             when (all isWorkItemError errs) noWork
-      unless (null errs) $
-        atomically $
-          writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS $ map (\e -> ("", INTERNAL $ show e)) errs)
+      forM_ (L.nonEmpty errs) $ notifySub c . ERRS . L.map (\e -> ("", INTERNAL $ show e))
     Left e
       | isWorkItemError e -> noWork >> notifyErr (CRITICAL False) e
       | otherwise -> notifyErr INTERNAL e
@@ -2313,15 +2450,16 @@ data ServerSessions = ServerSessions
 
 getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool)
 getAgentSubsTotal c userIds = do
-  ssActive <- getSubsCount activeSubs
-  ssPending <- getSubsCount pendingSubs
+  (ssActive, ssPending) <- SS.foldSessionSubs addSub (0, 0) $ currentSubs c
   sess <- hasSession . M.toList =<< readTVarIO (smpClients c)
   pure (SMPServerSubs {ssActive, ssPending}, sess)
   where
-    getSubsCount :: (AgentClient -> TRcvQueues q) -> IO Int
-    getSubsCount subs = M.foldrWithKey' addSub 0 <$> readTVarIO (getRcvQueues $ subs c)
-    addSub :: (UserId, SMPServer, SMP.RecipientId) -> q -> Int -> Int
-    addSub (userId, _, _) _ cnt = if userId `elem` userIds then cnt + 1 else cnt
+    addSub :: (Int, Int) -> (SMPTransportSession, SS.SessSubs) -> IO (Int, Int)
+    addSub acc@(!ssActive, !ssPending) ((userId, _, _), s)
+      | userId `elem` userIds = do
+          (active, pending) <- SS.mapSubs M.size s
+          pure (ssActive + active, ssPending + pending)
+      | otherwise = pure acc
     hasSession :: [(SMPTransportSession, SMPClientVar)] -> IO Bool
     hasSession = \case
       [] -> pure False
@@ -2358,13 +2496,12 @@ getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServ
         ntfServersSessions
       }
   where
-    getServerSubs = do
-      subs <- M.foldrWithKey' (addSub incActive) M.empty <$> readTVarIO (getRcvQueues $ activeSubs c)
-      M.foldrWithKey' (addSub incPending) subs <$> readTVarIO (getRcvQueues $ pendingSubs c)
+    getServerSubs = SS.foldSessionSubs addSub M.empty $ currentSubs c
       where
-        addSub f (userId, srv, _) _ = M.alter (Just . f . fromMaybe SMPServerSubs {ssActive = 0, ssPending = 0}) (userId, srv)
-        incActive ss = ss {ssActive = ssActive ss + 1}
-        incPending ss = ss {ssPending = ssPending ss + 1}
+        addSub subs ((userId, srv, _), s) = do
+          (active, pending) <- SS.mapSubs M.size s
+          let add ss = ss {ssActive = ssActive ss + active, ssPending = ssPending ss + pending}
+          pure $ M.alter (Just . add . fromMaybe (SMPServerSubs 0 0)) (userId, srv) subs
     Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv
     getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers
       where
@@ -2396,14 +2533,21 @@ data SubscriptionsInfo = SubscriptionsInfo
 
 getAgentSubscriptions :: AgentClient -> IO SubscriptionsInfo
 getAgentSubscriptions c = do
-  activeSubscriptions <- getSubs activeSubs
-  pendingSubscriptions <- getSubs pendingSubs
-  removedSubscriptions <- getRemovedSubs
+  (activeSubscriptions, pendingSubscriptions) <- SS.foldSessionSubs addSubs ([], []) $ currentSubs c
+  removedSubscriptions <- getRemoved
   pure $ SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions}
   where
-    getSubs :: (AgentClient -> TRcvQueues q) -> IO [SubInfo]
-    getSubs sel = map (`subInfo` Nothing) . M.keys <$> readTVarIO (getRcvQueues $ sel c)
-    getRemovedSubs = map (uncurry subInfo . second Just) . M.assocs <$> readTVarIO (removedSubs c)
+    addSubs :: ([SubInfo], [SubInfo]) -> (SMPTransportSession, SS.SessSubs) -> IO ([SubInfo], [SubInfo])
+    addSubs (active, pending) ((userId, srv, _), s) = do
+      (active', pending') <- SS.mapSubs (map (\rId -> subInfo (userId, srv, rId) Nothing) . M.keys) s
+      pure (active' ++ active, pending' ++ pending)
+    getRemoved :: IO [SubInfo]
+    getRemoved = foldM addSubInfo [] . M.assocs =<< readTVarIO (removedSubs c)
+      where
+        addSubInfo :: [SubInfo] -> ((UserId, SMPServer), TMap SMP.RecipientId SMPClientError) -> IO [SubInfo]
+        addSubInfo ss ((uId, srv), errs) = do
+          ss' <- map (\(rId, e) -> subInfo (uId, srv, rId) (Just e)) . M.assocs <$> readTVarIO errs
+          pure $ ss' ++ ss
     subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo
     subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err}
     enc :: StrEncoding a => a -> Text

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

@@ -64,7 +64,7 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (createStore)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import Simplex.Messaging.Agent.Store.Interface (DBOpts)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -90,7 +90,8 @@ data InitialAgentServers = InitialAgentServers
     ntf :: [NtfServer],
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
     netCfg :: NetworkConfig,
-    presetDomains :: [HostName]
+    presetDomains :: [HostName],
+    presetServers :: [SMPServer]
   }
 
 data ServerCfg p = ServerCfg
@@ -166,6 +167,7 @@ data AgentConfig = AgentConfig
     ntfBatchSize :: Int,
     ntfSubFirstCheckInterval :: NominalDiffTime,
     ntfSubCheckInterval :: NominalDiffTime,
+    maxPendingSubscriptions :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
@@ -237,6 +239,7 @@ defaultAgentConfig =
       ntfBatchSize = 150,
       ntfSubFirstCheckInterval = nominalDay,
       ntfSubCheckInterval = 3 * nominalDay,
+      maxPendingSubscriptions = 35000,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -266,7 +269,7 @@ newSMPAgentEnv config store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 
 data NtfSupervisor = NtfSupervisor

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -513,7 +513,7 @@ notifyInternalError' AgentClient {subQ} internalErrStr = atomically $ writeTBQue
 {-# INLINE notifyInternalError' #-}
 
 notifyErrs :: MonadIO m => AgentClient -> [(ConnId, AgentErrorType)] -> m ()
-notifyErrs AgentClient {subQ} connErrs = unless (null connErrs) $ atomically $ writeTBQueue subQ ("", "", AEvt SAENone $ ERRS connErrs)
+notifyErrs c = mapM_ (notifySub c . ERRS) . L.nonEmpty
 {-# INLINE notifyErrs #-}
 
 getNtfToken :: AM' (Maybe NtfToken)

src/Simplex/Messaging/Agent/Protocol.hs

@@ -70,6 +70,7 @@ module Simplex.Messaging.Agent.Protocol
     MsgMeta (..),
     RcvQueueInfo (..),
     SndQueueInfo (..),
+    SubscriptionStatus (..),
     ConnectionStats (..),
     SwitchPhase (..),
     RcvSwitchStatus (..),
@@ -111,6 +112,8 @@ module Simplex.Messaging.Agent.Protocol
     ServiceScheme,
     FixedLinkData (..),
     ConnLinkData (..),
+    UserConnLinkData (..),
+    UserContactData (..),
     UserLinkData (..),
     OwnerAuth (..),
     OwnerId,
@@ -167,6 +170,7 @@ module Simplex.Messaging.Agent.Protocol
     updateSMPServerHosts,
     shortenShortLink,
     restoreShortLink,
+    isPresetServer,
     linkUserData,
     linkUserData',
   )
@@ -405,7 +409,7 @@ data AEvent (e :: AEntity) where
   OK :: AEvent AEConn
   JOINED :: SndQueueSecured -> Maybe ClientServiceId -> AEvent AEConn
   ERR :: AgentErrorType -> AEvent AEConn
-  ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
+  ERRS :: NonEmpty (ConnId, AgentErrorType) -> AEvent AENone
   SUSPENDED :: AEvent AENone
   RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
   RFDONE :: FilePath -> AEvent AERcvFile
@@ -643,23 +647,34 @@ instance FromJSON RatchetSyncState where
 
 data RcvQueueInfo = RcvQueueInfo
   { rcvServer :: SMPServer,
+    status :: QueueStatus,
     rcvSwitchStatus :: Maybe RcvSwitchStatus,
-    canAbortSwitch :: Bool
+    canAbortSwitch :: Bool,
+    subStatus :: SubscriptionStatus
   }
   deriving (Eq, Show)
 
 data SndQueueInfo = SndQueueInfo
   { sndServer :: SMPServer,
+    status :: QueueStatus,
     sndSwitchStatus :: Maybe SndSwitchStatus
   }
   deriving (Eq, Show)
 
+data SubscriptionStatus
+  = SSActive
+  | SSPending
+  | SSRemoved {subError :: String}
+  | SSNoSub
+  deriving (Eq, Ord, Show)
+
 data ConnectionStats = ConnectionStats
   { connAgentVersion :: VersionSMPA,
     rcvQueuesInfo :: [RcvQueueInfo],
     sndQueuesInfo :: [SndQueueInfo],
     ratchetSyncState :: RatchetSyncState,
-    ratchetSyncSupported :: Bool
+    ratchetSyncSupported :: Bool,
+    subStatus :: Maybe SubscriptionStatus
   }
   deriving (Eq, Show)
 
@@ -1612,15 +1627,16 @@ shortenShortLink presetSrvs = \case
   CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (shortServer srv) lnkId linkKey
   CSLContact sch ct srv linkKey -> CSLContact sch ct (shortServer srv) linkKey
   where
-    shortServer srv@(SMPServer hs@(h :| _) p kh) =
-      if isPresetServer then SMPServerOnlyHost h else srv
-      where
-        isPresetServer = case findPresetServer srv presetSrvs of
-          Just (SMPServer hs' p' kh') ->
-            all (`elem` hs') hs
-              && (p == p' || (null p' && (p == "443" || p == "5223")))
-              && kh == kh'
-          Nothing -> False
+    shortServer srv@(SMPServer (h :| _) _ _) =
+      if isPresetServer srv presetSrvs then SMPServerOnlyHost h else srv
+
+isPresetServer :: Foldable t => SMPServer -> t SMPServer -> Bool
+isPresetServer srv@(SMPServer hs p kh) presetSrvs = case findPresetServer srv presetSrvs of
+  Just (SMPServer hs' p' kh') ->
+    all (`elem` hs') hs
+      && (p == p' || (null p' && (p == "443" || p == "5223")))
+      && kh == kh'
+  Nothing -> False
 
 -- explicit bidirectional is used for ghc 8.10.7 compatibility, [h]/[] patterns are not reversible.
 pattern SMPServerOnlyHost :: TransportHost -> SMPServer
@@ -1638,7 +1654,7 @@ restoreShortLink presetSrvs = \case
       s@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs
       s -> s
 
-findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer
+findPresetServer :: Foldable t => SMPServer -> t SMPServer -> Maybe SMPServer
 findPresetServer ProtocolServer {host = h :| _} = find (\ProtocolServer {host = h' :| _} -> h == h')
 {-# INLINE findPresetServer #-}
 
@@ -1676,25 +1692,30 @@ data FixedLinkData c = FixedLinkData
 
 data ConnLinkData c where
   InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
-  ContactLinkData ::
-    { agentVRange :: VersionRangeSMPA,
-      -- direct connection via connReq in fixed data is allowed.
-      direct :: Bool,
-      -- additional owner keys to sign changes of mutable data.
-      owners :: [OwnerAuth],
-      -- alternative addresses of chat relays that receive requests for this contact address.
-      relays :: [ConnShortLink 'CMContact],
-      userData :: UserLinkData
-    } -> ConnLinkData 'CMContact
+  ContactLinkData :: VersionRangeSMPA -> UserContactData -> ConnLinkData 'CMContact
+
+data UserContactData = UserContactData
+  { -- direct connection via connReq in fixed data is allowed.
+    direct :: Bool,
+    -- additional owner keys to sign changes of mutable data.
+    owners :: [OwnerAuth],
+    -- alternative addresses of chat relays that receive requests for this contact address.
+    relays :: [ConnShortLink 'CMContact],
+    userData :: UserLinkData
+  }
 
 newtype UserLinkData = UserLinkData ByteString
 
 data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m)
 
+data UserConnLinkData c where
+  UserInvLinkData :: UserLinkData -> UserConnLinkData 'CMInvitation
+  UserContactLinkData :: UserContactData -> UserConnLinkData 'CMContact
+
 linkUserData :: ConnLinkData c -> UserLinkData
 linkUserData = \case
   InvitationLinkData _ d -> d
-  ContactLinkData {userData} -> userData
+  ContactLinkData _ UserContactData {userData} -> userData
 {-# INLINE linkUserData #-}
 
 linkUserData' :: ConnLinkData c -> ByteString
@@ -1735,8 +1756,8 @@ instance ConnectionModeI c => Encoding (FixedLinkData c) where
 instance ConnectionModeI c => Encoding (ConnLinkData c) where
   smpEncode = \case
     InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData)
-    ContactLinkData {agentVRange, direct, owners, relays, userData} ->
-      B.concat [smpEncode (CMContact, agentVRange, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
+    ContactLinkData vr UserContactData {direct, owners, relays, userData} ->
+      B.concat [smpEncode (CMContact, vr, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
   smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP
   {-# INLINE smpP #-}
 
@@ -1749,11 +1770,12 @@ instance Encoding AConnLinkData where
         (vr, userData) <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
         pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
       CMContact -> do
-        (agentVRange, direct) <- smpP
+        (vr, direct) <- smpP
         owners <- smpListP
         relays <- smpListP
         userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
-        pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData}
+        let cd = UserContactData {direct, owners, relays, userData}
+        pure $ ACLD SCMContact $ ContactLinkData vr cd
 
 instance Encoding UserLinkData where
   smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s)
@@ -1859,6 +1881,8 @@ data AgentErrorType
     BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
     AGENT {agentErr :: SMPAgentError}
+  | -- | client notice
+    NOTICE {server :: Text, preset :: Bool, expiresAt :: Maybe UTCTime}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
   | -- | critical agent errors that should be shown to the user, optionally with restart button
@@ -2000,6 +2024,10 @@ serializeCommand = \case
 serializeBinary :: ByteString -> ByteString
 serializeBinary body = bshow (B.length body) <> "\n" <> body
 
+$(J.deriveJSON (enumJSON fstToLower) ''QueueStatus)
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "SS") ''SubscriptionStatus)
+
 $(J.deriveJSON defaultJSON ''RcvQueueInfo)
 
 $(J.deriveJSON defaultJSON ''SndQueueInfo)

src/Simplex/Messaging/Agent/Store.hs

@@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Common
 import Simplex.Messaging.Agent.Store.Interface (createDBStore)
 import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
 import Simplex.Messaging.Encoding.String
@@ -49,13 +49,12 @@ import Simplex.Messaging.Protocol
     RcvNtfDhSecret,
     RcvPrivateAuthKey,
     SndPrivateAuthKey,
-    SndPublicAuthKey,
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Util (AnyError (..), bshow)
 
-createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createStore dbOpts = createDBStore dbOpts appMigrations
 
 -- * Queue types
@@ -89,6 +88,10 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
     clientService :: Maybe (StoredClientService q),
     -- | queue status
     status :: QueueStatus,
+    -- | to enable notifications for this queue - this field is duplicated from ConnData
+    enableNtfs :: Bool,
+    -- | client notice
+    clientNoticeId :: Maybe NoticeId,
     -- | database queue ID (within connection)
     dbQueueId :: DBEntityId' q,
     -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
@@ -104,6 +107,25 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
   }
   deriving (Show)
 
+data RcvQueueSub = RcvQueueSub
+  { userId :: UserId,
+    connId :: ConnId,
+    server :: SMPServer,
+    rcvId :: SMP.RecipientId,
+    rcvPrivateKey :: RcvPrivateAuthKey,
+    status :: QueueStatus,
+    enableNtfs :: Bool,
+    clientNoticeId :: Maybe NoticeId,
+    dbQueueId :: Int64,
+    primary :: Bool,
+    dbReplaceQueueId :: Maybe Int64
+  }
+  deriving (Show)
+
+rcvQueueSub :: RcvQueue -> RcvQueueSub
+rcvQueueSub RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId = DBEntityId dbQueueId, primary, dbReplaceQueueId} =
+  RcvQueueSub {userId, connId, server, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
+
 data ShortLinkCreds = ShortLinkCreds
   { shortLinkId :: SMP.LinkId,
     shortLinkKey :: LinkKey,
@@ -116,10 +138,6 @@ clientServiceId :: RcvQueue -> Maybe ClientServiceId
 clientServiceId = fmap dbServiceId . clientService
 {-# INLINE clientServiceId #-}
 
-rcvQueueInfo :: RcvQueue -> RcvQueueInfo
-rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
-  RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
-
 rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
 rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
   SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
@@ -155,7 +173,6 @@ data InvShortLink = InvShortLink
     linkId :: SMP.LinkId,
     linkKey :: LinkKey,
     sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries
-    sndPublicKey :: SndPublicAuthKey,
     sndId :: Maybe SMP.SenderId
   }
   deriving (Show)
@@ -173,9 +190,7 @@ data StoredSndQueue (q :: DBStored) = SndQueue
     sndId :: SMP.SenderId,
     -- | sender can secure the queue
     queueMode :: Maybe QueueMode,
-    -- | key pair used by the sender to authorize transmissions
-    -- TODO combine keys to key pair so that types match
-    sndPublicKey :: SndPublicAuthKey,
+    -- | sender key used to authorize transmissions
     sndPrivateKey :: SndPrivateAuthKey,
     -- | DH public key used to negotiate per-queue e2e encryption
     e2ePubKey :: Maybe C.PublicKeyX25519,
@@ -195,10 +210,6 @@ data StoredSndQueue (q :: DBStored) = SndQueue
   }
   deriving (Show)
 
-sndQueueInfo :: SndQueue -> SndQueueInfo
-sndQueueInfo SndQueue {server, sndSwchStatus} =
-  SndQueueInfo {sndServer = server, sndSwitchStatus = sndSwchStatus}
-
 instance SMPQueue RcvQueue where
   qServer RcvQueue {server} = server
   {-# INLINE qServer #-}
@@ -211,6 +222,12 @@ instance SMPQueue NewRcvQueue where
   queueId RcvQueue {rcvId} = rcvId
   {-# INLINE queueId #-}
 
+instance SMPQueue RcvQueueSub where
+  qServer RcvQueueSub {server} = server
+  {-# INLINE qServer #-}
+  queueId RcvQueueSub {rcvId} = rcvId
+  {-# INLINE queueId #-}
+
 instance SMPQueue SndQueue where
   qServer SndQueue {server} = server
   {-# INLINE qServer #-}
@@ -250,6 +267,7 @@ class SMPQueue q => SMPQueueRec q where
   qUserId :: q -> UserId
   qConnId :: q -> ConnId
   dbQId :: q -> Int64
+  qPrimary :: q -> Bool
   dbReplaceQId :: q -> Maybe Int64
 
 instance SMPQueueRec RcvQueue where
@@ -259,9 +277,23 @@ instance SMPQueueRec RcvQueue where
   {-# INLINE qConnId #-}
   dbQId RcvQueue {dbQueueId = DBEntityId qId} = qId
   {-# INLINE dbQId #-}
+  qPrimary RcvQueue {primary} = primary
+  {-# INLINE qPrimary #-}
   dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
 
+instance SMPQueueRec RcvQueueSub where
+  qUserId RcvQueueSub {userId} = userId
+  {-# INLINE qUserId #-}
+  qConnId RcvQueueSub {connId} = connId
+  {-# INLINE qConnId #-}
+  dbQId RcvQueueSub {dbQueueId} = dbQueueId
+  {-# INLINE dbQId #-}
+  qPrimary RcvQueueSub {primary} = primary
+  {-# INLINE qPrimary #-}
+  dbReplaceQId RcvQueueSub {dbReplaceQueueId} = dbReplaceQueueId
+  {-# INLINE dbReplaceQId #-}
+
 instance SMPQueueRec SndQueue where
   qUserId SndQueue {userId} = userId
   {-# INLINE qUserId #-}
@@ -269,9 +301,22 @@ instance SMPQueueRec SndQueue where
   {-# INLINE qConnId #-}
   dbQId SndQueue {dbQueueId = DBEntityId qId} = qId
   {-# INLINE dbQId #-}
+  qPrimary SndQueue {primary} = primary
+  {-# INLINE qPrimary #-}
   dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
   {-# INLINE dbReplaceQId #-}
 
+class SMPQueueRec q => SomeRcvQueue q where
+  rcvAuthKey :: q -> RcvPrivateAuthKey
+
+instance SomeRcvQueue RcvQueue where
+  rcvAuthKey RcvQueue {rcvPrivateKey} = rcvPrivateKey
+  {-# INLINE rcvAuthKey #-}
+
+instance SomeRcvQueue RcvQueueSub where
+  rcvAuthKey RcvQueueSub {rcvPrivateKey} = rcvPrivateKey
+  {-# INLINE rcvAuthKey #-}
+
 -- * Connection types
 
 -- | Type of a connection.
@@ -287,16 +332,18 @@ data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 --
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
-data Connection (d :: ConnType) where
-  NewConnection :: ConnData -> Connection CNew
-  RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
-  SndConnection :: ConnData -> SndQueue -> Connection CSnd
-  DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
-  ContactConnection :: ConnData -> RcvQueue -> Connection CContact
+data Connection' (d :: ConnType) rq sq where
+  NewConnection :: ConnData -> Connection' CNew rq sq
+  RcvConnection :: ConnData -> rq -> Connection' CRcv rq sq
+  SndConnection :: ConnData -> sq -> Connection' CSnd rq sq
+  DuplexConnection :: ConnData -> NonEmpty rq -> NonEmpty sq -> Connection' CDuplex rq sq
+  ContactConnection :: ConnData -> rq -> Connection' CContact rq sq
 
-deriving instance Show (Connection d)
+deriving instance (Show rq, Show sq) => Show (Connection' d rq sq)
 
-toConnData :: Connection d -> ConnData
+type Connection d = Connection' d RcvQueue SndQueue
+
+toConnData :: Connection' d rq sq -> ConnData
 toConnData = \case
   NewConnection cData -> cData
   RcvConnection cData _ -> cData
@@ -304,7 +351,7 @@ toConnData = \case
   DuplexConnection cData _ _ -> cData
   ContactConnection cData _ -> cData
 
-updateConnection :: ConnData -> Connection d -> Connection d
+updateConnection :: ConnData -> Connection' d rq sq -> Connection' d rq sq
 updateConnection cData = \case
   NewConnection _ -> NewConnection cData
   RcvConnection _ rq -> RcvConnection cData rq
@@ -337,9 +384,13 @@ instance TestEquality SConnType where
 
 -- | Connection of an unknown type.
 -- Used to refer to an arbitrary connection when retrieving from store.
-data SomeConn = forall d. SomeConn (SConnType d) (Connection d)
+data SomeConn' rq sq = forall d. SomeConn (SConnType d) (Connection' d rq sq)
 
-deriving instance Show SomeConn
+deriving instance (Show rq, Show sq) => Show (SomeConn' rq sq)
+
+type SomeConn = SomeConn' RcvQueue SndQueue
+
+type SomeConnSub = SomeConn' RcvQueueSub SndQueue
 
 data ConnData = ConnData
   { connId :: ConnId,
@@ -353,6 +404,8 @@ data ConnData = ConnData
   }
   deriving (Eq, Show)
 
+type NoticeId = Int64
+
 -- this function should be mirrored in the clients
 ratchetSyncAllowed :: ConnData -> Bool
 ratchetSyncAllowed ConnData {ratchetSyncState, connAgentVersion} =

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

@@ -28,6 +28,7 @@
 module Simplex.Messaging.Agent.Store.AgentStore
   ( -- * Users
     createUserRecord,
+    getUserIds,
     deleteUserRecord,
     setUserDeleted,
     deleteUserWithoutConns,
@@ -39,11 +40,18 @@ module Simplex.Messaging.Agent.Store.AgentStore
     updateNewConnRcv,
     updateNewConnSnd,
     createSndConn,
+    getClientNotices,
+    updateClientNotices,
+    getSubscriptionServers,
+    getUserServerRcvQueueSubs,
+    unsetQueuesToSubscribe,
+    getConnIds,
     getConn,
     getDeletedConn,
     getConns,
+    getConnSubs,
     getDeletedConns,
-    getConnData,
+    getConnsData,
     setConnDeleted,
     setConnUserId,
     setConnAgentVersion,
@@ -109,6 +117,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     updateSndMsgRcpt,
     getPendingQueueMsg,
     getConnectionsForDelivery,
+    getAllSndQueuesForDelivery,
     updatePendingMsgRIState,
     deletePendingMsgs,
     getExpiredSndMessages,
@@ -136,6 +145,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     -- Async commands
     createCommand,
     getPendingCommandServers,
+    getAllPendingCommandConns,
     getPendingServerCommand,
     updateCommandServer,
     deleteCommand,
@@ -256,9 +266,11 @@ import Data.Int (Int64)
 import Data.List (foldl', sortBy)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
+import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Ord (Down (..))
+import qualified Data.Set as S
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
 import Data.Word (Word32)
@@ -274,25 +286,29 @@ import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.Common
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Entity
+import Simplex.Messaging.Client (SMPTransportSession)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceTokenFields, deviceToken')
 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.Protocol.Types
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
+import Simplex.Messaging.Util
 import Simplex.Messaging.Version.Internal
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 #if defined(dbPostgres)
-import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..))
+import Data.List (sortOn)
+import Database.PostgreSQL.Simple (In (..), Only (..), Query, SqlError, (:.) (..))
 import Database.PostgreSQL.Simple.Errors (constraintViolation)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 #else
@@ -321,6 +337,10 @@ createUserRecord db = do
   DB.execute_ db "INSERT INTO users DEFAULT VALUES"
   insertedRowId db
 
+getUserIds :: DB.Connection -> IO [UserId]
+getUserIds db =
+  map fromOnly <$> DB.query_ db "SELECT user_id FROM users WHERE deleted = 0"
+
 checkUser :: DB.Connection -> UserId -> IO (Either StoreError ())
 checkUser db userId =
   firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $
@@ -384,15 +404,15 @@ createNewConn db gVar cData cMode = do
   fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode)
 
 -- TODO [certs rcv] store clientServiceId from NewRcvQueue
-updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
-updateNewConnRcv db connId rq =
+updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
+updateNewConnRcv db connId rq subMode =
   getConn db connId $>>= \case
     (SomeConn _ NewConnection {}) -> updateConn
     (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
     (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
   where
     updateConn :: IO (Either StoreError RcvQueue)
-    updateConn = Right <$> addConnRcvQueue_ db connId rq
+    updateConn = Right <$> addConnRcvQueue_ db connId rq subMode
 
 updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 updateNewConnSnd db connId sq =
@@ -426,15 +446,12 @@ deleteConnRecord :: DB.Connection -> ConnId -> IO ()
 deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId)
 
 checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
-checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1"
-          (host server, port server, sndId, New)
-      )
+checkConfirmedSndQueueExists_ db SndQueue {server, sndId} =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1"
+      (host server, port server, sndId, New)
 
 getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
 getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
@@ -477,25 +494,25 @@ upgradeRcvConnToDuplex db connId sq =
     (SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
 
 -- TODO [certs rcv] store clientServiceId from NewRcvQueue
-upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
-upgradeSndConnToDuplex db connId rq =
+upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
+upgradeSndConnToDuplex db connId rq subMode =
   getConn db connId >>= \case
-    Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
+    Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq subMode
     Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
     _ -> pure $ Left SEConnNotFound
 
 -- TODO [certs rcv] store clientServiceId from NewRcvQueue
-addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
-addConnRcvQueue db connId rq =
+addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO (Either StoreError RcvQueue)
+addConnRcvQueue db connId rq subMode =
   getConn db connId >>= \case
-    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
+    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq subMode
     Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
     _ -> pure $ Left SEConnNotFound
 
-addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
-addConnRcvQueue_ db connId rq@RcvQueue {server} = do
+addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> IO RcvQueue
+addConnRcvQueue_ db connId rq@RcvQueue {server} subMode = do
   serverKeyHash_ <- createServer_ db server
-  insertRcvQueue_ db connId rq serverKeyHash_
+  insertRcvQueue_ db connId rq subMode serverKeyHash_
 
 addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 addConnSndQueue db connId sq =
@@ -783,13 +800,12 @@ getInvShortLink db server linkId =
       (host server, port server, linkId)
   where
     toInvShortLink :: (LinkKey, C.APrivateAuthKey, Maybe SenderId) -> InvShortLink
-    toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk), sndId) =
-      let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk
-       in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId}
+    toInvShortLink (linkKey, sndPrivateKey, sndId) =
+      InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId}
 
-getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.AAuthKeyPair))
+getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.APrivateAuthKey))
 getInvShortLinkKeys db srv sndId =
-  maybeFirstRow toSndKeys $
+  maybeFirstRow id $
     DB.query
       db
       [sql|
@@ -798,9 +814,6 @@ getInvShortLinkKeys db srv sndId =
         WHERE host = ? AND port = ? AND snd_id = ?
       |]
       (host srv, port srv, sndId)
-  where
-    toSndKeys :: (LinkId, C.APrivateAuthKey) -> (LinkId, C.AAuthKeyPair)
-    toSndKeys (linkId, privKey@(C.APrivateAuthKey a pk)) = (linkId, (C.APublicAuthKey a $ C.publicKey pk, privKey))
 
 deleteInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO ()
 deleteInvShortLink db srv lnkId =
@@ -887,8 +900,8 @@ createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do
   insertSndMsgDetails_ db connId sndMsgData
   updateSndMsgHash db connId internalSndId internalHash
 
-createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
-createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
+createSndMsgDelivery :: DB.Connection -> SndQueue -> InternalId -> IO ()
+createSndMsgDelivery db SndQueue {connId, dbQueueId} msgId =
   DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId)
 
 getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
@@ -920,6 +933,15 @@ getConnectionsForDelivery :: DB.Connection -> IO [ConnId]
 getConnectionsForDelivery db =
   map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0"
 
+getAllSndQueuesForDelivery :: DB.Connection -> IO [SndQueue]
+getAllSndQueuesForDelivery db = map toSndQueue <$> DB.query_ db (sndQueueQuery <> " " <> delivery)
+  where
+    delivery = [sql|
+      JOIN (SELECT DISTINCT conn_id, snd_queue_id FROM snd_message_deliveries WHERE failed = 0) d
+      ON d.conn_id = q.conn_id AND d.snd_queue_id = q.snd_queue_id
+      WHERE c.deleted = 0
+    |]
+
 getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
 getPendingQueueMsg db connId SndQueue {dbQueueId} =
   getWorkItem "message" getMsgId getMsgData markMsgFailed
@@ -1072,15 +1094,12 @@ toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity,
    in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck}
 
 checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
-checkRcvMsgHashExists db connId hash = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-          (connId, Binary hash)
-      )
+checkRcvMsgHashExists db connId hash =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
+      (connId, Binary hash)
 
 getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
 getRcvMsgBrokerTs db connId msgId =
@@ -1304,21 +1323,41 @@ insertedRowId db = fromOnly . head <$> DB.query_ db q
     q = "SELECT last_insert_rowid()"
 #endif
 
-getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer]
-getPendingCommandServers db connId = do
+getPendingCommandServers :: DB.Connection -> [ConnId] -> IO [(ConnId, NonEmpty (Maybe SMPServer))]
+getPendingCommandServers db connIds =
   -- TODO review whether this can break if, e.g., the server has another key hash.
-  map smpServer
-    <$> DB.query
+  mapMaybe connServers . groupOn' rowConnId
+    <$> DB.query_
       db
       [sql|
-        SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
+        SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
         FROM commands c
         LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
-        WHERE conn_id = ?
+        ORDER BY c.conn_id
       |]
-      (Only connId)
   where
+    rowConnId (Only connId :. _) = connId
+    connServers rs =
+      let connId = rowConnId $ L.head rs
+          srvs = L.map (\(_ :. r) -> smpServer r) rs
+       in if connId `S.member` conns then Just (connId, srvs) else Nothing
     smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
+    conns = S.fromList connIds
+
+getAllPendingCommandConns :: DB.Connection -> IO [(ConnId, Maybe SMPServer)]
+getAllPendingCommandConns db =
+  map toResult
+    <$> DB.query_
+      db
+      [sql|
+        SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash)
+        FROM commands c
+        JOIN connections cs ON c.conn_id = cs.conn_id
+        LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
+        WHERE cs.deleted = 0
+      |]
+  where
+    toResult (connId, host, port, keyHash) = (connId, SMPServer <$> host <*> port <*> keyHash)
 
 getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
 getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
@@ -1381,7 +1420,8 @@ deleteCommand db cmdId =
   DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
 
 createNtfToken :: DB.Connection -> NtfToken -> IO ()
-createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
+createNtfToken db NtfToken {deviceToken, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
+  let (provider, token) = deviceTokenFields deviceToken
   upsertNtfServer_ db srv
   DB.execute
     db
@@ -1408,10 +1448,12 @@ getSavedNtfToken db = do
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
+          deviceToken = deviceToken' provider dt
+       in NtfToken {deviceToken, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
 updateNtfTokenRegistration :: DB.Connection -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> IO ()
-updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do
+updateNtfTokenRegistration db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1423,8 +1465,10 @@ updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token
     (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO ()
-updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} (DeviceToken toProvider toToken) = do
+updateDeviceToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} toDt = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
+  let (toProvider, toToken) = deviceTokenFields toDt
   DB.execute
     db
     [sql|
@@ -1435,7 +1479,8 @@ updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServ
     (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO ()
-updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do
+updateNtfMode db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} ntfMode = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1447,7 +1492,8 @@ updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer =
     (ntfMode, updatedAt, provider, token, host, port)
 
 updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
-updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do
+updateNtfToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do
+  let (provider, token) = deviceTokenFields deviceToken
   updatedAt <- getCurrentTime
   DB.execute
     db
@@ -1459,7 +1505,8 @@ updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
     (tknStatus, tknAction, updatedAt, provider, token, host, port)
 
 removeNtfToken :: DB.Connection -> NtfToken -> IO ()
-removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} =
+removeNtfToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} = do
+  let (provider, token) = deviceTokenFields deviceToken
   DB.execute
     db
     [sql|
@@ -1784,7 +1831,8 @@ getActiveNtfToken db =
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
+          deviceToken = deviceToken' provider dt
+       in NtfToken {deviceToken, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
 
 getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime))
 getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
@@ -1956,8 +2004,8 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue
-insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> SubscriptionMode -> Maybe C.KeyHash -> IO RcvQueue
+insertRcvQueue_ db connId' rq@RcvQueue {..} subMode serverKeyHash_ = do
   -- to preserve ID if the queue already exists.
   -- possibly, it can be done in one query.
   currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId)
@@ -1967,19 +2015,20 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
     [sql|
       INSERT INTO rcv_queues
         ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
-          snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
+          snd_id, queue_mode, status, to_subscribe, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
           link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
           ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
-        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
+        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
     ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
-        :. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
+        :. (sndId, queueMode, status, BI toSubscribe, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
         :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
         :. ntfCredsFields
     )
   -- TODO [certs rcv] save client service
   pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
   where
+    toSubscribe = subMode == SMOnlyCreate
     ntfCredsFields = case clientNtfCreds of
       Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
         (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
@@ -1997,16 +2046,15 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
     db
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, queue_mode, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret,
+        (host, port, snd_id, queue_mode, conn_id, snd_private_key, e2e_pub_key, e2e_dh_secret,
          status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash)
-      VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+      VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
       ON CONFLICT (host, port, snd_id) DO UPDATE SET
         host=EXCLUDED.host,
         port=EXCLUDED.port,
         snd_id=EXCLUDED.snd_id,
         queue_mode=EXCLUDED.queue_mode,
         conn_id=EXCLUDED.conn_id,
-        snd_public_key=EXCLUDED.snd_public_key,
         snd_private_key=EXCLUDED.snd_private_key,
         e2e_pub_key=EXCLUDED.e2e_pub_key,
         e2e_dh_secret=EXCLUDED.e2e_dh_secret,
@@ -2017,7 +2065,7 @@ 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', sndPrivateKey, e2ePubKey, e2eDhSecret)
     :. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
   pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
 
@@ -2025,8 +2073,108 @@ newQueueId_ :: [Only Int64] -> DBEntityId
 newQueueId_ [] = DBEntityId 1
 newQueueId_ (Only maxId : _) = DBEntityId (maxId + 1)
 
+-- * subscribe all connections
+
+getClientNotices :: DB.Connection -> [SMPServer] -> IO (Map (Maybe SMPServer) (Maybe SystemSeconds))
+getClientNotices db presetSrvs =
+  M.map expiresAt . foldl' addNotice M.empty
+    <$> DB.query_
+      db
+      [sql|
+        SELECT n.host, n.port, n.entity_id, COALESCE(n.server_key_hash, s.key_hash), n.created_at, n.notice_ttl
+        FROM client_notices n
+        JOIN servers s ON n.host = s.host AND n.port = s.port
+        WHERE n.protocol = 'smp'
+      |]
+  where
+    expiresAt (createdAt, ttl)  = RoundedSystemTime . (createdAt +) <$> ttl
+    addNotice ::
+      Map (Maybe SMPServer) (Int64, Maybe Int64) ->
+      (NonEmpty TransportHost, ServiceName, RecipientId, C.KeyHash, Int64, Maybe Int64) ->
+      Map (Maybe SMPServer) (Int64, Maybe Int64)
+    addNotice m (host, port, _, keyHash, createdAt', ttl') =
+      let srv = SMPServer host port keyHash
+          srvKey
+            | isPresetServer srv presetSrvs = Nothing
+            | otherwise = Just srv
+       in M.alter (Just . addNoticeHost) srvKey m
+      where
+        -- sum of ttls starting from the latest createdAt
+        addNoticeHost :: Maybe (Int64, Maybe Int64) -> (Int64, Maybe Int64)
+        addNoticeHost = \case
+          Just (createdAt, ttl) -> (max createdAt createdAt', (+) <$> ttl <*> ttl')
+          Nothing -> (createdAt', ttl')
+
+updateClientNotices :: DB.Connection -> SMPTransportSession -> SystemSeconds -> [(RcvQueueSub, Maybe ClientNotice)] -> IO [(RecipientId, Maybe NoticeId)]
+updateClientNotices db (_, srv, _) now =
+  mapM $ \(rq, notice_) -> maybe (deleteNotice rq) (upsertNotice rq) notice_
+  where
+    deleteNotice RcvQueueSub {rcvId, clientNoticeId} = do
+      mapM_ (DB.execute db "DELETE FROM client_notices WHERE client_notice_id = ?" . Only) clientNoticeId
+      pure (rcvId, Nothing)
+    upsertNotice RcvQueueSub {rcvId, server} ClientNotice {ttl} =
+      getServerKeyHash_ db server >>= \case
+        Left _ -> pure (rcvId, Nothing)
+        Right keyHash_ -> do
+          noticeId_ <-
+            maybeFirstRow fromOnly $
+              DB.query
+                db
+                [sql|
+                  INSERT INTO client_notices(protocol, host, port, entity_id, server_key_hash, notice_ttl, created_at, updated_at)
+                    VALUES ('smp',?,?,?,?,?,?,?)
+                  ON CONFLICT (protocol, host, port, entity_id)
+                  DO UPDATE SET
+                    server_key_hash = EXCLUDED.server_key_hash,
+                    notice_ttl = EXCLUDED.notice_ttl,
+                    updated_at = EXCLUDED.updated_at
+                  RETURNING client_notice_id
+                |]
+                (host srv, port srv, rcvId, keyHash_, ttl, now, now)
+          forM_ noticeId_ $ \noticeId -> do
+            DB.execute
+              db
+              "UPDATE rcv_queues SET client_notice_id = ? WHERE host = ? AND port = ?AND rcv_id = ?"
+              (noticeId, host srv, port srv, rcvId)
+          pure (rcvId, noticeId_)
+
+getSubscriptionServers :: DB.Connection -> Bool -> IO [(UserId, SMPServer)]
+getSubscriptionServers db onlyNeeded =
+  map toUserServer <$> DB.query_ db (select <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0")
+  where
+    select =
+      [sql|
+        SELECT DISTINCT c.user_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash)
+        FROM rcv_queues q
+        JOIN servers s ON q.host = s.host AND q.port = s.port
+        JOIN connections c ON q.conn_id = c.conn_id
+      |]
+    toSubscribe
+      | onlyNeeded = " WHERE q.to_subscribe = 1 AND "
+      | otherwise = " WHERE "
+    toUserServer :: (UserId, NonEmpty TransportHost, ServiceName, C.KeyHash) -> (UserId, SMPServer)
+    toUserServer (userId, host, port, keyHash) = (userId, SMPServer host port keyHash)
+
+getUserServerRcvQueueSubs :: DB.Connection -> UserId -> SMPServer -> Bool -> IO [RcvQueueSub]
+getUserServerRcvQueueSubs db userId srv onlyNeeded =
+  map toRcvQueueSub
+    <$> DB.query
+      db
+      (rcvQueueSubQuery <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0 AND c.user_id = ? AND q.host = ? AND q.port = ?")
+      (userId, host srv, port srv)
+  where
+    toSubscribe
+      | onlyNeeded = " WHERE q.to_subscribe = 1 AND "
+      | otherwise = " WHERE "
+
+unsetQueuesToSubscribe :: DB.Connection -> IO ()
+unsetQueuesToSubscribe db = DB.execute_ db "UPDATE rcv_queues SET to_subscribe = 0 WHERE to_subscribe = 1"
+
 -- * getConn helpers
 
+getConnIds :: DB.Connection -> IO [ConnId]
+getConnIds db = map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted = 0"
+
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getConn = getAnyConn False
 {-# INLINE getConn #-}
@@ -2036,52 +2184,138 @@ getDeletedConn = getAnyConn True
 {-# INLINE getDeletedConn #-}
 
 getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getAnyConn deleted' dbConn connId =
-  getConnData dbConn connId >>= \case
+getAnyConn = getAnyConn_ getRcvQueuesByConnId_ getSndQueuesByConnId_
+{-# INLINE getAnyConn #-}
+
+getAnyConn_ ::
+  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty rq))) ->
+  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty sq))) ->
+  (Bool -> DB.Connection -> ConnId -> IO (Either StoreError (SomeConn' rq sq)))
+getAnyConn_ getRQs getSQs deleted' db connId =
+  getConnData deleted' db connId >>= \case
+    Just (cData, cMode) -> do
+      rQ <- getRQs db connId
+      sQ <- getSQs db connId
+      pure $ case (rQ, sQ, cMode) of
+        (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
+        (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
+        (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
+        (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
+        (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
+        _ -> Left SEConnNotFound
     Nothing -> pure $ Left SEConnNotFound
-    Just (cData@ConnData {deleted}, cMode)
-      | deleted /= deleted' -> pure $ Left SEConnNotFound
-      | otherwise -> do
-          rQ <- getRcvQueuesByConnId_ dbConn connId
-          sQ <- getSndQueuesByConnId_ dbConn connId
-          pure $ case (rQ, sQ, cMode) of
-            (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
-            (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
-            (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
-            (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
-            (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
-            _ -> Left SEConnNotFound
 
 getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getConns = getAnyConns_ False
+getConns = getAnyConns False
 {-# INLINE getConns #-}
 
 getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getDeletedConns = getAnyConns_ True
+getDeletedConns = getAnyConns True
 {-# INLINE getDeletedConns #-}
 
-getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
-getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
-  where
-    handleDBError :: E.SomeException -> IO (Either StoreError SomeConn)
-    handleDBError = pure . Left . SEInternal . bshow
+#if defined(dbPostgres)
+getAnyConns :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn)]
+getAnyConns = getAnyConns_ getRcvQueuesByConnIds_ getSndQueuesByConnIds_
+{-# INLINE getAnyConns #-}
 
-getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
-getConnData db connId' =
-  maybeFirstRow cData $
+getConnSubs :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
+getConnSubs = getAnyConns_ getRcvQueueSubsByConnIds_ getSndQueuesByConnIds_ False
+{-# INLINE getConnSubs #-}
+
+getAnyConns_ ::
+  forall rq sq.
+  (DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty rq))) ->
+  (DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty sq))) ->
+  (Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn' rq sq)])
+getAnyConns_ getRQs getSQs deleted' db connIds = do
+  cs <- getConnsData_ deleted' db connIds
+  let connIds' = M.keys cs
+  rQs :: Map ConnId (NonEmpty rq) <- getRQs db connIds'
+  sQs :: Map ConnId (NonEmpty sq) <- getSQs db connIds'
+  pure $ map (result cs rQs sQs) connIds
+  where
+    result cs rQs sQs connId = case M.lookup connId cs of
+      Just (cData, cMode) -> case (M.lookup connId rQs, M.lookup connId sQs, cMode) of
+        (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
+        (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
+        (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
+        (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
+        (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
+        _ -> Left SEConnNotFound
+      Nothing -> Left SEConnNotFound
+
+getRcvQueuesByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty RcvQueue))
+getRcvQueuesByConnIds_ db connIds' =
+  toQueueMap toRcvQueue <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id IN ? AND q.deleted = 0") (Only (In connIds'))
+
+getSndQueuesByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty SndQueue))
+getSndQueuesByConnIds_ db connIds' =
+  toQueueMap toSndQueue <$> DB.query db (sndQueueQuery <> " WHERE q.conn_id IN ?") (Only (In connIds'))
+
+getRcvQueueSubsByConnIds_ :: DB.Connection -> [ConnId] -> IO (Map ConnId (NonEmpty RcvQueueSub))
+getRcvQueueSubsByConnIds_ db connIds' =
+  toQueueMap toRcvQueueSub <$> DB.query db (rcvQueueSubQuery <> " WHERE q.conn_id IN ? AND q.deleted = 0") (Only (In connIds'))
+
+toQueueMap :: SMPQueueRec q => (a -> q) -> [a] -> Map ConnId (NonEmpty q)
+toQueueMap toQueue =
+  M.fromList . map (\qs@(q :| _) -> (qConnId q, L.sortBy primaryFirst qs)) . groupOn' qConnId . sortOn qConnId . map toQueue
+
+getConnsData :: DB.Connection -> [ConnId] -> IO [Either StoreError (Maybe (ConnData, ConnectionMode))]
+getConnsData db connIds = do
+  cs <- getConnsData_ False db connIds
+  pure $ map (Right . (`M.lookup` cs)) connIds
+
+getConnsData_ :: Bool -> DB.Connection -> [ConnId] -> IO (Map ConnId (ConnData, ConnectionMode))
+getConnsData_ deleted' db connIds =
+  M.fromList . map ((\c@(ConnData {connId}, _) -> (connId, c)) . rowToConnData) <$>
     DB.query
       db
       [sql|
-        SELECT
-          user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
+        SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
           last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support
         FROM connections
-        WHERE conn_id = ?
+        WHERE conn_id IN ? AND deleted = ?
       |]
-      (Only connId')
-  where
-    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) =
-      (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode)
+      (In connIds, BI deleted')
+
+#else
+getAnyConns :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getAnyConns = getAnyConns_ getRcvQueuesByConnId_ getSndQueuesByConnId_
+{-# INLINE getAnyConns #-}
+
+getConnSubs :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConnSub]
+getConnSubs = getAnyConns_ getRcvQueueSubsByConnId_ getSndQueuesByConnId_ False
+{-# INLINE getConnSubs #-}
+
+getAnyConns_ ::
+  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty rq))) ->
+  (DB.Connection -> ConnId -> IO (Maybe (NonEmpty sq))) ->
+  (Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError (SomeConn' rq sq)])
+getAnyConns_ getRQs getSQs deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn_ getRQs getSQs deleted' db
+
+getConnsData :: DB.Connection -> [ConnId] -> IO [Either StoreError (Maybe (ConnData, ConnectionMode))]
+getConnsData db connIds = forM connIds $ E.handle handleDBError . fmap Right . getConnData False db
+
+handleDBError :: E.SomeException -> IO (Either StoreError a)
+handleDBError = pure . Left . SEInternal . bshow
+#endif
+
+getConnData :: Bool -> DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData deleted' db connId' =
+  maybeFirstRow rowToConnData $
+    DB.query
+      db
+      [sql|
+        SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
+          last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support
+        FROM connections
+        WHERE conn_id = ? AND deleted = ?
+      |]
+      (connId', BI deleted')
+
+rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport) -> (ConnData, ConnectionMode)
+rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) =
+  (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode)
 
 setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
 setConnDeleted db waitDelivery connId
@@ -2119,15 +2353,12 @@ addProcessedRatchetKeyHash db connId hash =
   DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary hash)
 
 checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
-checkRatchetKeyHashExists db connId hash = do
-  fromMaybe False
-    <$> maybeFirstRow
-      fromOnly
-      ( DB.query
-          db
-          "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
-          (connId, Binary hash)
-      )
+checkRatchetKeyHashExists db connId hash =
+  maybeFirstRow' False fromOnlyBI $
+    DB.query
+      db
+      "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
+      (connId, Binary hash)
 
 deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
 deleteRatchetKeyHashesExpired db ttl = do
@@ -2139,16 +2370,16 @@ getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue
 getRcvQueuesByConnId_ db connId =
   L.nonEmpty . sortBy primaryFirst . map toRcvQueue
     <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
-  where
-    primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
-      -- the current primary queue is ordered first, the next primary - second
-      compare (Down p) (Down p') <> compare i i'
+
+-- the current primary queue is ordered first, the next primary - second
+primaryFirst :: SMPQueueRec q => q -> q -> Ordering
+primaryFirst q q' = compare (Down (qPrimary q)) (Down (qPrimary q')) <> compare (dbReplaceQId q) (dbReplaceQId q')
 
 rcvQueueQuery :: Query
 rcvQueueQuery =
   [sql|
     SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
-      q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status,
+      q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id,
       q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
       q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
       q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data
@@ -2159,13 +2390,13 @@ rcvQueueQuery =
 
 toRcvQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, Maybe QueueMode)
-    :. (QueueStatus, DBEntityId, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
+    :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, 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
 toRcvQueue
   ( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode)
-      :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
+      :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
       :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)
       :. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_)
   ) =
@@ -2177,8 +2408,30 @@ toRcvQueue
       shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
         (Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
         _ -> Nothing
+      enableNtfs = maybe True unBI enableNtfs_
       -- TODO [certs rcv] read client service
-   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, clientService = Nothing, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
+   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, clientService = Nothing, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
+
+-- | returns all connection queue credentials, the first queue is the primary one
+getRcvQueueSubsByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueueSub))
+getRcvQueueSubsByConnId_ db connId =
+  L.nonEmpty . sortBy primaryFirst . map toRcvQueueSub
+    <$> DB.query db (rcvQueueSubQuery <> " WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
+
+rcvQueueSubQuery :: Query
+rcvQueueSubQuery =
+  [sql|
+    SELECT c.user_id, q.conn_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id,
+      q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id
+    FROM rcv_queues q
+    JOIN servers s ON q.host = s.host AND q.port = s.port
+    JOIN connections c ON q.conn_id = c.conn_id
+  |]
+
+toRcvQueueSub :: (UserId, ConnId, NonEmpty TransportHost, ServiceName, C.KeyHash, SMP.RecipientId, SMP.RcvPrivateAuthKey) :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, Int64, BoolInt, Maybe Int64) -> RcvQueueSub
+toRcvQueueSub ((userId, connId, host, port, keyHash, rcvId, rcvPrivateKey) :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId)) =
+  let enableNtfs = maybe True unBI enableNtfs_
+   in RcvQueueSub {userId, connId, server = SMPServer host port keyHash, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
 
 getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
 getRcvQueueById db connId dbRcvId =
@@ -2190,17 +2443,13 @@ getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue
 getSndQueuesByConnId_ dbConn connId =
   L.nonEmpty . sortBy primaryFirst . map toSndQueue
     <$> DB.query dbConn (sndQueueQuery <> " WHERE q.conn_id = ?") (Only connId)
-  where
-    primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
-      -- the current primary queue is ordered first, the next primary - second
-      compare (Down p) (Down p') <> compare i i'
 
 sndQueueQuery :: Query
 sndQueueQuery =
   [sql|
     SELECT
       c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.queue_mode,
-      q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
+      q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
       q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
     FROM snd_queues q
     JOIN servers s ON q.host = s.host AND q.port = s.port
@@ -2209,17 +2458,16 @@ sndQueueQuery =
 
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode)
-    :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
+    :. (SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
     :. (DBEntityId, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
   SndQueue
 toSndQueue
   ( (userId, keyHash, connId, host, port, sndId, queueMode)
-      :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status)
+      :. (sndPrivateKey, e2ePubKey, e2eDhSecret, status)
       :. (dbQueueId, BI primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
     ) =
     let server = SMPServer host port keyHash
-        sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey
-     in SndQueue {userId, connId, server, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
+     in SndQueue {userId, connId, server, sndId, queueMode, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
 
 getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
 getSndQueueById db connId dbSndId =
@@ -2528,6 +2776,7 @@ getRcvFile db rcvFileId = runExceptT $ do
               SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path
               FROM rcv_file_chunks
               WHERE rcv_file_id = ?
+              ORDER BY chunk_no ASC
             |]
             (Only rcvFileId)
       forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do
@@ -2905,8 +3154,8 @@ deleteSndFile' db sndFileId =
 
 getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool
 getSndFileDeleted db sndFileId =
-  fromMaybe True
-    <$> maybeFirstRow fromOnlyBI (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId))
+  maybeFirstRow' True fromOnlyBI $
+    DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)
 
 createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO ()
 createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId

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

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

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

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

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

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

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

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

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

@@ -8,6 +8,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251009_queue_to_subscribe
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notices
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Text, Maybe Text)]
@@ -15,7 +17,9 @@ schemaMigrations =
   [ ("20241210_initial", m20241210_initial, Nothing),
     ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
     ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
-    ("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
+    ("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete),
+    ("20251009_queue_to_subscribe", m20251009_queue_to_subscribe, Just down_m20251009_queue_to_subscribe),
+    ("20251010_client_notices", m20251010_client_notices, Just down_m20251010_client_notices)
   ]
 
 -- | The list of migrations in ascending order by date

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

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

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

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

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

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

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

@@ -1,15 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where
 
 import Data.Text (Text)
-import qualified Data.Text as T
 import Text.RawString.QQ (r)
 
 m20250702_conn_invitations_remove_cascade_delete :: Text
 m20250702_conn_invitations_remove_cascade_delete =
-  T.pack
-    [r|
+  [r|
 ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
 
 ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id DROP NOT NULL;
@@ -23,8 +22,7 @@ ALTER TABLE conn_invitations
 
 down_m20250702_conn_invitations_remove_cascade_delete :: Text
 down_m20250702_conn_invitations_remove_cascade_delete =
-  T.pack
-    [r|
+  [r|
 ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
 
 ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id SET NOT NULL;

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

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

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

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

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

@@ -27,6 +27,7 @@
 module Simplex.Messaging.Agent.Store.SQLite
   ( DBOpts (..),
     Migrations.getCurrentMigrations,
+    migrateDBSchema,
     createDBStore,
     closeDBStore,
     reopenDBStore,
@@ -57,33 +58,38 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.SQLite.Common
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
-import System.FilePath (takeDirectory)
+import System.FilePath (takeDirectory, takeFileName, (</>))
 import UnliftIO.Exception (bracketOnError, onException)
 import UnliftIO.MVar
 import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
+createDBStore opts@DBOpts {dbFilePath, dbKey, keepKey, track} migrations migrationConfig = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
   st <- connectSQLiteStore dbFilePath dbKey keepKey track
-  r <- migrateSchema st `onException` closeDBStore st
+  r <- migrateDBSchema st opts Nothing migrations migrationConfig `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
     Left e -> closeDBStore st $> Left e
   where
-    migrateSchema st =
-      let initialize = Migrations.initialize st
-          getCurrent = withTransaction st Migrations.getCurrentMigrations
-          run = Migrations.run st vacuum
-          backup = copyFile dbFilePath (dbFilePath <> ".bak")
-          dbm = DBMigrate {initialize, getCurrent, run, backup}
-       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+
+migrateDBSchema :: DBStore -> DBOpts -> Maybe Query -> [Migration] -> MigrationConfig -> IO (Either MigrationError ())
+migrateDBSchema st DBOpts {dbFilePath, vacuum} migrationsTable migrations MigrationConfig {confirm, backupPath} =
+  let initialize = Migrations.initialize st migrationsTable
+      getCurrent = withTransaction st $ Migrations.getCurrentMigrations migrationsTable
+      run = Migrations.run st migrationsTable vacuum
+      backup = mkBackup <$> backupPath
+      mkBackup bp =
+        let f = if null bp then dbFilePath else bp </> takeFileName dbFilePath
+          in copyFile dbFilePath $ f <> ".bak"
+      dbm = DBMigrate {initialize, getCurrent, run, backup}
+   in sharedMigrateSchema dbm (dbNew st) migrations confirm
 
 connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore
 connectSQLiteStore dbFilePath key keepKey track = do

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

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

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

@@ -44,6 +44,8 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251009_queue_to_subscribe
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -87,7 +89,9 @@ schemaMigrations =
     ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
     ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
     ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
-    ("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
+    ("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete),
+    ("m20251009_queue_to_subscribe", m20251009_queue_to_subscribe, Just down_m20251009_queue_to_subscribe),
+    ("m20251010_client_notices", m20251010_client_notices, Just down_m20251010_client_notices)
   ]
 
 -- | The list of migrations in ascending order by date

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

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

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

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

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

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

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

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

src/Simplex/Messaging/Agent/TRcvQueues.hs

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

src/Simplex/Messaging/Agent/TSessionSubs.hs

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

src/Simplex/Messaging/Client.hs

@@ -29,6 +29,7 @@
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
     TransportSession,
+    SMPTransportSession,
     ProtocolClient (thParams, sessionTs),
     SMPClient,
     ProxiedRelay (..),
@@ -39,6 +40,7 @@ module Simplex.Messaging.Client
     transportHost',
     transportSession',
     useWebPort,
+    isPresetDomain,
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -102,6 +104,7 @@ module Simplex.Messaging.Client
     temporaryClientError,
     smpClientServiceError,
     smpProxyError,
+    smpErrorClientNotice,
     textToHostMode,
     ServerTransmissionBatch,
     ServerTransmission (..),
@@ -156,6 +159,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -549,6 +553,8 @@ type UserId = Int64
 -- Please note that for SMP connection ID is used as entity ID, not queue ID.
 type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 
+type SMPTransportSession = TransportSession BrokerMsg
+
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
@@ -712,13 +718,16 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
               Right _ -> logWarn "SMP client unprocessed event"
 
 useWebPort :: NetworkConfig -> [HostName] -> ProtocolServer p -> Bool
-useWebPort cfg presetDomains srv = case smpWebPortServers cfg of
+useWebPort cfg presetDomains ProtocolServer {host = h :| _} = case smpWebPortServers cfg of
   SWPAll -> True
-  SWPPreset -> case srv of
-    ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
-    _ -> False
+  SWPPreset -> isPresetDomain presetDomains h
   SWPOff -> False
 
+isPresetDomain :: [HostName] -> TransportHost -> Bool
+isPresetDomain presetDomains = \case
+  THDomainName h -> any (`isSuffixOf` h) presetDomains
+  _ -> False
+
 unexpectedResponse :: Show r => r -> ProtocolClientError err
 unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
 
@@ -791,6 +800,12 @@ smpProxyError = \case
   PCECryptoError _ -> CRYPTO
   PCEIOError _ -> INTERNAL
 
+smpErrorClientNotice :: SMPClientError -> Maybe (Maybe ClientNotice)
+smpErrorClientNotice = \case
+  PCEProtocolError (BLOCKED BlockingInfo {notice}) -> Just notice
+  _ -> Nothing
+{-# INLINE smpErrorClientNotice #-}
+
 -- | Create a new SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
@@ -924,12 +939,12 @@ secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKe
 {-# INLINE secureSMPQueue #-}
 
 -- | Secure the SMP queue via sender queue ID.
-secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
-secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId
+secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO ()
+secureSndSMPQueue c nm spKey sId = okSMPCommand (SKEY $ C.toPublic spKey) c nm spKey sId
 {-# INLINE secureSndSMPQueue #-}
 
-proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY senderKey)
+proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> ExceptT SMPClientError IO (Either ProxyClientError ())
+proxySecureSndSMPQueue c nm proxiedRelay spKey sId = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY $ C.toPublic spKey)
 {-# INLINE proxySecureSndSMPQueue #-}
 
 -- | Add or update date for queue link
@@ -943,15 +958,15 @@ deleteSMPQueueLink = okSMPCommand LDEL
 {-# INLINE deleteSMPQueueLink #-}
 
 -- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
-secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
-secureGetSMPQueueLink c nm spKey lnkId senderKey =
-  sendSMPCommand c nm (Just spKey) lnkId (LKEY senderKey) >>= \case
+secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
+secureGetSMPQueueLink c nm spKey lnkId =
+  sendSMPCommand c nm (Just spKey) lnkId (LKEY $ C.toPublic spKey) >>= \case
     LNK sId d -> pure (sId, d)
     r -> throwE $ unexpectedResponse r
 
-proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
-proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey =
-  proxySMPCommand  c nm proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
+proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
+proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId =
+  proxySMPCommand  c nm proxiedRelay (Just spKey) lnkId (LKEY $ C.toPublic spKey) >>= \case
     Right (LNK sId d) -> pure $ Right (sId, d)
     Right r -> throwE $ unexpectedResponse r
     Left e -> pure $ Left e

src/Simplex/Messaging/Crypto.hs

@@ -76,6 +76,7 @@ module Simplex.Messaging.Crypto
     generateKeyPair,
     generateSignatureKeyPair,
     generateAuthKeyPair,
+    generatePrivateAuthKey,
     generateDhKeyPair,
     privateToX509,
     x509ToPublic,
@@ -86,6 +87,7 @@ module Simplex.Messaging.Crypto
     signatureKeyPair,
     publicToX509,
     encodeASNObj,
+    readECPrivateKey,
 
     -- * key encoding/decoding
     encodePubKey,
@@ -93,6 +95,10 @@ module Simplex.Messaging.Crypto
     encodePrivKey,
     decodePrivKey,
     pubKeyBytes,
+    encodeBigInt,
+    uncompressEncodePoint,
+    uncompressDecodePoint,
+    uncompressDecodePrivateNumber,
 
     -- * sign/verify
     Signature (..),
@@ -127,6 +133,7 @@ module Simplex.Messaging.Crypto
     encryptAEAD,
     decryptAEAD,
     encryptAESNoPad,
+    encryptAES128NoPad,
     decryptAESNoPad,
     authTagSize,
     randomAesKey,
@@ -209,24 +216,29 @@ import Control.Exception (Exception)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Except
-import Crypto.Cipher.AES (AES256)
+import Crypto.Cipher.AES (AES128, AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA3_256, SHA3_384, SHA256 (..), SHA512 (..), hash, hashDigestSize)
+import Crypto.Hash (Digest, SHA256 (..), SHA3_256, SHA3_384, SHA512 (..), hash, hashDigestSize)
 import qualified Crypto.KDF.HKDF as H
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+import qualified Crypto.PubKey.ECC.Types as ECC
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import qualified Crypto.PubKey.Ed448 as Ed448
 import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNew, randomBytesGenerate, withDRG)
+import qualified Crypto.Store.PKCS8 as PK
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
 import Data.ASN1.Types
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (bimap, first)
+import qualified Data.Binary as Bin
+import qualified Data.Bits as Bits
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Base64 (decode, encode)
@@ -234,13 +246,14 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Lazy (fromStrict, toStrict)
+import qualified Data.ByteString.Lazy as LB
 import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
 import qualified Data.List.NonEmpty as L
 import Data.String
 import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
-import Data.Word (Word32)
+import Data.Word (Word32, Word64)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
@@ -329,10 +342,10 @@ type PublicKeyX448 = PublicKey X448
 
 -- | GADT for private keys.
 data PrivateKey (a :: Algorithm) where
-  PrivateKeyEd25519 :: Ed25519.SecretKey -> Ed25519.PublicKey -> PrivateKey Ed25519
-  PrivateKeyEd448 :: Ed448.SecretKey -> Ed448.PublicKey -> PrivateKey Ed448
-  PrivateKeyX25519 :: X25519.SecretKey -> X25519.PublicKey -> PrivateKey X25519
-  PrivateKeyX448 :: X448.SecretKey -> X448.PublicKey -> PrivateKey X448
+  PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519
+  PrivateKeyEd448 :: Ed448.SecretKey -> PrivateKey Ed448
+  PrivateKeyX25519 :: X25519.SecretKey -> PrivateKey X25519
+  PrivateKeyX448 :: X448.SecretKey -> PrivateKey X448
 
 deriving instance Eq (PrivateKey a)
 
@@ -616,48 +629,66 @@ class CryptoPrivateKey pk where
   type PublicKeyType pk
   toPrivKey :: (forall a. AlgorithmI a => PrivateKey a -> b) -> pk -> b
   privKey :: APrivateKey -> Either String pk
+  toPublic :: pk -> PublicKeyType pk
 
 instance CryptoPrivateKey APrivateKey where
   type PublicKeyType APrivateKey = APublicKey
   toPrivKey f (APrivateKey _ k) = f k
+  {-# INLINE toPrivKey #-}
   privKey = Right
+  {-# INLINE privKey #-}
+  toPublic (APrivateKey a k) = APublicKey a (toPublic k)
+  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateSignKey where
   type PublicKeyType APrivateSignKey = APublicVerifyKey
   toPrivKey f (APrivateSignKey _ k) = f k
+  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case signatureAlgorithm a of
     Just Dict -> Right $ APrivateSignKey a k
     _ -> Left "key does not support signature algorithms"
+  toPublic (APrivateSignKey a k) = APublicVerifyKey a (toPublic k)
+  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateAuthKey where
   type PublicKeyType APrivateAuthKey = APublicAuthKey
   toPrivKey f (APrivateAuthKey _ k) = f k
+  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case authAlgorithm a of
     Just Dict -> Right $ APrivateAuthKey a k
     _ -> Left "key does not support auth algorithms"
+  toPublic (APrivateAuthKey a k) = APublicAuthKey a (toPublic k)
+  {-# INLINE toPublic #-}
 
 instance CryptoPrivateKey APrivateDhKey where
   type PublicKeyType APrivateDhKey = APublicDhKey
   toPrivKey f (APrivateDhKey _ k) = f k
+  {-# INLINE toPrivKey #-}
   privKey (APrivateKey a k) = case dhAlgorithm a of
     Just Dict -> Right $ APrivateDhKey a k
     _ -> Left "key does not support DH algorithm"
+  toPublic (APrivateDhKey a k) = APublicDhKey a (toPublic k)
+  {-# INLINE toPublic #-}
 
 instance AlgorithmI a => CryptoPrivateKey (PrivateKey a) where
   type PublicKeyType (PrivateKey a) = PublicKey a
   toPrivKey = id
+  {-# INLINE toPrivKey #-}
   privKey (APrivateKey _ k) = checkAlgorithm k
+  {-# INLINE privKey #-}
+  toPublic = publicKey
+  {-# INLINE toPublic #-}
 
 publicKey :: PrivateKey a -> PublicKey a
 publicKey = \case
-  PrivateKeyEd25519 _ k -> PublicKeyEd25519 k
-  PrivateKeyEd448 _ k -> PublicKeyEd448 k
-  PrivateKeyX25519 _ k -> PublicKeyX25519 k
-  PrivateKeyX448 _ k -> PublicKeyX448 k
+  PrivateKeyEd25519 pk -> PublicKeyEd25519 (Ed25519.toPublic pk)
+  PrivateKeyEd448 pk -> PublicKeyEd448 (Ed448.toPublic pk)
+  PrivateKeyX25519 pk -> PublicKeyX25519 (X25519.toPublic pk)
+  PrivateKeyX448 pk -> PublicKeyX448 (X448.toPublic pk)
 
 -- | Expand signature private key to a key pair.
 signatureKeyPair :: APrivateSignKey -> ASignatureKeyPair
-signatureKeyPair ak@(APrivateSignKey a k) = (APublicVerifyKey a (publicKey k), ak)
+signatureKeyPair ak@(APrivateSignKey a k) = (APublicVerifyKey a (toPublic k), ak)
 
 encodePrivKey :: CryptoPrivateKey pk => pk -> ByteString
 encodePrivKey = toPrivKey $ encodeASNObj . privateToX509
@@ -707,6 +738,9 @@ generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$
 generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
 generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g
 
+generatePrivateAuthKey :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM APrivateAuthKey
+generatePrivateAuthKey a g = APrivateAuthKey a <$> generatePrivateKey g
+
 generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair
 generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g
 
@@ -714,23 +748,19 @@ generateKeyPair :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (KeyPair a)
 generateKeyPair g = stateTVar g (`withDRG` generateKeyPair_)
 
 generateKeyPair_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (KeyPair a)
-generateKeyPair_ = case sAlgorithm @a of
-  SEd25519 ->
-    Ed25519.generateSecretKey >>= \pk ->
-      let k = Ed25519.toPublic pk
-       in pure (PublicKeyEd25519 k, PrivateKeyEd25519 pk k)
-  SEd448 ->
-    Ed448.generateSecretKey >>= \pk ->
-      let k = Ed448.toPublic pk
-       in pure (PublicKeyEd448 k, PrivateKeyEd448 pk k)
-  SX25519 ->
-    X25519.generateSecretKey >>= \pk ->
-      let k = X25519.toPublic pk
-       in pure (PublicKeyX25519 k, PrivateKeyX25519 pk k)
-  SX448 ->
-    X448.generateSecretKey >>= \pk ->
-      let k = X448.toPublic pk
-       in pure (PublicKeyX448 k, PrivateKeyX448 pk k)
+generateKeyPair_ = do
+  pk <- generatePrivateKey_
+  pure (toPublic pk, pk)
+
+generatePrivateKey :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (PrivateKey a)
+generatePrivateKey g = stateTVar g (`withDRG` generatePrivateKey_)
+
+generatePrivateKey_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (PrivateKey a)
+generatePrivateKey_ = case sAlgorithm @a of
+  SEd25519 -> PrivateKeyEd25519 <$> Ed25519.generateSecretKey
+  SEd448 -> PrivateKeyEd448 <$> Ed448.generateSecretKey
+  SX25519 -> PrivateKeyX25519 <$> X25519.generateSecretKey
+  SX448 -> PrivateKeyX448 <$> X448.generateSecretKey
 
 instance ToField APrivateSignKey where toField = toField . Binary . encodePrivKey
 
@@ -854,8 +884,8 @@ instance SignatureSize APublicVerifyKey where
 
 instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where
   signatureSize = \case
-    PrivateKeyEd25519 _ _ -> Ed25519.signatureSize
-    PrivateKeyEd448 _ _ -> Ed448.signatureSize
+    PrivateKeyEd25519 _ -> Ed25519.signatureSize
+    PrivateKeyEd448 _ -> Ed448.signatureSize
   {-# INLINE signatureSize #-}
 
 instance SignatureAlgorithm a => SignatureSize (PublicKey a) where
@@ -1021,9 +1051,20 @@ encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag
 encryptAESNoPad key iv = encryptAEADNoPad key iv ""
 {-# INLINE encryptAESNoPad #-}
 
+-- Used to encrypt WebPush notifications
+-- This function requires 12 bytes IV, it does not transform IV.
+encryptAES128NoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAES128NoPad key iv = encryptAEAD128NoPad key iv ""
+{-# INLINE encryptAES128NoPad #-}
+
 encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
 encryptAEADNoPad aesKey ivBytes ad msg = do
-  aead <- initAEADGCM aesKey ivBytes
+  aead <- initAEADGCM @AES256 aesKey ivBytes
+  pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
+
+encryptAEAD128NoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAEAD128NoPad aesKey ivBytes ad msg = do
+  aead <- initAEADGCM @AES128 aesKey ivBytes
   pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
 
 -- | AEAD-GCM decryption with associated data.
@@ -1045,7 +1086,7 @@ decryptAESNoPad key iv = decryptAEADNoPad key iv ""
 
 decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
 decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
-  aead <- initAEADGCM aesKey iv
+  aead <- initAEADGCM @AES256 aesKey iv
   maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg tag)
 
 maxMsgLen :: Int
@@ -1120,7 +1161,7 @@ initAEAD (Key aesKey) (IV ivBytes) = do
     AES.aeadInit AES.AEAD_GCM cipher iv
 
 -- this function requires 12 bytes IV, it does not transforms IV.
-initAEADGCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES256)
+initAEADGCM :: forall c. AES.BlockCipher c => Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
   cipher <- AES.cipherInit aesKey
   AES.aeadInit AES.AEAD_GCM cipher ivBytes
@@ -1155,8 +1196,8 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
 --
 -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages.
 sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
-sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
-sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
+sign' (PrivateKeyEd25519 pk) msg = SignatureEd25519 $ Ed25519.sign pk (Ed25519.toPublic pk) msg
+sign' (PrivateKeyEd448 pk) msg = SignatureEd448 $ Ed448.sign pk (Ed448.toPublic pk) msg
 {-# INLINE sign' #-}
 
 sign :: APrivateSignKey -> ByteString -> ASignature
@@ -1222,11 +1263,11 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
 -- | A wrapper to marshall signed ASN1 objects, like certificates.
 newtype SignedObject a = SignedObject {getSignedExact :: X.SignedExact a}
 
-instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
+instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a)
 #if defined(dbPostgres)
-  fromField f dat = SignedObject <$> blobFieldDecoder X.decodeSignedObject f dat
+  where fromField f dat = SignedObject <$> blobFieldDecoder X.decodeSignedObject f dat
 #else
-  fromField = fmap SignedObject . blobFieldDecoder X.decodeSignedObject
+  where fromField = fmap SignedObject . blobFieldDecoder X.decodeSignedObject
 #endif
 
 instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
@@ -1260,8 +1301,8 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
   _ -> False
 
 dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
-dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
-dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
+dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk) = DhSecretX25519 $ X25519.dh k pk
+dh' (PublicKeyX448 k) (PrivateKeyX448 pk) = DhSecretX448 $ X448.dh k pk
 {-# INLINE dh' #-}
 
 -- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
@@ -1465,10 +1506,10 @@ publicToX509 = \case
 
 privateToX509 :: PrivateKey a -> X.PrivKey
 privateToX509 = \case
-  PrivateKeyEd25519 k _ -> X.PrivKeyEd25519 k
-  PrivateKeyEd448 k _ -> X.PrivKeyEd448 k
-  PrivateKeyX25519 k _ -> X.PrivKeyX25519 k
-  PrivateKeyX448 k _ -> X.PrivKeyX448 k
+  PrivateKeyEd25519 k -> 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 []
@@ -1495,10 +1536,10 @@ x509ToPublic' k = x509ToPublic (k, []) >>= pubKey
 
 x509ToPrivate :: (X.PrivKey, [ASN1]) -> Either String APrivateKey
 x509ToPrivate = \case
-  (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
+  (X.PrivKeyEd25519 k, []) -> Right $ APrivateKey SEd25519 $ PrivateKeyEd25519 k
+  (X.PrivKeyEd448 k, []) -> Right $ APrivateKey SEd448 $ PrivateKeyEd448 k
+  (X.PrivKeyX25519 k, []) -> Right $ APrivateKey SX25519 $ PrivateKeyX25519 k
+  (X.PrivKeyX448 k, []) -> Right $ APrivateKey SX448 $ PrivateKeyX448 k
   r -> keyError r
 
 x509ToPrivate' :: CryptoPrivateKey k => X.PrivKey -> Either String k
@@ -1512,3 +1553,54 @@ keyError :: (a, [ASN1]) -> Either String b
 keyError = \case
   (_, []) -> Left "unknown key algorithm"
   _ -> Left "more than one key"
+
+readECPrivateKey :: FilePath -> IO ECDSA.PrivateKey
+readECPrivateKey f = do
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
+  pure ECDSA.PrivateKey {private_curve = ECC.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
+
+-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
+-- | as required by RFC8291
+-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
+uncompressEncodePoint :: ECC.Point -> ByteString
+uncompressEncodePoint (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y
+uncompressEncodePoint ECC.PointO = "\0"
+
+uncompressDecodePoint :: ByteString -> Either String ECC.Point
+uncompressDecodePoint "\0" = pure ECC.PointO
+uncompressDecodePoint s
+  | B.take 1 s /= prefix = Left "PointFormatUnsupported"
+  | B.length s /= 65 = Left "KeySizeInvalid"
+  | otherwise = do
+      let s' = B.drop 1 s
+      x <- decodeBigInt $ B.take 32 s'
+      y <- decodeBigInt $ B.drop 32 s'
+      pure $ ECC.Point x y
+  where
+    prefix = "\x04" :: ByteString
+
+-- Used to test encryption against the RFC8291 Example - which gives the AS private key
+uncompressDecodePrivateNumber :: ByteString -> Either String ECC.PrivateNumber
+uncompressDecodePrivateNumber s
+  | B.length s /= 32 = Left "KeySizeInvalid"
+  | otherwise = decodeBigInt s
+
+encodeBigInt :: Integer -> ByteString
+encodeBigInt i =
+  let s1 = Bits.shiftR i 64
+      s2 = Bits.shiftR s1 64
+      s3 = Bits.shiftR s2 64
+   in LB.toStrict $ Bin.encode (w64 s3, w64 s2, w64 s1, w64 i)
+  where
+    w64 :: Integer -> Word64
+    w64 = fromIntegral
+
+decodeBigInt :: ByteString -> Either String Integer
+decodeBigInt s
+  | B.length s /= 32 = Left "PointSizeInvalid"
+  | otherwise =
+      let (w3, w2, w1, w0) = Bin.decode (LB.fromStrict s) :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64)
+       in Right $ shift 3 w3 + shift 2 w2 + shift 1 w1 + fromIntegral w0
+  where
+    shift i w = Bits.shiftL (fromIntegral w) (64 * i)

src/Simplex/Messaging/Crypto/ShortLink.hs

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

src/Simplex/Messaging/Encoding/String.hs

@@ -10,6 +10,9 @@ module Simplex.Messaging.Encoding.String
     strToJSON,
     strToJEncoding,
     strParseJSON,
+    textToJSON,
+    textToEncoding,
+    textParseJSON,
     base64urlP,
     strEncodeList,
     strListP,
@@ -225,9 +228,22 @@ _strP = A.space *> strP
 
 strToJSON :: StrEncoding a => a -> J.Value
 strToJSON = J.String . decodeLatin1 . strEncode
+{-# INLINE strToJSON #-}
 
 strToJEncoding :: StrEncoding a => a -> J.Encoding
 strToJEncoding = JE.text . decodeLatin1 . strEncode
+{-# INLINE strToJEncoding #-}
 
 strParseJSON :: StrEncoding a => String -> J.Value -> JT.Parser a
 strParseJSON name = J.withText name $ either fail pure . parseAll strP . encodeUtf8
+
+textToJSON :: TextEncoding a => a -> J.Value
+textToJSON = J.String . textEncode
+{-# INLINE textToJSON #-}
+
+textToEncoding :: TextEncoding a => a -> J.Encoding
+textToEncoding = JE.text . textEncode
+{-# INLINE textToEncoding #-}
+
+textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
+textParseJSON name = J.withText name $ maybe (fail name) pure . textDecode

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -12,6 +12,7 @@
 module Simplex.Messaging.Notifications.Protocol where
 
 import Control.Applicative (optional, (<|>))
+import qualified Crypto.PubKey.ECC.Types as ECC
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -27,6 +28,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System
 import Data.Type.Equality
 import Data.Word (Word16)
+import Network.HTTP.Client (Request, parseUrlThrow)
 import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
@@ -372,14 +374,35 @@ instance StrEncoding SMPQueueNtf where
     notifierId <- A.char '/' *> strP
     pure SMPQueueNtf {smpServer, notifierId}
 
-data PushProvider
+data PushProvider = PPAPNS APNSProvider | PPWP WPProvider
+  deriving (Eq, Ord, Show)
+
+data APNSProvider
   = PPApnsDev -- provider for Apple development environment
   | PPApnsProd -- production environment, including TestFlight
   | PPApnsTest -- used for tests, to use APNS mock server
   | PPApnsNull -- used to test servers from the client - does not communicate with APNS
   deriving (Eq, Ord, Show)
 
+newtype WPSrvLoc = WPSrvLoc SrvLoc
+  deriving (Eq, Ord, Show)
+
+newtype WPProvider = WPP WPSrvLoc
+  deriving (Eq, Ord, Show)
+
+wpAud :: WPProvider -> B.ByteString
+wpAud (WPP (WPSrvLoc (SrvLoc aud _))) = B.pack aud
+
 instance Encoding PushProvider where
+  smpEncode = \case
+    PPAPNS p -> smpEncode p
+    PPWP p -> smpEncode p
+  smpP =
+    A.peekChar' >>= \case
+      'A' -> PPAPNS <$> smpP
+      _ -> PPWP <$> smpP
+
+instance Encoding APNSProvider where
   smpEncode = \case
     PPApnsDev -> "AD"
     PPApnsProd -> "AP"
@@ -391,9 +414,18 @@ instance Encoding PushProvider where
       "AP" -> pure PPApnsProd
       "AT" -> pure PPApnsTest
       "AN" -> pure PPApnsNull
-      _ -> fail "bad PushProvider"
+      _ -> fail "bad APNSProvider"
 
 instance StrEncoding PushProvider where
+  strEncode = \case
+    PPAPNS p -> strEncode p
+    PPWP p -> strEncode p
+  strP =
+    A.peekChar' >>= \case
+      'a' -> PPAPNS <$> strP
+      _ -> PPWP <$> strP
+
+instance StrEncoding APNSProvider where
   strEncode = \case
     PPApnsDev -> "apns_dev"
     PPApnsProd -> "apns_prod"
@@ -405,38 +437,194 @@ instance StrEncoding PushProvider where
       "apns_prod" -> pure PPApnsProd
       "apns_test" -> pure PPApnsTest
       "apns_null" -> pure PPApnsNull
-      _ -> fail "bad PushProvider"
+      _ -> fail "bad APNSProvider"
+
+instance Encoding WPSrvLoc where
+  smpEncode (WPSrvLoc srv) = smpEncode srv
+  smpP = WPSrvLoc <$> smpP
+
+instance StrEncoding WPSrvLoc where
+  strEncode (WPSrvLoc srv) = "https://" <> strEncode srv
+  strP = WPSrvLoc <$> ("https://" *> strP)
+
+instance Encoding WPProvider where
+  smpEncode (WPP srv) = "WP" <> smpEncode srv
+  smpP = WPP <$> ("WP" *> smpP)
+
+instance StrEncoding WPProvider where
+  strEncode (WPP srv) = "webpush " <> strEncode srv
+  strP = WPP <$> ("webpush " *> strP)
 
 instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
 instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
 
-data DeviceToken = DeviceToken PushProvider ByteString
+newtype WPAuth = WPAuth {unWPAuth :: ByteString} deriving (Eq, Ord, Show)
+
+toWPAuth :: ByteString -> Either String WPAuth
+toWPAuth s
+  | B.length s == 16 = Right $ WPAuth s
+  | otherwise = Left "bad WPAuth"
+
+newtype WPP256dh = WPP256dh ECC.PublicPoint
+  deriving (Eq, Show)
+
+-- This Ord instance for ECC point is quite arbitrary, it is needed because token is used as Map key
+instance Ord WPP256dh where
+  compare (WPP256dh p1) (WPP256dh p2) = case (p1, p2) of
+    (ECC.PointO, ECC.PointO) -> EQ
+    (ECC.PointO, _) -> GT
+    (_, ECC.PointO) -> LT
+    (ECC.Point x1 y1, ECC.Point x2 y2) -> compare (x1, y1) (x2, y2)
+
+data WPKey = WPKey
+  { wpAuth :: WPAuth,
+    wpP256dh :: WPP256dh
+  }
   deriving (Eq, Ord, Show)
 
+uncompressEncode :: WPP256dh -> ByteString
+uncompressEncode (WPP256dh p) = C.uncompressEncodePoint p
+{-# INLINE uncompressEncode #-}
+
+uncompressDecode :: ByteString -> Either String WPP256dh
+uncompressDecode bs = WPP256dh <$> C.uncompressDecodePoint bs
+{-# INLINE uncompressDecode #-}
+
+data WPTokenParams = WPTokenParams
+  { wpPath :: ByteString,
+    wpKey :: WPKey
+  }
+  deriving (Eq, Ord, Show)
+
+instance Encoding WPAuth where
+  smpEncode = smpEncode . unWPAuth
+  smpP = toWPAuth <$?> smpP
+
+instance StrEncoding WPAuth where
+  strEncode = strEncode . unWPAuth
+  strP = toWPAuth <$?> strP
+
+instance Encoding WPP256dh where
+  smpEncode = smpEncode . uncompressEncode
+  {-# INLINE smpEncode #-}
+  smpP = uncompressDecode <$?> smpP
+  {-# INLINE smpP #-}
+
+instance StrEncoding WPP256dh where
+  strEncode = strEncode . uncompressEncode
+  {-# INLINE strEncode #-}
+  strP = uncompressDecode <$?> strP
+  {-# INLINE strP #-}
+
+instance Encoding WPKey where
+  smpEncode WPKey {wpAuth, wpP256dh} = smpEncode (wpAuth, wpP256dh)
+  smpP = do
+    wpAuth <- smpP
+    wpP256dh <- smpP
+    pure WPKey {wpAuth, wpP256dh}
+
+instance StrEncoding WPKey where
+  strEncode WPKey {wpAuth, wpP256dh} = strEncode (wpAuth, wpP256dh)
+  strP = do
+    (wpAuth, wpP256dh) <- strP
+    pure WPKey {wpAuth, wpP256dh}
+
+instance Encoding WPTokenParams where
+  smpEncode WPTokenParams {wpPath, wpKey} = smpEncode (wpPath, wpKey)
+  smpP = do
+    wpPath <- smpP
+    wpKey <- smpP
+    pure WPTokenParams {wpPath, wpKey}
+
+instance StrEncoding WPTokenParams where
+  strEncode WPTokenParams {wpPath, wpKey} = wpPath <> " " <> strEncode wpKey
+  strP = do
+    wpPath <- A.takeWhile (/= ' ')
+    _ <- A.char ' '
+    wpKey <- strP
+    pure WPTokenParams {wpPath, wpKey}
+
+data DeviceToken
+  = APNSDeviceToken APNSProvider ByteString
+  | WPDeviceToken WPProvider WPTokenParams
+  deriving (Eq, Ord, Show)
+
+tokenPushProvider :: DeviceToken -> PushProvider
+tokenPushProvider = \case
+  APNSDeviceToken pp _ -> PPAPNS pp
+  WPDeviceToken pp _ -> PPWP pp
+
 instance Encoding DeviceToken where
-  smpEncode (DeviceToken p t) = smpEncode (p, t)
-  smpP = DeviceToken <$> smpP <*> smpP
+  smpEncode token = case token of
+    APNSDeviceToken p t -> smpEncode (p, t)
+    WPDeviceToken p t -> smpEncode (p, t)
+  smpP =
+    smpP >>= \case
+      PPAPNS p -> APNSDeviceToken p <$> smpP
+      PPWP p -> WPDeviceToken p <$> smpP
 
 instance StrEncoding DeviceToken where
-  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = nullToken <|> hexToken
+  strEncode token = case token of
+    APNSDeviceToken p t -> strEncode p <> " " <> t
+    -- We don't do strEncode (p, t), because we don't want any space between
+    -- p (e.g. webpush https://localhost) and t.wpPath (e.g /random)
+    WPDeviceToken p t -> strEncode p <> strEncode t
+  strP = nullToken <|> deviceToken
     where
-      nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token"
-      hexToken = DeviceToken <$> strP <* A.space <*> hexStringP
-      hexStringP =
+      nullToken = "apns_null test_ntf_token" $> APNSDeviceToken PPApnsNull "test_ntf_token"
+      deviceToken =
+        strP >>= \case
+          PPAPNS p -> APNSDeviceToken p <$> hexStringP
+          PPWP p -> do
+            t <- WPDeviceToken p <$> strP
+            _ <- wpRequest t
+            pure t
+      hexStringP = do
+        _ <- A.space
         A.takeWhile (`B.elem` "0123456789abcdef") >>= \s ->
           if even (B.length s) then pure s else fail "odd number of hex characters"
 
 instance ToJSON DeviceToken where
-  toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
-  toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
+  toEncoding token = case token of
+    APNSDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= decodeLatin1 t
+    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
+    WPDeviceToken p _ -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p)
+
+  -- WPDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= toJSON t
+  toJSON token = case token of
+    APNSDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= decodeLatin1 t]
+    -- ToJSON/FromJSON isn't used for WPDeviceToken, we just include the pushProvider so it can fail properly if used to decrypt
+    WPDeviceToken p _ -> J.object ["pushProvider" .= decodeLatin1 (strEncode p)]
+
+-- WPDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= toJSON t]
 
 instance FromJSON DeviceToken where
-  parseJSON = J.withObject "DeviceToken" $ \o -> do
-    pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider"
-    t <- encodeUtf8 <$> o .: "token"
-    pure $ DeviceToken pp t
+  parseJSON = J.withObject "DeviceToken" $ \o ->
+    (strDecode . encodeUtf8 <$?> o .: "pushProvider") >>= \case
+      PPAPNS p -> APNSDeviceToken p . encodeUtf8 <$> (o .: "token")
+      PPWP _ -> fail "FromJSON not implemented for WPDeviceToken"
+
+-- | Returns fields for the device token (pushProvider, token)
+-- TODO [webpush] save token as separate fields
+deviceTokenFields :: DeviceToken -> (PushProvider, ByteString)
+deviceTokenFields dt = case dt of
+  APNSDeviceToken p t -> (PPAPNS p, t)
+  WPDeviceToken p t -> (PPWP p, strEncode t)
+
+-- | Returns the device token from the fields (pushProvider, token)
+deviceToken' :: PushProvider -> ByteString -> DeviceToken
+deviceToken' pp t = case pp of
+  PPAPNS p -> APNSDeviceToken p t
+  PPWP p -> WPDeviceToken p <$> either error id $ strDecode t
+
+wpRequest :: MonadFail m => DeviceToken -> m Request
+wpRequest (APNSDeviceToken _ _) = fail "Invalid device token"
+wpRequest (WPDeviceToken (WPP s) param) = do
+  let endpoint = strEncode s <> wpPath param
+  case parseUrlThrow $ B.unpack endpoint of
+    Left _ -> fail "Invalid URL"
+    Right r -> pure r
 
 -- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
 -- because strEncode of NonEmpty list uses comma for separator,

src/Simplex/Messaging/Notifications/Server.hs

@@ -56,7 +56,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Prometheus
-import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Push (PushNotification(..), PushProviderError(..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf)
 import Simplex.Messaging.Notifications.Server.Store.Postgres
@@ -67,9 +67,9 @@ import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
-import Simplex.Messaging.Server.QueueStore (getSystemDate)
 import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats)
 import Simplex.Messaging.Session
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
@@ -629,18 +629,18 @@ showServer' = decodeLatin1 . strEncode . host
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
+  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  logDebug $ "sending push notification to " <> tshow (tokenPushProvider t)
   st <- asks store
   case ntf of
     PNVerification _ ->
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn ntf) >>= \case
         Right _ -> do
           void $ liftIO $ setTknStatusConfirmed st tkn
           incNtfStatT t ntfVrfDelivered
         Left _ -> incNtfStatT t ntfVrfFailed
     PNCheckMessages -> do
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn ntf) >>= \case
         Right _ -> do
           void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime
           incNtfStatT t ntfCronDelivered
@@ -648,7 +648,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
     PNMessage {} -> checkActiveTkn tknStatus $ do
       stats <- asks serverStats
       liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
-      liftIO (deliverNotification st pp tkn ntf) >>= \case
+      liftIO (deliverNotification st tkn ntf) >>= \case
         Left _ -> do
           incNtfStatT t ntfFailed
           liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
@@ -661,8 +661,8 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
     checkActiveTkn status action
       | status == NTActive = action
       | otherwise = liftIO $ logError "bad notification token status"
-    deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
-    deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf = do
+    deliverNotification :: NtfPostgresStore -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
+    deliverNotification st tkn@NtfTknRec {ntfTknId, token} ntf = do
       deliver <- getPushClient s pp
       runExceptT (deliver tkn ntf) >>= \case
         Right _ -> pure $ Right ()
@@ -675,7 +675,10 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
             void $ updateTknStatus st tkn $ NTInvalid $ Just r
             err e
           PPPermanentError -> err e
+          PPInvalidPusher -> err e
+          _ -> err e
       where
+        pp = tokenPushProvider token
         retryDeliver :: IO (Either PushProviderError ())
         retryDeliver = do
           deliver <- newPushClient s pp
@@ -905,7 +908,7 @@ withNtfStore stAction continue = do
     Right a -> continue a
 
 incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
-incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
+incNtfStatT (APNSDeviceToken PPApnsNull _) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 {-# INLINE incNtfStatT #-}
 

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

@@ -1,8 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -12,12 +12,15 @@ import Control.Concurrent (ThreadId)
 import Control.Logger.Simple
 import Control.Monad
 import Crypto.Random
+import Data.IORef (newIORef)
 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 qualified Data.X509.Validation as XV
+import Network.HTTP.Client (Manager, ManagerSettings (..), Request (..), newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Network.Socket
 import qualified Network.TLS as TLS
 import Numeric.Natural
@@ -25,7 +28,9 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Server.Push.WebPush (WebPushClient (..), WebPushConfig, wpPushProviderClient)
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres
@@ -57,6 +62,7 @@ data NtfServerConfig = NtfServerConfig
     pushQSize :: Natural,
     smpAgentCfg :: SMPClientAgentConfig,
     apnsConfig :: APNSPushClientConfig,
+    wpConfig :: WebPushConfig,
     subsBatchSize :: Int,
     inactiveClientExpiration :: Maybe ExpirationConfig,
     dbStoreConfig :: PostgresStoreCfg,
@@ -96,7 +102,7 @@ data NtfEnv = NtfEnv
   }
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
+newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, wpConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
   when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
   random <- C.newRandom
   store <- newNtfDbStore dbStoreConfig
@@ -112,7 +118,7 @@ newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbSt
         pure smpAgentCfg {smpCfg = (smpCfg smpAgentCfg) {serviceCredentials = Just service}}
       else pure smpAgentCfg
   subscriber <- newNtfSubscriber smpAgentCfg' random
-  pushServer <- newNtfPushServer pushQSize apnsConfig
+  pushServer <- newNtfPushServer pushQSize apnsConfig wpConfig
   serverStats <- newNtfServerStats =<< getCurrentTime
   pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
   where
@@ -149,22 +155,50 @@ data SMPSubscriber = SMPSubscriber
 data NtfPushServer = NtfPushServer
   { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
     pushClients :: TMap PushProvider PushProviderClient,
-    apnsConfig :: APNSPushClientConfig
+    apnsConfig :: APNSPushClientConfig,
+    wpConfig :: WebPushConfig
   }
 
-newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
-newNtfPushServer qSize apnsConfig = do
+newNtfPushServer :: Natural -> APNSPushClientConfig -> WebPushConfig -> IO NtfPushServer
+newNtfPushServer qSize apnsConfig wpConfig = do
   pushQ <- newTBQueueIO qSize
   pushClients <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, apnsConfig}
+  pure NtfPushServer {pushQ, pushClients, apnsConfig, wpConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  c <- case apnsProviderHost pp of
+newPushClient s pp = do
+  c <- case pp of
+    PPWP p -> newWPPushClient s p
+    PPAPNS p -> newAPNSPushClient s p
+  atomically $ TM.insert pp c $ pushClients s
+  pure c
+
+newAPNSPushClient :: NtfPushServer -> APNSProvider -> IO PushProviderClient
+newAPNSPushClient NtfPushServer {apnsConfig, pushClients} pp = do
+  case apnsProviderHost pp of
     Nothing -> pure $ \_ _ -> pure ()
     Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
-  atomically $ TM.insert pp c pushClients
-  pure c
+
+newWPPushClient :: NtfPushServer -> WPProvider -> IO PushProviderClient
+newWPPushClient NtfPushServer {wpConfig, pushClients} pp = do
+  logDebug "New WP Client requested"
+  -- We use one http manager per push server (which may be used by different clients)
+  manager <- wpHTTPManager
+  cache <- newIORef Nothing
+  random <- C.newRandom
+  let client = WebPushClient {wpConfig, cache, manager, random}
+  pure $ wpPushProviderClient client
+
+wpHTTPManager :: IO Manager
+wpHTTPManager =
+  newManager
+    tlsManagerSettings
+      { -- Ideally, we should be able to override the domain resolution to
+        -- disable requests to non-public IPs. The risk is very limited as
+        -- we allow https only, and the body is encrypted. Disabling redirections
+        -- avoids cross-protocol redir (https => http/unix)
+        managerModifyRequest = \r -> pure r {redirectCount = 0}
+      }
 
 getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 getPushClient s@NtfPushServer {pushClients} pp =

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

@@ -11,7 +11,7 @@
 module Simplex.Messaging.Notifications.Server.Main where
 
 import Control.Logger.Simple (setLogLevel)
-import Control.Monad ((<$!>))
+import Control.Monad (unless, void, (<$!>))
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
@@ -31,9 +31,10 @@ import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClie
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
-import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs)
+import Simplex.Messaging.Notifications.Server (restoreServerLastNtfs, runNtfServer)
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Notifications.Server.Push.WebPush (VapidKey (..), WebPushConfig (..), mkVapid)
 import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
 import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
 import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
@@ -55,6 +56,7 @@ import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import System.Process (readCreateProcess, shell)
 import Text.Read (readMaybe)
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
@@ -146,6 +148,7 @@ ntfServerCLI cfgPath logPath =
       clearDirIfExists logPath
       createDirectoryIfMissing True cfgPath
       createDirectoryIfMissing True logPath
+      _ <- genVapidKey vapidKeyPath
       let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
       fp <- createServerX509 cfgPath x509cfg
       let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
@@ -212,11 +215,13 @@ ntfServerCLI cfgPath logPath =
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
+      vapidKey@VapidKey {fp = vapidFp} <- getVapidKey vapidKeyPath
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@NtfServerConfig {transports} = serverConfig
+          cfg@NtfServerConfig {transports} = serverConfig vapidKey
           srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
       printServiceInfo serverVersion srv
+      B.putStrLn $ "VAPID: " <> vapidFp
       printNtfServerConfig transports dbStoreConfig
       runNtfServer cfg
       where
@@ -230,7 +235,7 @@ ntfServerCLI cfgPath logPath =
               confirmMigrations = MCYesUp,
               deletedTTL = iniDeletedTTL ini
             }
-        serverConfig =
+        serverConfig vapidKey =
           NtfServerConfig
             { transports = iniTransports ini,
               controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
@@ -258,6 +263,11 @@ ntfServerCLI cfgPath logPath =
                     persistErrorInterval = 0 -- seconds
                   },
               apnsConfig = defaultAPNSPushClientConfig,
+              wpConfig =
+                WebPushConfig
+                  { vapidKey,
+                    paddedNtfLength = 3072
+                  },
               subsBatchSize = 900,
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
@@ -294,6 +304,7 @@ ntfServerCLI cfgPath logPath =
       putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
       putStrLn "Configure notification server storage."
       exitFailure
+    vapidKeyPath = combine cfgPath "vapid.privkey"
 
 printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
 printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
@@ -350,18 +361,21 @@ cliCommandP cfgPath logPath iniFile =
     skipTokensP =
       option
         strParse
-          ( long "skip-tokens"
-              <> help "Skip tokens during import"
-              <> value S.empty
-          )
+        ( long "skip-tokens"
+            <> help "Skip tokens during import"
+            <> value S.empty
+        )
     initP :: Parser InitOptions
     initP = do
       enableStoreLog <-
-        flag' False
+        flag'
+          False
           ( long "disable-store-log"
               <> help "Disable store log for persistence (enabled by default)"
           )
-          <|> flag True True
+          <|> flag
+            True
+            True
             ( long "store-log"
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"
@@ -395,3 +409,19 @@ cliCommandP cfgPath logPath iniFile =
               <> metavar "FQDN"
           )
       pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn}
+
+genVapidKey :: FilePath -> IO VapidKey
+genVapidKey file = do
+  cfgExists <- doesFileExist file
+  unless cfgExists $ run $ "openssl ecparam -name prime256v1 -genkey -noout -out " <> file
+  key <- C.readECPrivateKey file
+  pure $ mkVapid key
+  where
+    run cmd = void $ readCreateProcess (shell cmd) ""
+
+getVapidKey :: FilePath -> IO VapidKey
+getVapidKey file = do
+  cfgExists <- doesFileExist file
+  unless cfgExists $ error $ "VAPID key not found: " <> file
+  key <- C.readECPrivateKey file
+  pure $ mkVapid key

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

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

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

@@ -10,20 +10,13 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
-import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
-import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
 import Crypto.Random (ChaChaDRG)
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
 import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -32,18 +25,15 @@ import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.Int (Int64)
 import Data.List (find)
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.System
-import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Network.HPACK.Token as HT
 import Network.HTTP.Types (Status)
@@ -53,6 +43,7 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
@@ -62,55 +53,6 @@ import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show)
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show)
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-$(JQ.deriveToJSON defaultJSON ''JWTHeader)
-
-$(JQ.deriveToJSON defaultJSON ''JWTClaims)
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
-  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
-  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
-
-data PushNotification
-  = PNVerification NtfRegCode
-  | PNMessage (NonEmpty PNMessageData)
-  | -- | PNAlert Text
-    PNCheckMessages
-  deriving (Show)
-
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show)
 
@@ -182,7 +124,7 @@ data APNSPushClientConfig = APNSPushClientConfig
     caStoreFile :: FilePath
   }
 
-apnsProviderHost :: PushProvider -> Maybe HostName
+apnsProviderHost :: APNSProvider -> Maybe HostName
 apnsProviderHost = \case
   PPApnsNull -> Nothing
   PPApnsTest -> Just "localhost"
@@ -218,9 +160,9 @@ createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
 createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
   https2Client <- newTVarIO Nothing
   void $ connectHTTPS2 apnsHost apnsCfg https2Client
-  privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
+  privateKey <- C.readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
-  let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
+  let jwtHeader = mkJWTHeader authKeyAlg (Just authKeyId)
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
   nonceDrg <- C.newRandom
   pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
@@ -236,7 +178,8 @@ getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, token
       atomically $ writeTVar jwtToken t
       pure signedJWT'
   where
-    jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
+    jwtTokenAge (JWTToken _ JWTClaims {iat = Just iat}) = subtract iat . systemSeconds <$> getSystemTime
+    jwtTokenAge (JWTToken _ JWTClaims {iat = Nothing}) = pure maxBound :: IO Int64
 
 mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
 mkApnsJWTToken appTeamId jwtHeader privateKey = do
@@ -308,24 +251,15 @@ apnsRequest c tkn ntf@APNSNotification {aps} = do
       APNSBackground {} -> "background"
       _ -> "alert"
 
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid NTInvalidReason
-  | PPRetryLater
-  | PPPermanentError
-  deriving (Show, Exception)
-
-type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
-
 -- this is not a newtype on purpose to have a correct JSON encoding as a record
 data APNSErrorResponse = APNSErrorResponse {reason :: Text}
 
 $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
 
+-- TODO [webpush] change type accept token components so it only allows APNS token
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do
+apnsPushProviderClient _ NtfTknRec {token = WPDeviceToken _ _} _ = throwE PPInvalidPusher
+apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = APNSDeviceToken _ tknStr} pn = do
   http2 <- liftHTTPS2 $ getApnsHTTP2Client c
   nonce <- atomically $ C.randomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn

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

@@ -0,0 +1,225 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+
+module Simplex.Messaging.Notifications.Server.Push.WebPush where
+
+import Control.Exception (SomeException, fromException, try)
+import Control.Logger.Simple (logDebug)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (throwE)
+import qualified Crypto.Cipher.Types as CT
+import Crypto.Hash.Algorithms (SHA256)
+import qualified Crypto.MAC.HMAC as HMAC
+import qualified Crypto.PubKey.ECC.DH as ECDH
+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+import qualified Crypto.PubKey.ECC.Types as ECC
+import Crypto.Random (ChaChaDRG, getRandomBytes)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Binary as Bin
+import qualified Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64.URL as B64
+import qualified Data.ByteString.Lazy as LB
+import Data.IORef
+import Data.Int (Int64)
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import Data.Time.Clock.System (getSystemTime, systemSeconds)
+import Network.HTTP.Client
+import qualified Network.HTTP.Types as N
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfRegCode (..), WPAuth (..), WPKey (..), WPP256dh (..), WPTokenParams (..), encodePNMessages, wpAud, wpRequest)
+import Simplex.Messaging.Notifications.Server.Push
+import Simplex.Messaging.Notifications.Server.Store.Types
+import Simplex.Messaging.Util (liftError', safeDecodeUtf8, tshow)
+import UnliftIO.STM
+
+-- | Vapid
+-- | fp: fingerprint, base64url encoded without padding
+-- | key: privkey
+data VapidKey = VapidKey
+  { key :: ECDSA.PrivateKey,
+    fp :: ByteString
+  }
+  deriving (Eq, Show)
+
+mkVapid :: ECDSA.PrivateKey -> VapidKey
+mkVapid key = VapidKey {key, fp}
+  where
+    fp = B64.encodeUnpadded $ C.uncompressEncodePoint $ ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ ECDSA.private_d key
+
+data WebPushClient = WebPushClient
+  { wpConfig :: WebPushConfig,
+    cache :: IORef (Maybe WPCache),
+    manager :: Manager,
+    random :: TVar ChaChaDRG
+  }
+
+data WebPushConfig = WebPushConfig
+  { vapidKey :: VapidKey,
+    paddedNtfLength :: Int
+  }
+
+data WPCache = WPCache
+  { vapidHeader :: ByteString,
+    expire :: Int64
+  }
+
+getVapidHeader :: VapidKey -> IORef (Maybe WPCache) -> ByteString -> IO ByteString
+getVapidHeader vapidK cache uriAuthority = do
+  h <- readIORef cache
+  now <- systemSeconds <$> getSystemTime
+  case h of
+    Nothing -> newCacheEntry now
+    -- if it expires in 1 min, then we renew - for safety
+    Just entry ->
+      if expire entry > now + 60
+        then pure $ vapidHeader entry
+        else newCacheEntry now
+  where
+    newCacheEntry :: Int64 -> IO ByteString
+    newCacheEntry now = do
+      -- The new entry expires in one hour
+      let expire = now + 3600
+      vapidHeader <- mkVapidHeader vapidK uriAuthority expire
+      let entry = Just WPCache {vapidHeader, expire}
+      atomicWriteIORef cache entry
+      pure vapidHeader
+
+-- | With time in input for the tests
+getVapidHeader' :: Int64 -> VapidKey -> IORef (Maybe WPCache) -> ByteString -> IO ByteString
+getVapidHeader' now vapidK cache uriAuthority = do
+  h <- readIORef cache
+  case h of
+    Nothing -> newCacheEntry
+    Just entry ->
+      if expire entry > now
+        then pure $ vapidHeader entry
+        else newCacheEntry
+  where
+    newCacheEntry :: IO ByteString
+    newCacheEntry = do
+      -- The new entry expires in one hour
+      let expire = now + 3600
+      vapidHeader <- mkVapidHeader vapidK uriAuthority expire
+      let entry = Just WPCache {vapidHeader, expire}
+      atomicWriteIORef cache entry
+      pure vapidHeader
+
+-- | mkVapidHeader -> vapid -> endpoint -> expire -> vapid header
+mkVapidHeader :: VapidKey -> ByteString -> Int64 -> IO ByteString
+mkVapidHeader VapidKey {key, fp} uriAuthority expire = do
+  let jwtHeader = mkJWTHeader "ES256" Nothing
+      jwtClaims =
+        JWTClaims
+          { iss = Nothing,
+            iat = Nothing,
+            exp = Just expire,
+            aud = Just $ T.decodeUtf8 $ "https://" <> uriAuthority,
+            sub = Just "https://github.com/simplex-chat/simplexmq/"
+          }
+      jwt = JWTToken jwtHeader jwtClaims
+  signedToken <- signedJWTTokenRaw key jwt
+  pure $ "vapid t=" <> signedToken <> ",k=" <> fp
+
+wpPushProviderClient :: WebPushClient -> PushProviderClient
+wpPushProviderClient _ NtfTknRec {token = APNSDeviceToken _ _} _ = throwE PPInvalidPusher
+wpPushProviderClient c@WebPushClient {wpConfig, cache, manager} tkn@NtfTknRec {token = token@(WPDeviceToken pp params)} pn = do
+  -- TODO [webpush] this function should accept type that is restricted to WP token (so, possibly WPProvider and WPTokenParams)
+  -- parsing will happen in DeviceToken parser, so it won't fail here
+  r <- wpRequest token
+  vapidH <- liftError' toPPWPError $ try $ getVapidHeader (vapidKey wpConfig) cache $ wpAud pp
+  logDebug $ "Web Push request to " <> tshow (host r)
+  encBody <- withExceptT PPCryptoError $ wpEncrypt c tkn params pn
+  let requestHeaders =
+        [ ("TTL", "2592000"), -- 30 days
+          ("Urgency", "high"),
+          ("Content-Encoding", "aes128gcm"),
+          ("Authorization", vapidH)
+          -- TODO: topic for pings and interval
+        ]
+      req =
+        r
+          { method = "POST",
+            requestHeaders,
+            requestBody = RequestBodyBS encBody,
+            redirectCount = 0
+          }
+  void $ liftError' toPPWPError $ try $ httpNoBody req manager
+
+-- | encrypt :: UA key -> clear -> cipher
+-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
+wpEncrypt :: WebPushClient -> NtfTknRec -> WPTokenParams -> PushNotification -> ExceptT C.CryptoError IO ByteString
+wpEncrypt WebPushClient {wpConfig, random} NtfTknRec {tknDhSecret} params pn = do
+  salt <- liftIO $ getRandomBytes 16
+  asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
+  pn' <-
+    LB.toStrict . J.encode <$> case pn of
+      PNVerification (NtfRegCode code) -> do
+        (nonce, code') <- encrypt code
+        pure $ J.object ["nonce" .= nonce, "verification" .= code']
+      PNMessage msgData -> do
+        (nonce, msgData') <- encrypt $ encodePNMessages msgData
+        pure $ J.object ["nonce" .= nonce, "message" .= msgData']
+      PNCheckMessages -> pure $ J.object ["checkMessages" .= True]
+  wpEncrypt' (wpKey params) asPrivK salt pn'
+  where
+    encrypt :: ByteString -> ExceptT C.CryptoError IO (C.CbNonce, Text)
+    encrypt ntfData = do
+      nonce <- atomically $ C.randomCbNonce random
+      encData <- liftEither $ C.cbEncrypt tknDhSecret nonce ntfData $ paddedNtfLength wpConfig
+      pure (nonce, safeDecodeUtf8 $ B64.encode encData)
+
+-- | encrypt :: UA key -> AS key -> salt -> clear -> cipher
+-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
+wpEncrypt' :: WPKey -> ECC.PrivateNumber -> ByteString -> ByteString -> ExceptT C.CryptoError IO ByteString
+wpEncrypt' WPKey {wpAuth, wpP256dh = WPP256dh uaPubK} asPrivK salt clearT = do
+  let uaPubKS = C.uncompressEncodePoint uaPubK
+  let asPubKS = C.uncompressEncodePoint $ ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) asPrivK
+      ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
+      prkKey = hmac (unWPAuth wpAuth) ecdhSecret
+      keyInfo = "WebPush: info\0" <> uaPubKS <> asPubKS
+      ikm = hmac prkKey (keyInfo <> "\x01")
+      prk = hmac salt ikm
+      cekInfo = "Content-Encoding: aes128gcm\0" :: ByteString
+      cek = B.take 16 $ BA.convert $ hmac prk (cekInfo <> "\x01")
+      nonceInfo = "Content-Encoding: nonce\0" :: ByteString
+      nonce = B.take 12 $ BA.convert $ hmac prk (nonceInfo <> "\x01")
+      rs = LB.toStrict $ Bin.encode (4096 :: Bin.Word32) -- with RFC8291, it's ok to always use 4096 because there is only one single record and the final record can be smaller than rs (RFC8188)
+      idlen = LB.toStrict $ Bin.encode (65 :: Bin.Word8) -- with RFC8291, keyid is the pubkey, so always 65 bytes
+      header = salt <> rs <> idlen <> asPubKS
+  iv <- liftEither $ C.gcmIV nonce
+  -- The last record uses a padding delimiter octet set to the value 0x02
+  (C.AuthTag (CT.AuthTag tag), cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
+  -- Uncomment to see intermediate values, to compare with RFC8291 example
+  -- liftIO . print $ strEncode (BA.convert ecdhSecret :: ByteString)
+  -- liftIO . print . strEncode $ B.take 32 $ BA.convert prkKey
+  -- liftIO . print $ strEncode cek
+  -- liftIO . print $ strEncode cipherT
+  pure $ header <> cipherT <> BA.convert tag
+  where
+    hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
+
+toPPWPError :: SomeException -> PushProviderError
+toPPWPError e = case fromException e of
+  Just (InvalidUrlException _ _) -> PPWPInvalidUrl
+  Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String)
+  _ -> PPWPOtherError e
+  where
+    fromStatusCode status reason
+      | status == N.status200 = PPWPRemovedEndpoint
+      | status == N.status410 = PPWPRemovedEndpoint
+      | status == N.status413 = PPWPRequestTooLong
+      | status == N.status429 = PPRetryLater
+      | status >= N.status500 = PPRetryLater
+      | otherwise = PPResponseError (Just status) (tshow reason)

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

@@ -25,7 +25,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId)
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
@@ -61,10 +61,10 @@ data NtfTknData = NtfTknData
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
     tknCronInterval :: TVar Word16,
-    tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
+    tknUpdatedAt :: TVar (Maybe SystemDate)
   }
 
-mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
+mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> SystemDate -> IO NtfTknData
 mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
   tknStatus <- newTVarIO NTRegistered
   tknCronInterval <- newTVarIO 0

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

@@ -1,18 +1,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Notifications.Server.Store.Migrations where
 
 import Data.List (sortOn)
 import Data.Text (Text)
-import qualified Data.Text as T
 import Simplex.Messaging.Agent.Store.Shared
 import Text.RawString.QQ (r)
 
 ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
 ntfServerSchemaMigrations =
   [ ("20250417_initial", m20250417_initial, Nothing),
-    ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert)
+    ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert),
+    ("20250916_webpush", m20250916_webpush, Just down_m20250916_webpush)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -23,8 +24,7 @@ ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations
 
 m20250417_initial :: Text
 m20250417_initial =
-  T.pack
-    [r|
+  [r|
 CREATE TABLE tokens(
   token_id BYTEA NOT NULL,
   push_provider TEXT NOT NULL,
@@ -79,28 +79,55 @@ CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token
 CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id);
 
 CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
-    |]
+  |]
 
 m20250517_service_cert :: Text
 m20250517_service_cert =
-  T.pack
-    [r|
+  [r|
 ALTER TABLE smp_servers ADD COLUMN ntf_service_id BYTEA;
 
 ALTER TABLE subscriptions ADD COLUMN ntf_service_assoc BOOLEAN NOT NULL DEFAULT FALSE;
 
 DROP INDEX idx_subscriptions_smp_server_id_status;
 CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON subscriptions(smp_server_id, ntf_service_assoc, status);
-    |]
+  |]
 
 down_m20250517_service_cert :: Text
 down_m20250517_service_cert =
-  T.pack
-    [r|
+  [r|
 DROP INDEX idx_subscriptions_smp_server_id_ntf_service_status;
 CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
 
 ALTER TABLE smp_servers DROP COLUMN ntf_service_id;
 
 ALTER TABLE subscriptions DROP COLUMN ntf_service_assoc;
-    |]
+  |]
+
+m20250916_webpush :: Text
+m20250916_webpush =
+  [r|
+CREATE TABLE webpush_servers(
+  wp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  wp_host TEXT NOT NULL,
+  wp_port TEXT NOT NULL,
+  wp_keyhash BYTEA NOT NULL
+);
+
+ALTER TABLE tokens
+  ADD COLUMN wp_server_id BIGINT REFERENCES webpush_servers ON DELETE RESTRICT ON UPDATE RESTRICT,
+  ADD COLUMN wp_path TEXT,
+  ADD COLUMN wp_auth BYTEA,
+  ADD COLUMN wp_key BYTEA;
+  |]
+
+down_m20250916_webpush :: Text
+down_m20250916_webpush =
+  [r|
+ALTER TABLE tokens
+  DROP COLUMN wp_server_id,
+  DROP COLUMN wp_path,
+  DROP COLUMN wp_auth,
+  DROP COLUMN wp_key;
+
+DROP TABLE webpush_servers;
+  |]

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

@@ -54,7 +54,8 @@ import Network.Socket (ServiceName)
 import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
-import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import qualified Simplex.Messaging.Crypto as C
@@ -63,12 +64,11 @@ import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubDat
 import Simplex.Messaging.Notifications.Server.Store.Migrations
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Server.StoreLog
-import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId, pattern SMPServer)
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
 import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_)
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (anyM, firstRow, maybeFirstRow, toChunks, tshow)
 import System.Exit (exitFailure)
@@ -76,6 +76,8 @@ import System.IO (IOMode (..), hFlush, stdout, withFile)
 import Text.Hex (decodeHex)
 
 #if !defined(dbPostgres)
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util (eitherToMaybe)
 #endif
 
@@ -85,7 +87,7 @@ data NtfPostgresStore = NtfPostgresStore
     deletedTTL :: Int64
   }
 
-mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> NtfTknRec
+mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> SystemDate -> NtfTknRec
 mkNtfTknRec ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhPrivKey tknDhSecret tknRegCode ts =
   NtfTknRec {ntfTknId, token, tknStatus = NTRegistered, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval = 0, tknUpdatedAt = Just ts}
 
@@ -98,7 +100,7 @@ data NtfEntityRec (e :: NtfEntity) where
 
 newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
 newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
+  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations (MigrationConfig confirmMigrations Nothing)
   dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
   pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
   where
@@ -126,8 +128,9 @@ insertNtfTknQuery =
   |]
 
 replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
-replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
+replaceNtfToken st NtfTknRec {ntfTknId, token, tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
   withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do
+    let (pp, ppToken) = deviceTokenFields token
     ExceptT $ assertUpdated <$>
       DB.execute
         db
@@ -141,7 +144,7 @@ replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken),
 
 ntfTknToRow :: NtfTknRec -> NtfTknRow
 ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
-  let DeviceToken pp ppToken = token
+  let (pp, ppToken) = deviceTokenFields token
       NtfRegCode regCode = tknRegCode
    in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)
 
@@ -151,7 +154,8 @@ getNtfToken st tknId =
     getNtfToken_ st " WHERE token_id = ?" (Only tknId)
 
 findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec))
-findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) =
+findNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) = do
+  let (pp, ppToken) = deviceTokenFields token
   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))
@@ -168,7 +172,7 @@ updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
     void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId)
     withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts
 
-type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe RoundedSystemTime)
+type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate)
 
 ntfTknQuery :: Query
 ntfTknQuery =
@@ -179,7 +183,7 @@ ntfTknQuery =
 
 rowToNtfTkn :: NtfTknRow -> NtfTknRec
 rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)  =
-  let token = DeviceToken pp ppToken
+  let token = deviceToken' pp ppToken
       tknRegCode = NtfRegCode regCode
    in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
@@ -374,8 +378,9 @@ setTknStatusConfirmed st NtfTknRec {ntfTknId} =
     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} =
+setTokenActive st tkn@NtfTknRec {ntfTknId, token} =
   withFastDB' "setTokenActive" st $ \db -> do
+    let (pp, ppToken) = deviceTokenFields token
     updateTknStatus_ st db tkn NTActive
     -- this removes other instances of the same token, e.g. because of repeated token registration attempts
     tknIds <-

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

@@ -16,7 +16,7 @@ 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)
+import Simplex.Messaging.SystemTime
 
 data NtfTknRec = NtfTknRec
   { ntfTknId :: NtfTokenId,
@@ -27,7 +27,7 @@ data NtfTknRec = NtfTknRec
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
     tknCronInterval :: Word16,
-    tknUpdatedAt :: Maybe RoundedSystemTime
+    tknUpdatedAt :: Maybe SystemDate
   }
   deriving (Show)
 

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

@@ -92,7 +92,31 @@ CREATE TABLE ntf_server.tokens (
     reg_code bytea NOT NULL,
     cron_interval bigint NOT NULL,
     cron_sent_at bigint,
-    updated_at bigint
+    updated_at bigint,
+    wp_server_id bigint,
+    wp_path text,
+    wp_auth bytea,
+    wp_key bytea
+);
+
+
+
+CREATE TABLE ntf_server.webpush_servers (
+    wp_server_id bigint NOT NULL,
+    wp_host text NOT NULL,
+    wp_port text NOT NULL,
+    wp_keyhash bytea NOT NULL
+);
+
+
+
+ALTER TABLE ntf_server.webpush_servers ALTER COLUMN wp_server_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME ntf_server.webpush_servers_wp_server_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
 );
 
 
@@ -122,6 +146,11 @@ ALTER TABLE ONLY ntf_server.tokens
 
 
 
+ALTER TABLE ONLY ntf_server.webpush_servers
+    ADD CONSTRAINT webpush_servers_pkey PRIMARY KEY (wp_server_id);
+
+
+
 CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id);
 
 
@@ -178,3 +207,8 @@ ALTER TABLE ONLY ntf_server.subscriptions
 
 
 
+ALTER TABLE ONLY ntf_server.tokens
+    ADD CONSTRAINT tokens_wp_server_id_fkey FOREIGN KEY (wp_server_id) REFERENCES ntf_server.webpush_servers(wp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT;
+
+
+

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

@@ -39,8 +39,8 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.SystemTime
 import System.IO
 
 data NtfStoreLogRecord
@@ -49,7 +49,7 @@ data NtfStoreLogRecord
   | UpdateToken NtfTokenId DeviceToken NtfRegCode
   | TokenCron NtfTokenId Word16
   | DeleteToken NtfTokenId
-  | UpdateTokenTime NtfTokenId RoundedSystemTime
+  | UpdateTokenTime NtfTokenId SystemDate
   | CreateSubscription NtfSubRec
   | SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
   | DeleteSubscription NtfSubscriptionId
@@ -103,7 +103,7 @@ logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
 logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
 logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
 
-logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
+logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> SystemDate -> IO ()
 logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
 
 logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()

src/Simplex/Messaging/Protocol.hs

@@ -217,6 +217,7 @@ import Control.Applicative (optional, (<|>))
 import Control.Exception (Exception, SomeException, displayException, fromException)
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -224,6 +225,7 @@ import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
 import Data.Char (isPrint, isSpace)
 import Data.Constraint (Dict (..))
 import Data.Functor (($>))
@@ -249,6 +251,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
+import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.ServiceScheme
 import Simplex.Messaging.Transport
@@ -1588,7 +1591,8 @@ toNetworkError e = maybe (NEConnectError err) fromTLSError (fromException e)
       _ -> NETLSError err
 
 data BlockingInfo = BlockingInfo
-  { reason :: BlockingReason
+  { reason :: BlockingReason,
+    notice :: Maybe ClientNotice
   }
   deriving (Eq, Show)
 
@@ -1596,10 +1600,12 @@ data BlockingReason = BRSpam | BRContent
   deriving (Eq, Show)
 
 instance StrEncoding BlockingInfo where
-  strEncode BlockingInfo {reason} = "reason=" <> strEncode reason
+  strEncode BlockingInfo {reason, notice} =
+    "reason=" <> strEncode reason <> maybe "" ((",notice=" <>) . LB.toStrict . J.encode) notice
   strP = do
     reason <- "reason=" *> strP
-    pure BlockingInfo {reason}
+    notice <- optional $ ",notice=" *> (J.eitherDecodeStrict <$?> A.takeByteString)
+    pure BlockingInfo {reason, notice}
 
 instance Encoding BlockingInfo where
   smpEncode = strEncode
@@ -1843,9 +1849,13 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       | otherwise -> e END_
     INFO info -> e (INFO_, ' ', info)
     OK -> e OK_
-    ERR err -> case err of
-      BLOCKED _ | v < blockedEntitySMPVersion -> e (ERR_, ' ', AUTH)
-      _ -> e (ERR_, ' ', err)
+    ERR err -> e (ERR_, ' ', err')
+      where
+        err' = case err of
+          BLOCKED info
+            | v < blockedEntitySMPVersion -> AUTH
+            | v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing}
+          _ -> err
     PONG -> e PONG_
     where
       e :: Encoding a => a -> ByteString

src/Simplex/Messaging/Protocol/Types.hs

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

src/Simplex/Messaging/Server.hs

@@ -105,7 +105,7 @@ import Simplex.Messaging.Server.Control
 import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
@@ -115,6 +115,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (foldLogLines)
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
@@ -132,12 +133,17 @@ import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
+
 #if MIN_VERSION_base(4,18,0)
 import Data.List (sort)
 import GHC.Conc (listThreads, threadStatus)
 import GHC.Conc.Sync (threadLabel)
 #endif
 
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats)
+#endif
+
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
@@ -477,7 +483,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               atomicWriteIORef (msgCount stats) stored
               atomicModifyIORef'_ (msgExpired stats) (+ expired)
               printMessageStats "STORE: messages" msgStats
-            Left e -> logError $ "STORE: withAllMsgQueues, error expiring messages, " <> tshow e
+            Left e -> logError $ "STORE: expireOldMessages, error expiring messages, " <> tshow e
 
     expireNtfsThread :: ServerConfig s -> M s ()
     expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do
@@ -987,14 +993,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                   else do
                     r <- liftIO $ runExceptT $ do
                       (q, QueueRec {status}) <- ExceptT $ getSenderQueue st qId
-                      when (status == EntityActive) $ ExceptT $ blockQueue (queueStore st) q info
-                      pure status
+                      let rId = recipientId q
+                      when (status /= EntityBlocked info) $ do
+                        ExceptT $ blockQueue (queueStore st) q info
+                        liftIO $
+                          getSubscribedClient rId (queueSubscribers $ subscribers srv)
+                            $>>= readTVarIO
+                            >>= mapM_ (\c -> atomically (writeTBQueue (sndQ c) ([(NoCorrId, rId, ERR $ BLOCKED info)] , [])))
+                      pure (status, EntityBlocked info)
                     case r of
                       Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
-                      Right EntityActive -> do
+                      Right (EntityActive, status') -> do
                         incStat $ qBlocked stats
-                        liftIO $ hPutStrLn h "ok, queue blocked"
-                      Right status -> liftIO $ hPutStrLn h $ "ok, already inactive: " <> show status
+                        liftIO $ hPutStrLn h $ "ok, queue blocked: " <> show status'
+                      Right (_, status') -> liftIO $ hPutStrLn h $ "ok, already inactive: " <> show status'
               CPUnblock qId -> withUserRole $ unliftIO u $ do
                 st <- asks msgStore
                 r <- liftIO $ runExceptT $ do
@@ -1674,7 +1686,7 @@ client
               -- This is tracked as "subscription" in the client to prevent these
               -- clients from being able to subscribe.
               pure s
-            getMessage_ :: Sub -> Maybe (MsgId, RoundedSystemTime) -> M s (Transmission BrokerMsg)
+            getMessage_ :: Sub -> Maybe (MsgId, SystemSeconds) -> M s (Transmission BrokerMsg)
             getMessage_ s delivered_ = do
               stats <- asks serverStats
               fmap (either err id) $ liftIO $ runExceptT $
@@ -1800,13 +1812,13 @@ client
                           pure (corrId, entId, maybe OK (MSG . encryptMsg qr) msg_)
                 _ -> pure $ err NO_MSG
           where
-            getDelivered :: Sub -> STM (Maybe (ServerSub, RoundedSystemTime))
+            getDelivered :: Sub -> STM (Maybe (ServerSub, SystemSeconds))
             getDelivered Sub {delivered, subThread} = do
               readTVar delivered $>>= \(msgId', ts) ->
                 if msgId == msgId' || B.null msgId
                   then writeTVar delivered Nothing $> Just (subThread, ts)
                   else pure Nothing
-            updateStats :: ServerStats -> Bool -> RoundedSystemTime -> Message -> IO ()
+            updateStats :: ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
             updateStats stats isGet deliveryTime = \case
               MessageQuota {} -> pure ()
               Message {msgFlags} -> do
@@ -2025,7 +2037,7 @@ client
             msgId' = messageId msg
             msgTs' = messageTs msg
 
-        setDelivered :: Sub -> Message -> RoundedSystemTime -> STM ()
+        setDelivered :: Sub -> Message -> SystemSeconds -> STM ()
         setDelivered Sub {delivered} msg !ts = do
           let !msgId = messageId msg
           writeTVar delivered $ Just (msgId, ts)
@@ -2104,27 +2116,42 @@ randomId = fmap EntityId . randomId'
 {-# INLINE randomId #-}
 
 saveServerMessages :: Bool -> MsgStore s -> IO ()
-saveServerMessages drainMsgs = \case
-  StoreMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
+saveServerMessages drainMsgs ms = case ms of
+  StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
     Just f -> exportMessages False ms f drainMsgs
     Nothing -> logNote "undelivered messages are not saved"
   StoreJournal _ -> logNote "closed journal message storage"
+#if defined(dbServerPostgres)
+  StoreDatabase _ -> logNote "closed postgres message storage"
+#endif
 
-exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
-exportMessages tty ms f drainMsgs = do
+exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO ()
+exportMessages tty st f drainMsgs = do
   logNote $ "saving messages to file " <> T.pack f
-  liftIO $ withFile f WriteMode $ \h ->
-    tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case
-      Right (Sum total) -> logNote $ "messages saved: " <> tshow total
+  run $ case st of
+    StoreMemory ms -> exportMessages_ ms $ getMsgs ms
+    StoreJournal ms -> exportMessages_ ms $ getJournalMsgs ms
+#if defined(dbServerPostgres)
+    StoreDatabase ms -> exportDbMessages tty ms
+#endif
+  where
+    exportMessages_ ms get = fmap (\(Sum n) -> n) . unsafeWithAllMsgQueues tty ms . saveQueueMsgs get
+    run :: (Handle -> IO Int) -> IO ()
+    run a = liftIO $ withFile f WriteMode $ tryAny . a >=> \case
+      Right n -> logNote $ "messages saved: " <> tshow n
       Left e -> do
         logError $ "error exporting messages: " <> tshow e
         exitFailure
-  where
-    saveQueueMsgs h q = do
-      msgs <-
-        unsafeRunStore q "saveQueueMsgs" $
-          getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
-      BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
+    getJournalMsgs ms q =
+      readTVarIO (msgQueue' q) >>= \case
+        Just _ -> getMsgs ms q
+        Nothing -> getJournalQueueMessages ms q
+    getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
+    getMsgs ms q = unsafeRunStore q "saveQueueMsgs" $ getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
+    saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int)
+    saveQueueMsgs get h q = do
+      msgs <- get q
+      unless (null msgs) $ BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
       pure $ Sum $ length msgs
     encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n')
 
@@ -2140,6 +2167,9 @@ processServerMessages StartOptions {skipWarnings} = do
           Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing)
           Nothing -> pure Nothing
         StoreJournal ms -> processJournalMessages old_ expire ms
+#if defined(dbServerPostgres)
+        StoreDatabase ms -> processDbMessages old_ expire ms
+#endif
       processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
       processJournalMessages old_ expire ms
         | expire = Just <$> case old_ of
@@ -2151,7 +2181,7 @@ processServerMessages StartOptions {skipWarnings} = do
               run processValidateQueue
         | otherwise = logWarn "skipping message expiration" $> Nothing
         where
-          run a = unsafeWithAllMsgQueues False False ms a `catchAny` \_ -> exitFailure
+          run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
           processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
           processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
             mq <- getMsgQueue ms q False
@@ -2162,6 +2192,17 @@ processServerMessages StartOptions {skipWarnings} = do
           processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do
             storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False
             pure newMessageStats {storedMsgsCount, storedQueues = 1}
+#if defined(dbServerPostgres)
+      processDbMessages old_ expire ms
+        | expire = Just <$> case old_ of
+            Just old -> do
+              -- TODO [messages] expire messages from all queues, not only recent
+              logNote "expiring database store messages..."
+              now <- systemSeconds <$> getSystemTime
+              expireOldMessages False ms now (now - old)
+            Nothing -> getDbMessageStats ms
+        | otherwise = logWarn "skipping message expiration" $> Nothing
+#endif
 
 importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
 importMessages tty ms f old_ skipWarnings  = do

src/Simplex/Messaging/Server/CLI.hs

@@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
-import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
+import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), dbStoreCfg, storeLogFile')
 import Simplex.Messaging.Server.Main.GitCommit
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
@@ -414,12 +414,13 @@ printServerTransports protocol ts = do
       \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
 
 printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
-printSMPServerConfig transports = \case
-  SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
-  SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile
-  SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
-    B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
-    printServerTransports "SMP" transports
+printSMPServerConfig transports st = case dbStoreCfg st of
+  Just cfg -> printDBConfig cfg
+  Nothing -> printServerConfig "SMP" transports $ storeLogFile' st
+  where
+    printDBConfig PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}} = do
+      B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
+      printServerTransports "SMP" transports
 
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

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

@@ -72,7 +72,10 @@ module Simplex.Messaging.Server.Env.STM
     defaultIdleQueueInterval,
     journalMsgStoreDepth,
     readWriteQueueStore,
+    noPostgresExitStr,
     noPostgresExit,
+    dbStoreCfg,
+    storeLogFile',
   )
 where
 
@@ -120,6 +123,7 @@ import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Server.StoreLog.ReadWrite
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP)
@@ -131,6 +135,10 @@ import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.MsgStore.Postgres
+#endif
+
 data ServerConfig s = ServerConfig
   { transports :: [(ServiceName, ASrvTransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
@@ -275,14 +283,25 @@ fromMsgStore :: MsgStore s -> s
 fromMsgStore = \case
   StoreMemory s -> s
   StoreJournal s -> s
+#if defined(dbServerPostgres)
+  StoreDatabase s -> s
+#endif
 {-# INLINE fromMsgStore #-}
 
 type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
   SupportedStore 'QSMemory 'MSMemory = ()
   SupportedStore 'QSMemory 'MSJournal = ()
-  SupportedStore 'QSPostgres 'MSJournal = ()
+  SupportedStore 'QSMemory 'MSPostgres =
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in Postgres DB with queues in memory is not supported"))
   SupportedStore 'QSPostgres 'MSMemory =
-    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported"))
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with queues in Postgres DB is not supported"))
+  SupportedStore 'QSPostgres 'MSJournal = ()
+#if defined(dbServerPostgres)
+  SupportedStore 'QSPostgres 'MSPostgres = ()
+#else
+  SupportedStore 'QSPostgres 'MSPostgres =
+    (Int ~ Bool, TypeError ('TE.Text "Server compiled without server_postgres flag"))
+#endif
 
 data AStoreType =
   forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
@@ -292,16 +311,43 @@ data ServerStoreCfg s where
   SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore
   SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory)
   SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres)
+#if defined(dbServerPostgres)
+  SSCDatabase :: PostgresStoreCfg -> ServerStoreCfg PostgresMsgStore
+#endif
+
+dbStoreCfg :: ServerStoreCfg s -> Maybe PostgresStoreCfg
+dbStoreCfg = \case
+  SSCMemory _ -> Nothing
+  SSCMemoryJournal {} -> Nothing
+  SSCDatabaseJournal {storeCfg} -> Just storeCfg
+#if defined(dbServerPostgres)
+  SSCDatabase cfg -> Just cfg
+#endif
+
+storeLogFile' :: ServerStoreCfg s -> Maybe FilePath
+storeLogFile' = \case
+  SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> Just storeLogFile
+  SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbStoreLogPath}} -> dbStoreLogPath
+#if defined(dbServerPostgres)
+  SSCDatabase (PostgresStoreCfg {dbStoreLogPath}) -> dbStoreLogPath
+#endif
 
 data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath}
 
 type family MsgStoreType (qs :: QSType) (ms :: MSType) where
   MsgStoreType 'QSMemory 'MSMemory = STMMsgStore
   MsgStoreType qs 'MSJournal = JournalMsgStore qs
+#if defined(dbServerPostgres)
+  MsgStoreType 'QSPostgres 'MSPostgres = PostgresMsgStore
+#endif
 
 data MsgStore s where
   StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
   StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
+#if defined(dbServerPostgres)
+  StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore
+#endif
 
 data Server s = Server
   { clients :: ServerClients s,
@@ -419,7 +465,7 @@ data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId)
 
 data Sub = Sub
   { subThread :: ServerSub, -- Nothing value indicates that sub
-    delivered :: TVar (Maybe (MsgId, RoundedSystemTime))
+    delivered :: TVar (Maybe (MsgId, SystemSeconds))
   }
 
 newServer :: IO (Server s)
@@ -522,6 +568,10 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
       forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms
       pure $ StoreMemory ms
     SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
+      logWarn $
+        "Journal message store is deprecated and will be removed soon.\n"
+          <> "Please migrate to in-memory storage using `journal export` command.\n"
+          <> "After that you can migrate to PostgreSQL using `database import` command."
       let qsCfg = MQStoreCfg
           cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
       ms <- newMsgStore cfg
@@ -533,8 +583,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
           qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
           cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
       when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
-      ms <- newMsgStore cfg
-      pure $ StoreJournal ms
+      StoreJournal <$> newMsgStore cfg
+    SSCDatabase storeCfg -> do
+      let StartOptions {compactLog, confirmMigrations} = startOptions config
+          cfg = PostgresMsgStoreCfg storeCfg {confirmMigrations} msgQueueQuota
+      when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
+      StoreDatabase <$> newMsgStore cfg
 #else
     SSCDatabaseJournal {} -> noPostgresExit
 #endif
@@ -628,10 +682,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
           _ -> SPMMessages
 
 noPostgresExit :: IO a
-noPostgresExit = do
-  putStrLn "Error: server binary is compiled without support for PostgreSQL database."
-  putStrLn "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
-  exitFailure
+noPostgresExit = putStrLn noPostgresExitStr >> exitFailure
+
+noPostgresExitStr :: String
+noPostgresExitStr =
+  "Error: server binary is compiled without support for PostgreSQL database.\n"
+    <> "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
 
 mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
 mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =

src/Simplex/Messaging/Server/Main.hs

@@ -18,9 +18,10 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
-import Control.Exception (finally)
+import Control.Exception (SomeException, finally, try)
 import Control.Logger.Simple
 import Control.Monad
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, toUpper)
@@ -60,11 +61,11 @@ import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupp
 import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
 import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
-import Simplex.Messaging.Util (eitherToMaybe, ifM)
+import Simplex.Messaging.Util (eitherToMaybe, ifM, unlessM)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import System.IO (BufferMode (..), IOMode (..), hSetBuffering, stderr, stdout, withFile)
 import Text.Read (readMaybe)
 
 #if defined(dbServerPostgres)
@@ -73,6 +74,7 @@ import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
 import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
 import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
 import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
+import Simplex.Messaging.Server.MsgStore.Postgres
 import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
 import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
 import Simplex.Messaging.Server.QueueStore.Types
@@ -129,6 +131,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               printMessageStats "Messages" msgStats
               putStrLn $ case readStoreType ini of
                 Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
+                Right (ASType SQSPostgres SMSPostgres) -> "store_messages set to `database`, update it to `journal` in INI file"
                 Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
                 Left e -> e <> ", configure storage correctly"
         SCExport
@@ -140,19 +143,31 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               confirmOrExit
                 ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
                 "Journal not exported"
-              ms <- newJournalMsgStore logPath MQStoreCfg
-              -- TODO [postgres] in case postgres configured, queues must be read from database
-              readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
-              exportMessages True ms storeMsgsFilePath False
-              putStrLn "Export completed"
               case readStoreType ini of
-                Right (ASType SQSMemory SMSMemory) -> putStrLn "store_messages set to `memory`, start the server."
-                Right (ASType SQSMemory SMSJournal) -> putStrLn "store_messages set to `journal`, update it to `memory` in INI file"
-                Right (ASType SQSPostgres SMSJournal) ->
+                Right (ASType SQSMemory msType) -> do
+                  ms <- newJournalMsgStore logPath MQStoreCfg
+                  readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
+                  exportMessages True (StoreJournal ms) storeMsgsFilePath False
+                  putStrLn "Export completed"
+                  putStrLn $ case msType of
+                    SMSMemory -> "store_messages set to `memory`, start the server."
+                    SMSJournal -> "store_messages set to `journal`, update it to `memory` in INI file"
 #if defined(dbServerPostgres)
+                Right (ASType SQSPostgres SMSJournal) -> do
+                  let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+                      dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
+                  unlessM (checkSchemaExists connstr schema) $ do
+                    putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+                    exitFailure
+                  ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+                  exportMessages True (StoreJournal ms) storeMsgsFilePath False
+                  putStrLn "Export completed"
                   putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
+                Right (ASType SQSPostgres SMSPostgres) -> do
+                  putStrLn $ "Messages can be exported with `dabatase export --table messages`."
+                  exitFailure
 #else
-                  noPostgresExit
+                Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
 #endif
                 Left e -> putStrLn $ e <> ", configure storage correctly"
         SCDelete
@@ -166,11 +181,32 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               deleteDirIfExists storeMsgsJournalDir
               putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
 #if defined(dbServerPostgres)
-    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+    Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
       schemaExists <- checkSchemaExists connstr schema
       storeLogExists <- doesFileExist storeLogFilePath
-      case cmd of
-        SCImport
+      msgsFileExists <- doesFileExist storeMsgsFilePath
+      case (cmd, tables) of
+        (SCImport, DTAll)
+          | not schemaExists && storeLogExists && msgsFileExists -> do
+              storeLogFile <- getRequiredStoreLogFile ini
+              confirmOrExit
+                ("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Store logs not imported"
+              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
+              putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
+              putStrLn "Importing messages..."
+              mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
+              putStrLn $ "Import completed: " <> show mCnt <> " messages"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
+                Right _ -> "set store_queues and store_messages to `database` in INI file"
+                Left e -> e <> ", configure storage correctly"
+          | otherwise -> do
+              when schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
+              unless storeLogExists $ putStrLn $ storeLogFilePath <> " file does not exist."
+              unless msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file does not exist."
+              exitFailure
+        (SCImport, DTQueues)
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
@@ -188,12 +224,48 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               putStrLn $ case readStoreType ini of
                 Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
                 Right (ASType SQSMemory SMSJournal) -> setToDbStr
-                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server."
+                Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
                 Left e -> e <> ", configure storage correctly"
           where
             setToDbStr :: String
             setToDbStr = "store_queues set to `memory`, update it to `database` in INI file"
-        SCExport
+        (SCImport, DTMessages)
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | not msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Message records not imported"
+              mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
+              putStrLn $ "Import completed: " <> show mCnt <> " messages"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
+                Right _ -> "set store_queues and store_messages to `database` in INI file"
+                Left e -> e <> ", configure storage correctly"
+        (SCExport, DTAll)
+          | schemaExists && not storeLogExists && not msgsFileExists -> do
+              confirmOrExit
+                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
+                "Database store not exported"
+              (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
+              putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
+              putStrLn "Exporting messages..."
+              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
+              ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
+              withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
+                Right mCnt -> putStrLn $ "Export completed: " <> show mCnt <> " messages"
+                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
+              closeMsgStore ms
+          | otherwise -> do
+              unless schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              when storeLogExists $ putStrLn $ storeLogFilePath <> " file already exists."
+              when msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file already exists."
+              exitFailure
+        (SCExport, DTQueues)
           | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
@@ -203,15 +275,34 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               exitFailure
           | otherwise -> do
               confirmOrExit
-                ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
                 "Queue records not exported"
               (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
               putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
               putStrLn $ case readStoreType ini of
-                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
+                Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
                 Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
                 Left e -> e <> ", configure storage correctly"
-        SCDelete
+        (SCExport, DTMessages)
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: Messages from PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to message log file " <> storeMsgsFilePath)
+                "Message records not exported"
+              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
+              ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
+              withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
+                Right mCnt -> do
+                  putStrLn $ "Export completed: " <> show mCnt <> " messages"
+                  putStrLn "Export queues with `smp-server database export queues`"
+                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
+              closeMsgStore ms
+        (SCDelete, _)
           | not schemaExists -> do
               putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
               exitFailure
@@ -245,8 +336,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
     readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
       ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
       ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
+      ("memory", "database") -> Left "Database and memory storage are not compatible."
+      ("database", "memory") -> Left "Database and memory storage are not compatible."
       ("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
-      ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
+#if defined(dbServerPostgres)
+      ("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
+#else
+      ("database", "database") -> Left noPostgresExitStr
+#endif
       (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
       where
         iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
@@ -396,6 +493,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
               storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
            in SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}
+#if defined(dbServerPostgres)
+        iniStoreCfg SQSPostgres SMSPostgres =
+          let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+              storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+           in SSCDatabase storeCfg
+#endif
         serverConfig :: ServerStoreCfg s -> ServerConfig s
         serverConfig serverStoreCfg =
           ServerConfig
@@ -505,6 +608,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       msgsFileExists <- doesFileExist storeMsgsFilePath
       storeLogExists <- doesFileExist storeLogFilePath
       case mode of
+#if defined(dbServerPostgres)
+        ASType SQSPostgres SMSPostgres
+          | msgsFileExists || msgsDirExists -> do
+              putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
+              putStrLn "Configure memory storage."
+              exitFailure
+          | otherwise -> checkDbStorage ini storeLogExists
+#endif
         ASType qs SMSJournal
           | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
           | msgsFileExists -> do
@@ -517,28 +628,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               SQSMemory ->
                 unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
 #if defined(dbServerPostgres)
-              SQSPostgres -> do
-                let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
-                schemaExists <- checkSchemaExists connstr schema
-                case enableDbStoreLog' ini of
-                  Just ()
-                    | not schemaExists -> noDatabaseSchema connstr schema
-                    | not storeLogExists -> do
-                        putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
-                        exitFailure
-                    | otherwise -> pure ()
-                  Nothing
-                    | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
-                    | storeLogExists -> do
-                        putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
-                        putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
-                        exitFailure
-                    | not schemaExists -> noDatabaseSchema connstr schema
-                    | otherwise -> pure ()
-                where
-                  noDatabaseSchema connstr schema = do
-                    putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
-                    exitFailure
+              SQSPostgres -> checkDbStorage ini storeLogExists
 #else
               SQSPostgres -> noPostgresExit
 #endif
@@ -556,6 +646,29 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       exitFailure
 
 #if defined(dbServerPostgres)
+    checkDbStorage ini storeLogExists = do
+      let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
+      schemaExists <- checkSchemaExists connstr schema
+      case enableDbStoreLog' ini of
+        Just ()
+          | not schemaExists -> noDatabaseSchema connstr schema
+          | not storeLogExists -> do
+              putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
+              exitFailure
+          | otherwise -> pure ()
+        Nothing
+          | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
+          | storeLogExists -> do
+              putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
+              putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
+              exitFailure
+          | not schemaExists -> noDatabaseSchema connstr schema
+          | otherwise -> pure ()
+      where
+        noDatabaseSchema connstr schema = do
+          putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
+          exitFailure
+
     exitConfigureQueueStore connstr schema = do
       putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
       putStrLn "Configure queue storage."
@@ -576,13 +689,28 @@ importStoreLogToDatabase logPath storeLogFile dbOpts = do
   renameFile storeLogFile $ storeLogFile <> ".bak"
   pure (sCnt, qCnt)
 
+importMessagesToDatabase :: FilePath -> DBOpts -> IO Int64
+importMessagesToDatabase msgsLogFile dbOpts = do
+  let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
+  ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
+  mCnt <- getDbMessageCount ms
+  when (mCnt > 0) $ do
+    confirmOrExit ("WARNING: the database contains messages, they will be deleted.") "Message records not imported"
+    deleteAllMessages ms
+  inserted <- batchInsertMessages True msgsLogFile $ queueStore ms
+  mCnt' <- getDbMessageCount ms
+  unless (inserted == mCnt') $ putStrLn $ "WARNING: inserted " <> show inserted <> " rows, table has " <> show mCnt' <> " messages."
+  updateQueueCounts ms
+  renameFile msgsLogFile $ msgsLogFile <> ".bak"
+  pure mCnt'
+
 exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
 exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
   let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
   ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
   sl <- openWriteStoreLog False storeLogFilePath
   Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
-  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
+  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
   closeStoreLog sl
   pure (sCnt, qCnt)
 #endif
@@ -668,10 +796,24 @@ data CliCommand
   | Start StartOptions
   | Delete
   | Journal StoreCmd
-  | Database StoreCmd DBOpts
+  | Database StoreCmd DatabaseTable DBOpts
 
 data StoreCmd = SCImport | SCExport | SCDelete
 
+data DatabaseTable = DTQueues | DTMessages | DTAll
+
+instance StrEncoding DatabaseTable where
+  strEncode = \case
+    DTQueues -> "queues"
+    DTMessages -> "messages"
+    DTAll -> "all"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "queues" -> pure DTQueues
+      "messages" -> pure DTMessages
+      "all" -> pure DTAll
+      _ -> fail "DatabaseTable"
+
 cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
@@ -680,7 +822,7 @@ cliCommandP cfgPath logPath iniFile =
         <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
         <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
-        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -834,6 +976,14 @@ cliCommandP cfgPath logPath iniFile =
             <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
             <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
         )
+    dbTableP =
+      option
+        strParse
+        ( long "table"
+            <> help "Database tables: queues/messages"
+            <> metavar "TABLE"
+            <> value DTAll
+        )
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)

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

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

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

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

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

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

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

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

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -14,14 +12,13 @@ module Simplex.Messaging.Server.QueueStore where
 import Control.Applicative (optional, (<|>))
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
-import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport (SMPServiceRole)
 #if defined(dbServerPostgres)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -40,7 +37,7 @@ data QueueRec = QueueRec
     queueData :: Maybe (LinkId, QueueLinkData),
     notifier :: Maybe NtfCreds,
     status :: ServerEntityStatus,
-    updatedAt :: Maybe RoundedSystemTime,
+    updatedAt :: Maybe SystemDate,
     rcvServiceId :: Maybe ServiceId
   }
   deriving (Show)
@@ -67,7 +64,7 @@ data ServiceRec = ServiceRec
     serviceRole :: SMPServiceRole,
     serviceCert :: X.CertificateChain,
     serviceCertHash :: XV.Fingerprint, -- SHA512 hash of long-term service client certificate. See comment for ClientHandshake.
-    serviceCreatedAt :: RoundedSystemTime
+    serviceCreatedAt :: SystemDate
   }
   deriving (Show)
 
@@ -111,22 +108,3 @@ instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherT
 
 instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
 #endif
-
-newtype RoundedSystemTime = RoundedSystemTime Int64
-  deriving (Eq, Ord, Show)
-#if defined(dbServerPostgres)
-  deriving newtype (FromField, ToField)
-#endif
-
-instance StrEncoding RoundedSystemTime where
-  strEncode (RoundedSystemTime t) = strEncode t
-  strP = RoundedSystemTime <$> strP
-
-getRoundedSystemTime :: Int64 -> IO RoundedSystemTime
-getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
-
-getSystemDate :: IO RoundedSystemTime
-getSystemDate = getRoundedSystemTime 86400
-
-getSystemSeconds :: IO RoundedSystemTime
-getSystemSeconds = RoundedSystemTime . systemSeconds <$> getSystemTime

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

@@ -25,9 +25,13 @@ module Simplex.Messaging.Server.QueueStore.Postgres
     batchInsertQueues,
     foldServiceRecs,
     foldQueueRecs,
+    foldRecentQueueRecs,
     handleDuplicate,
     withLog_,
+    withDB,
     withDB',
+    assertUpdated,
+    renderField,
   )
 where
 
@@ -70,6 +74,7 @@ import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
@@ -80,10 +85,11 @@ import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations
 import Simplex.Messaging.Server.QueueStore.STM (STMService (..), readQueueRecIO)
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPServiceRole (..))
-import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>))
+import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, maybeFirstRow', tshow, (<$$>))
 import System.Exit (exitFailure)
 import System.IO (IOMode (..), hFlush, stdout)
 import UnliftIO.STM
@@ -104,15 +110,18 @@ data PostgresQueueStore q = PostgresQueueStore
     notifiers :: TMap NotifierId RecipientId,
     notifierLocks :: TMap NotifierId Lock,
     serviceLocks :: TMap CertFingerprint Lock,
-    deletedTTL :: Int64
+    deletedTTL :: Int64,
+    useCache :: Bool
   }
 
-instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
-  type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
+type UseQueueCache = Bool
 
-  newQueueStore :: PostgresStoreCfg  -> IO (PostgresQueueStore q)
-  newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
+instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
+  type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache)
+
+  newQueueStore :: (PostgresStoreCfg, UseQueueCache)  -> IO (PostgresQueueStore q)
+  newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
     dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
     queues <- TM.emptyIO
     senders <- TM.emptyIO
@@ -120,7 +129,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     notifiers <- TM.emptyIO
     notifierLocks <- TM.emptyIO
     serviceLocks <- TM.emptyIO
-    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL}
+    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache}
     where
       err e = do
         logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -167,28 +176,35 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       void $ withDB "addQueue_" st $ \db ->
         E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr))
           >>= bimapM handleDuplicate pure
-      atomically $ TM.insert rId sq queues
-      atomically $ TM.insert (senderId qr) rId senders
-      forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
-      forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
+      when useCache $ do
+        atomically $ TM.insert rId sq queues
+        atomically $ TM.insert (senderId qr) rId senders
+        forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
+        forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
       withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
       pure sq
     where
-      PostgresQueueStore {queues, senders, links, notifiers} = st
+      PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
       -- Not doing duplicate checks in maps as the probability of duplicates is very low.
       -- It needs to be reconsidered when IDs are supplied by the users.
       -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
       -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
 
   getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
-  getQueue_ st mkQ party qId = case party of
-    SRecipient -> getRcvQueue qId
-    SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
-    SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
-    -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
-    SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
+  getQueue_ st mkQ party qId
+    | useCache = case party of
+        SRecipient -> getRcvQueue qId
+        SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
+        SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
+        -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
+        SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
+    | otherwise = case party of
+        SRecipient -> loadQueueNoCache " WHERE recipient_id = ?"
+        SSender -> loadQueueNoCache " WHERE sender_id = ?"
+        SSenderLink -> loadQueueNoCache " WHERE link_id = ?"
+        SNotifier -> loadQueueNoCache " WHERE notifier_id = ?"
     where
-      PostgresQueueStore {queues, senders, links, notifiers} = st
+      PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
       getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
       loadRcvQueue = do
         (rId, qRec) <- loadQueue " WHERE recipient_id = ?"
@@ -205,6 +221,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
         liftIO $
           TM.lookupIO rId queues -- checking recipient map first
             >>= maybe (cacheQueue rId qRec cacheSender) (atomically (cacheSender rId) $>)
+      loadQueueNoCache cond = mask $ loadQueue cond >>= liftIO . uncurry (mkQ True)
       mask = E.uninterruptibleMask_ . runExceptT
       cacheSender rId = TM.insert qId rId senders
       loadQueue condition =
@@ -227,20 +244,27 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
               pure sq
 
   getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
-  getQueues_ st mkQ party qIds = case party of
-    SRecipient -> do
-      qs <- readTVarIO queues
-      let qs' = map (\qId -> get qs qId qId) qIds
-      E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
-    SNotifier -> do
-      ns <- readTVarIO notifiers
-      qs <- readTVarIO queues
-      let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
-      E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
-        forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
-          (nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
+  getQueues_ st mkQ party qIds
+    | null qIds = pure []
+    | useCache = case party of
+        SRecipient -> do
+          qs <- readTVarIO queues
+          let qs' = map (\qId -> get qs qId qId) qIds
+          E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
+        SNotifier -> do
+          ns <- readTVarIO notifiers
+          qs <- readTVarIO queues
+          let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
+          E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
+            forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
+              (nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
+    | otherwise = E.uninterruptibleMask_ $ case party of
+        SRecipient -> loadQueuesNoCache " WHERE recipient_id IN ?" $ \(rId, qRec) ->
+          Just . (rId,) <$> mkQ False rId qRec
+        SNotifier -> loadQueuesNoCache " WHERE notifier_id IN ?" $ \(rId, qRec) ->
+          forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ False rId qRec
     where
-      PostgresQueueStore {queues, notifiers} = st
+      PostgresQueueStore {queues, notifiers, useCache} = st
       get :: M.Map QueueId a -> QueueId -> QueueId -> Either QueueId a
       get m qId = maybe (Left qId) Right . (`M.lookup` m)
       loadQueues :: [Either QueueId q] -> Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q]
@@ -249,15 +273,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
         if null qIds'
           then pure $ map (first (const INTERNAL)) qs'
           else do
-            qs_ <-
-              runExceptT $ fmap M.fromList $
-                withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
-                  >>= liftIO . fmap catMaybes . mapM (mkCacheQueue . rowToQueueRec)
+            qs_ <- dbLoadQueues qIds' cond mkCacheQueue
             pure $ map (result qs_) qs'
         where
           result :: Either ErrorType (M.Map QueueId q) -> Either QueueId q -> Either ErrorType q
           result _ (Right q) = Right q
           result qs_ (Left qId) = maybe (Left AUTH) Right . M.lookup qId =<< qs_
+      dbLoadQueues qIds' cond mkQueue' =
+        runExceptT $ fmap M.fromList $
+          withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
+            >>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec)
       cacheRcvQueue (rId, qRec) = do
         sq <- mkQ True rId qRec
         sq' <- withQueueLock sq "getQueue_" $ atomically $
@@ -266,6 +291,12 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
             Just sq' -> pure sq'
             Nothing -> sq <$ TM.insert rId sq queues
         pure $ Just (rId, sq')
+      loadQueuesNoCache cond mkQueue' = do
+        qs_ <- dbLoadQueues qIds cond mkQueue'
+        pure $ map (result qs_) qIds
+        where
+          result :: Either ErrorType (M.Map QueueId q) -> QueueId -> Either ErrorType q
+          result qs_ qId = maybe (Left AUTH) Right . M.lookup qId =<< qs_
 
   getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
   getQueueLinkData st sq lnkId = runExceptT $ do
@@ -331,19 +362,23 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
   addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
     withQueueRec sq "addQueueNotifier" $ \q ->
-      ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
-        ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do
-          assertUpdated $ withDB "addQueueNotifier" st $ \db ->
-            E.try (update db) >>= bimapM handleDuplicate pure
-          nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
-          let !q' = q {notifier = Just ntfCreds}
-          atomically $ writeTVar (queueRec sq) $ Just q'
-          -- cache queue notifier ID – after notifier is added ntf server will likely subscribe
+      checkCachedNotifier $ do
+        assertUpdated $ withDB "addQueueNotifier" st $ \db ->
+          E.try (update db) >>= bimapM handleDuplicate pure
+        nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
+        let !q' = q {notifier = Just ntfCreds}
+        atomically $ writeTVar (queueRec sq) $ Just q'
+        when useCache $ do
           atomically $ TM.insert nId rId notifiers
-          withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
-          pure nc_
+        withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
+        pure nc_
     where
-      PostgresQueueStore {notifiers} = st
+      checkCachedNotifier add
+        | useCache =
+            ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
+              ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT add
+        | otherwise = add
+      PostgresQueueStore {notifiers, useCache} = st
       rId = recipientId sq
       update db =
         DB.execute
@@ -359,13 +394,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   deleteQueueNotifier st sq =
     withQueueRec sq "deleteQueueNotifier" $ \q ->
       ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
-        withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do
+        withNotifierLock nId $ runExceptT $ do
           assertUpdated $ withDB' "deleteQueueNotifier" st update
-          atomically $ TM.delete nId $ notifiers st
+          when (useCache st) $ atomically $ TM.delete nId $ notifiers st
           atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
           withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
           pure nc
     where
+      withNotifierLock nId
+        | useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier"
+        | otherwise = id
       rId = recipientId sq
       update db =
         DB.execute
@@ -392,7 +430,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
     setStatusDB "unblockQueue" st sq EntityActive $
       withLog "unblockQueue" st (`logUnblockQueue` recipientId sq)
 
-  updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  updateQueueTime :: PostgresQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
   updateQueueTime st sq t =
     withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
       if updatedAt == Just t
@@ -408,20 +446,20 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       rId = recipientId sq
 
   -- this method is called from JournalMsgStore deleteQueue that already locks the queue
-  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType QueueRec)
   deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do
     q <- ExceptT $ readQueueRecIO qr
     RoundedSystemTime ts <- liftIO getSystemDate
     assertUpdated $ withDB' "deleteStoreQueue" st $ \db ->
       DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
     atomically $ writeTVar qr Nothing
-    atomically $ TM.delete (senderId q) $ senders st
-    forM_ (notifier q) $ \NtfCreds {notifierId} -> do
-      atomically $ TM.delete notifierId $ notifiers st
-      atomically $ TM.delete notifierId $ notifierLocks st
-    mq_ <- atomically $ swapTVar (msgQueue sq) Nothing
+    when (useCache st) $ do
+      atomically $ TM.delete (senderId q) $ senders st
+      forM_ (notifier q) $ \NtfCreds {notifierId} -> do
+        atomically $ TM.delete notifierId $ notifiers st
+        atomically $ TM.delete notifierId $ notifierLocks st
     withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
-    pure (q, mq_)
+    pure q
     where
       rId = recipientId sq
       qr = queueRec sq
@@ -487,7 +525,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   getServiceQueueCount :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
   getServiceQueueCount st party serviceId =
     E.uninterruptibleMask_ $ runExceptT $ withDB' "getServiceQueueCount" st $ \db ->
-      fmap (fromMaybe 0) $ maybeFirstRow fromOnly $
+      maybeFirstRow' 0 fromOnly $
         DB.query db query (Only serviceId)
     where
       query = case party of
@@ -545,8 +583,28 @@ foldServiceRecs st f =
     DB.fold_ db "SELECT service_id, service_role, service_cert, service_cert_hash, created_at FROM services" mempty $
       \ !acc -> fmap (acc <>) . f . rowToServiceRec
 
-foldQueueRecs :: forall a q. Monoid a => Bool -> Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
-foldQueueRecs tty withData st skipOld_ f = do
+foldQueueRecs :: Monoid a => Bool -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
+foldQueueRecs withData = foldQueueRecs_ foldRecs
+  where
+    foldRecs db acc f'
+      | withData = DB.fold_ db (queueRecQueryWithData <> cond) acc $ \acc' -> f' acc' . rowToQueueRecWithData
+      | otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec
+    cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC"
+
+foldRecentQueueRecs :: Monoid a => Int64 -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
+foldRecentQueueRecs old = foldQueueRecs_ foldRecs
+  where
+    foldRecs db acc f' = DB.fold db (queueRecQuery <> cond) (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
+    cond = " WHERE deleted_at IS NULL AND updated_at > ? ORDER BY recipient_id ASC"
+
+foldQueueRecs_ ::
+  Monoid a =>
+  (DB.Connection -> (Int, a) -> ((Int, a) -> (RecipientId, QueueRec) -> IO (Int, a)) -> IO (Int, a)) ->
+  Bool ->
+  PostgresQueueStore q ->
+  ((RecipientId, QueueRec) -> IO a) ->
+  IO a
+foldQueueRecs_ foldRecs tty st f = do
   (n, r) <- withTransaction (dbStore st) $ \db ->
     foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
       r <- f qr
@@ -557,13 +615,6 @@ foldQueueRecs tty withData st skipOld_ f = do
   when tty $ putStrLn $ progress n
   pure r
   where
-    foldRecs db acc f' = case skipOld_ of
-      Nothing
-        | withData -> DB.fold_ db (queueRecQueryWithData <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
-        | otherwise -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
-      Just old
-        | withData -> DB.fold db (queueRecQueryWithData <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
-        | otherwise -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
     progress i = "Processed: " <> show i <> " records"
 
 queueRecQuery :: Query
@@ -591,7 +642,7 @@ type QueueRecRow =
   ( RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret,
     SenderId, Maybe SndPublicAuthKey, Maybe QueueMode,
     Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, Maybe ServiceId,
-    ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId, Maybe ServiceId
+    ServerEntityStatus, Maybe SystemDate, Maybe LinkId, Maybe ServiceId
   )
 
 queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes)
@@ -627,13 +678,14 @@ queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey,
     (linkId_, queueData_) = queueDataColumns queueData
     nullable :: ToField a => Maybe a -> Builder
     nullable = maybe mempty (renderField . toField)
-    renderField :: Action -> Builder
-    renderField = \case
-      Plain bld -> bld
-      Escape s -> BB.byteString s
-      EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s
-      EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
-      Many as -> mconcat (map renderField as)
+
+renderField :: Action -> Builder
+renderField = \case
+  Plain bld -> bld
+  Escape s -> BB.byteString s
+  EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s
+  EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
+  Many as -> mconcat (map renderField as)
 
 queueDataColumns :: Maybe (LinkId, QueueLinkData) -> (Maybe LinkId, Maybe QueueLinkData)
 queueDataColumns = \case
@@ -658,11 +710,11 @@ mkNotifier (Just notifierId, Just notifierKey, Just rcvNtfDhSecret) ntfServiceId
   Just NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId}
 mkNotifier _ _ = Nothing
 
-serviceRecToRow :: ServiceRec -> (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, RoundedSystemTime)
+serviceRecToRow :: ServiceRec -> (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, SystemDate)
 serviceRecToRow ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash = XV.Fingerprint fp, serviceCreatedAt} =
   (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedAt)
 
-rowToServiceRec :: (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, RoundedSystemTime) -> ServiceRec
+rowToServiceRec :: (ServiceId, SMPServiceRole, X.CertificateChain, Binary ByteString, SystemDate) -> ServiceRec
 rowToServiceRec (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedAt) =
   ServiceRec {serviceId, serviceRole, serviceCert, serviceCertHash = XV.Fingerprint fp, serviceCreatedAt}
 
@@ -741,4 +793,8 @@ instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodeP
 instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s)
 
 deriving newtype instance FromField EncDataBytes
+
+deriving newtype instance ToField (RoundedSystemTime t)
+
+deriving newtype instance FromField (RoundedSystemTime t)
 #endif

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

@@ -1,11 +1,11 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Simplex.Messaging.Server.QueueStore.Postgres.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)
 
@@ -14,7 +14,8 @@ serverSchemaMigrations =
   [ ("20250207_initial", m20250207_initial, Nothing),
     ("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index),
     ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links),
-    ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs)
+    ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs),
+    ("20250903_store_messages", m20250903_store_messages, Just down_m20250903_store_messages)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -25,8 +26,7 @@ serverMigrations = sortOn name $ map migration serverSchemaMigrations
 
 m20250207_initial :: Text
 m20250207_initial =
-  T.pack
-    [r|
+  [r|
 CREATE TABLE msg_queues(
   recipient_id BYTEA NOT NULL,
   recipient_key BYTEA NOT NULL,
@@ -50,24 +50,21 @@ CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at);
 
 m20250319_updated_index :: Text
 m20250319_updated_index =
-  T.pack
-    [r|
+  [r|
 DROP INDEX idx_msg_queues_deleted_at;
 CREATE INDEX idx_msg_queues_updated_at ON msg_queues (deleted_at, updated_at);
     |]
 
 down_m20250319_updated_index :: Text
 down_m20250319_updated_index =
-  T.pack
-    [r|
+  [r|
 DROP INDEX idx_msg_queues_updated_at;
 CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at);
     |]
 
 m20250320_short_links :: Text
 m20250320_short_links =
-  T.pack
-    [r|
+  [r|
 ALTER TABLE msg_queues
   ADD COLUMN queue_mode TEXT,
   ADD COLUMN link_id BYTEA,
@@ -87,8 +84,7 @@ CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id);
 
 down_m20250320_short_links :: Text
 down_m20250320_short_links =
-  T.pack
-    [r|
+  [r|
 ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE;
 
 UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M';
@@ -123,8 +119,7 @@ ALTER TABLE msg_queues RENAME COLUMN recipient_keys TO recipient_key;
 
 m20250514_service_certs :: Text
 m20250514_service_certs =
-  T.pack
-    [r|
+  [r|
 CREATE TABLE services(
   service_id BYTEA NOT NULL,
   service_role TEXT NOT NULL,
@@ -146,8 +141,7 @@ CREATE INDEX idx_msg_queues_ntf_service_id ON msg_queues(ntf_service_id, deleted
 
 down_m20250514_service_certs :: Text
 down_m20250514_service_certs =
-  T.pack
-    [r|
+  [r|
 DROP INDEX idx_msg_queues_rcv_service_id;
 DROP INDEX idx_msg_queues_ntf_service_id;
 
@@ -159,3 +153,297 @@ DROP INDEX idx_services_service_role;
 
 DROP TABLE services;
     |]
+
+m20250903_store_messages :: Text
+m20250903_store_messages =
+  [r|
+CREATE TABLE messages(
+  message_id BIGINT NOT NULL PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  recipient_id BYTEA NOT NULL REFERENCES msg_queues ON DELETE CASCADE ON UPDATE RESTRICT,
+  msg_id BYTEA NOT NULL,
+  msg_ts BIGINT NOT NULL,
+  msg_quota BOOLEAN NOT NULL,
+  msg_ntf_flag BOOLEAN NOT NULL,
+  msg_body BYTEA NOT NULL
+);
+
+ALTER TABLE msg_queues
+  ADD COLUMN msg_can_write BOOLEAN NOT NULL DEFAULT TRUE,
+  ADD COLUMN msg_queue_expire BOOLEAN NOT NULL DEFAULT FALSE,
+  ADD COLUMN msg_queue_size BIGINT NOT NULL DEFAULT 0;
+
+CREATE INDEX idx_messages_recipient_id_message_id ON messages (recipient_id, message_id);
+CREATE INDEX idx_messages_recipient_id_msg_ts on messages(recipient_id, msg_ts);
+CREATE INDEX idx_messages_recipient_id_msg_quota on messages(recipient_id, msg_quota);
+
+DROP INDEX idx_msg_queues_updated_at;
+CREATE INDEX idx_msg_queues_updated_at_recipient_id ON msg_queues (deleted_at, updated_at, msg_queue_expire, recipient_id);
+
+CREATE FUNCTION write_message(
+  p_recipient_id BYTEA,
+  p_msg_id BYTEA,
+  p_msg_ts BIGINT,
+  p_msg_quota BOOLEAN,
+  p_msg_ntf_flag BOOLEAN,
+  p_msg_body BYTEA,
+  p_quota INT
+)
+RETURNS TABLE (quota_written BOOLEAN, was_empty BOOLEAN)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_can_write BOOLEAN;
+  q_size BIGINT;
+BEGIN
+  SELECT msg_can_write, msg_queue_size INTO q_can_write, q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF q_can_write OR q_size = 0 THEN
+    quota_written := p_msg_quota OR q_size >= p_quota;
+    was_empty := q_size = 0;
+
+    INSERT INTO messages(recipient_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body)
+    VALUES (p_recipient_id, p_msg_id, p_msg_ts, quota_written, p_msg_ntf_flag AND NOT quota_written, CASE WHEN quota_written THEN '' :: BYTEA ELSE p_msg_body END);
+
+    UPDATE msg_queues
+    SET msg_can_write = NOT quota_written,
+        msg_queue_expire = TRUE,
+        msg_queue_size = msg_queue_size + 1
+    WHERE recipient_id = p_recipient_id;
+
+    RETURN QUERY VALUES (quota_written, was_empty);
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION try_del_msg(p_recipient_id BYTEA, p_msg_id BYTEA)
+RETURNS TABLE (r_msg_id BYTEA, r_msg_ts BIGINT, r_msg_quota BOOLEAN, r_msg_ntf_flag BOOLEAN, r_msg_body BYTEA)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+    IF FOUND THEN
+      UPDATE msg_queues
+      SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+          msg_queue_expire = msg_queue_size > 1,
+          msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+      WHERE recipient_id = p_recipient_id;
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION try_del_peek_msg(p_recipient_id BYTEA, p_msg_id BYTEA)
+RETURNS TABLE (r_msg_id BYTEA, r_msg_ts BIGINT, r_msg_quota BOOLEAN, r_msg_ntf_flag BOOLEAN, r_msg_body BYTEA)
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  msg RECORD;
+  msg_deleted BOOLEAN;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE;
+
+  IF NOT FOUND THEN
+    RETURN;
+  END IF;
+
+  SELECT message_id, msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+  INTO msg
+  FROM messages
+  WHERE recipient_id = p_recipient_id
+  ORDER BY message_id ASC LIMIT 1;
+
+  IF NOT FOUND THEN
+    IF q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+    RETURN;
+  END IF;
+
+  IF msg.msg_id = p_msg_id THEN
+    DELETE FROM messages WHERE message_id = msg.message_id;
+
+    msg_deleted := FOUND;
+    IF msg_deleted THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+    END IF;
+
+    SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
+    INTO msg
+    FROM messages
+    WHERE recipient_id = p_recipient_id
+    ORDER BY message_id ASC LIMIT 1;
+
+    IF FOUND THEN
+      RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+      IF msg_deleted THEN
+        UPDATE msg_queues
+        SET msg_can_write = msg_can_write OR msg_queue_size <= 1,
+            msg_queue_expire = msg_queue_size > 1,
+            msg_queue_size = GREATEST(msg_queue_size - 1, 0)
+        WHERE recipient_id = p_recipient_id;
+      END IF;
+    ELSIF msg_deleted OR q_size != 0 THEN
+      UPDATE msg_queues
+      SET msg_can_write = TRUE,
+          msg_queue_expire = FALSE,
+          msg_queue_size = 0
+      WHERE recipient_id = p_recipient_id;
+    END IF;
+  ELSE
+    RETURN QUERY VALUES (msg.msg_id, msg.msg_ts, msg.msg_quota, msg.msg_ntf_flag, msg.msg_body);
+  END IF;
+END;
+$$;
+
+CREATE FUNCTION delete_expired_msgs(p_recipient_id BYTEA, p_old_ts BIGINT) RETURNS BIGINT
+LANGUAGE plpgsql AS $$
+DECLARE
+  q_size BIGINT;
+  keep_min_id BIGINT;
+  del_count BIGINT;
+BEGIN
+  SELECT msg_queue_size INTO q_size
+  FROM msg_queues
+  WHERE recipient_id = p_recipient_id AND deleted_at IS NULL
+  FOR UPDATE SKIP LOCKED;
+
+  IF NOT FOUND OR q_size = 0 THEN
+    RETURN 0;
+  END IF;
+
+  SELECT MIN(message_id) INTO keep_min_id
+  FROM messages WHERE recipient_id = p_recipient_id AND msg_ts >= p_old_ts AND msg_quota = FALSE;
+
+  IF keep_min_id IS NULL THEN
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND msg_quota = FALSE;
+  ELSE
+    DELETE FROM messages WHERE recipient_id = p_recipient_id AND message_id < keep_min_id AND msg_quota = FALSE;
+  END IF;
+
+  GET DIAGNOSTICS del_count = ROW_COUNT;
+  IF del_count > 0 THEN
+    UPDATE msg_queues
+    SET msg_can_write = msg_can_write OR msg_queue_size <= del_count,
+        msg_queue_expire = msg_queue_size > del_count AND keep_min_id IS NOT NULL,
+        msg_queue_size = GREATEST(msg_queue_size - del_count, 0)
+    WHERE recipient_id = p_recipient_id;
+  END IF;
+  RETURN del_count;
+END;
+$$;
+
+CREATE PROCEDURE expire_old_messages(
+  p_old_queue BIGINT,
+  p_old_ts BIGINT,
+  batch_size INT,
+  OUT r_expired_msgs_count BIGINT,
+  OUT r_stored_msgs_count BIGINT,
+  OUT r_stored_queues BIGINT
+)
+LANGUAGE plpgsql AS $$
+DECLARE
+  rids BYTEA[];
+  rid BYTEA;
+  last_rid BYTEA := '\x';
+  del_count BIGINT;
+  total_deleted BIGINT := 0;
+BEGIN
+  LOOP
+    SELECT array_agg(recipient_id)
+    INTO rids
+    FROM (
+      SELECT recipient_id
+      FROM msg_queues
+      WHERE deleted_at IS NULL
+        AND updated_at > p_old_queue
+        AND msg_queue_expire = TRUE
+        AND recipient_id > last_rid
+      ORDER BY recipient_id ASC
+      LIMIT batch_size
+    ) qs;
+
+    EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
+
+    FOREACH rid IN ARRAY rids
+    LOOP
+      BEGIN
+        del_count := delete_expired_msgs(rid, p_old_ts);
+        total_deleted := total_deleted + del_count;
+      EXCEPTION WHEN OTHERS THEN
+        RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
+        CONTINUE;
+      END;
+      COMMIT;
+    END LOOP;
+    last_rid := rids[cardinality(rids)];
+  END LOOP;
+
+  r_expired_msgs_count := total_deleted;
+  r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
+  r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
+END;
+$$;
+    |]
+
+down_m20250903_store_messages :: Text
+down_m20250903_store_messages =
+  [r|
+DROP FUNCTION write_message;
+DROP FUNCTION try_del_msg;
+DROP FUNCTION try_del_peek_msg;
+DROP FUNCTION delete_expired_msgs;
+DROP PROCEDURE expire_old_messages;
+
+DROP INDEX idx_msg_queues_updated_at_recipient_id;
+CREATE INDEX idx_msg_queues_updated_at ON msg_queues (deleted_at, updated_at);
+
+DROP INDEX idx_messages_recipient_id_message_id;
+DROP INDEX idx_messages_recipient_id_msg_ts;
+DROP INDEX idx_messages_recipient_id_msg_quota;
+
+ALTER TABLE msg_queues
+  DROP COLUMN msg_can_write,
+  DROP COLUMN msg_queue_expire,
+  DROP COLUMN msg_queue_size;
+
+DROP TABLE messages;
+    |]

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

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

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

@@ -41,6 +41,7 @@ import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPServiceRole (..))
@@ -228,7 +229,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
   deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
   deleteQueueNotifier st sq =
     withQueueRec qr delete
-      $>>= \nc_ -> nc_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq)
+      $>>= (<$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq))
     where
       qr = queueRec sq
       delete q = forM (notifier q) $ \nc -> do
@@ -251,7 +252,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
     setStatus (queueRec sq) EntityActive
       $>> withLog "unblockQueue" st (`logUnblockQueue` recipientId sq)
 
-  updateQueueTime :: STMQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  updateQueueTime :: STMQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
   updateQueueTime st sq t = withQueueRec qr update $>>= log'
     where
       qr = queueRec sq
@@ -264,11 +265,10 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
         | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId sq) t)
         | otherwise = pure $ Right q
 
-  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType QueueRec)
   deleteStoreQueue st sq =
     withQueueRec qr delete
-      $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
-      >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing))
+      $>>= (<$$ withLog "deleteStoreQueue" st (`logDeleteQueue` rId))
     where
       rId = recipientId sq
       qr = queueRec sq

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

@@ -14,13 +14,12 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 
 class StoreQueueClass q where
-  type MsgQueue q = mq | mq -> q
   recipientId :: q -> RecipientId
   queueRec :: q -> TVar (Maybe QueueRec)
-  msgQueue :: q -> TVar (Maybe (MsgQueue q))
   withQueueLock :: q -> Text -> IO a -> IO a
 
 class StoreQueueClass q => QueueStoreClass q s where
@@ -43,8 +42,8 @@ class StoreQueueClass q => QueueStoreClass q s where
   suspendQueue :: s -> q -> IO (Either ErrorType ())
   blockQueue :: s -> q -> BlockingInfo -> IO (Either ErrorType ())
   unblockQueue :: s -> q -> IO (Either ErrorType ())
-  updateQueueTime :: s -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
-  deleteStoreQueue :: s -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  updateQueueTime :: s -> q -> SystemDate -> IO (Either ErrorType QueueRec)
+  deleteStoreQueue :: s -> q -> IO (Either ErrorType QueueRec)
   getCreateService :: s -> ServiceRec -> IO (Either ErrorType ServiceId)
   setQueueService :: (PartyI p, ServiceParty p) => s -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
   getQueueNtfServices :: s -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))

src/Simplex/Messaging/Server/Stats.hs

@@ -27,7 +27,7 @@ import Data.Time.Clock (UTCTime (..))
 import GHC.IORef (atomicSwapIORef)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (EntityId (..))
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Util (atomicModifyIORef'_, tshow, unlessM)
 
 data ServerStats = ServerStats
@@ -976,7 +976,7 @@ data TimeBuckets = TimeBuckets
 emptyTimeBuckets :: TimeBuckets
 emptyTimeBuckets = TimeBuckets 0 0 IM.empty
 
-updateTimeBuckets :: RoundedSystemTime -> RoundedSystemTime -> TimeBuckets -> TimeBuckets
+updateTimeBuckets :: SystemSeconds -> SystemSeconds -> TimeBuckets -> TimeBuckets
 updateTimeBuckets
   (RoundedSystemTime deliveryTime)
   (RoundedSystemTime currTime)

src/Simplex/Messaging/Server/StoreLog.hs

@@ -55,9 +55,9 @@ import GHC.IO (catchAny)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
--- import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.StoreLog.Types
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM)
 import System.Directory (doesFileExist, listDirectory, removeFile, renameFile)
 import System.IO
@@ -75,7 +75,7 @@ data StoreLogRecord
   | UnblockQueue QueueId
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
-  | UpdateTime QueueId RoundedSystemTime
+  | UpdateTime QueueId SystemDate
   | NewService ServiceRec
   | QueueService RecipientId ASubscriberParty (Maybe ServiceId)
   deriving (Show)
@@ -280,7 +280,7 @@ logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 
-logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
+logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> SystemDate -> IO ()
 logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
 
 logNewService :: StoreLog 'WriteMode -> ServiceRec -> IO ()

src/Simplex/Messaging/ServiceScheme.hs

@@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Network.Socket (HostName, ServiceName)
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Encoding (Encoding(..))
 
 data ServiceScheme = SSSimplex | SSAppServer SrvLoc
   deriving (Eq, Show)
@@ -24,6 +25,12 @@ instance StrEncoding ServiceScheme where
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
 
+instance Encoding SrvLoc where
+  smpEncode (SrvLoc h s) = smpEncode (h, s)
+  smpP = do
+    (h, s) <- smpP
+    pure $ SrvLoc h s
+
 instance StrEncoding SrvLoc where
   strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port
   strP = SrvLoc <$> host <*> (port <|> pure "")

src/Simplex/Messaging/SystemTime.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.Messaging.SystemTime where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Int (Int64)
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime, systemToUTCTime)
+import Data.Typeable (Proxy (..))
+import GHC.TypeLits (KnownNat, Nat, natVal)
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
+import Simplex.Messaging.Encoding.String
+
+newtype RoundedSystemTime (t :: Nat) = RoundedSystemTime {roundedSeconds :: Int64}
+  deriving (Eq, Ord, Show)
+  deriving newtype (FromJSON, ToJSON, FromField, ToField)
+
+type SystemDate = RoundedSystemTime 86400
+
+type SystemSeconds = RoundedSystemTime 1
+
+instance StrEncoding (RoundedSystemTime t) where
+  strEncode (RoundedSystemTime t) = strEncode t
+  strP = RoundedSystemTime <$> strP
+
+getRoundedSystemTime :: forall t. KnownNat t => IO (RoundedSystemTime t)
+getRoundedSystemTime = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
+  where
+    prec = fromIntegral $ natVal $ Proxy @t
+
+getSystemDate :: IO SystemDate
+getSystemDate = getRoundedSystemTime
+{-# INLINE getSystemDate #-}
+
+getSystemSeconds :: IO SystemSeconds
+getSystemSeconds = RoundedSystemTime . systemSeconds <$> getSystemTime
+{-# INLINE getSystemSeconds #-}
+
+roundedToUTCTime :: RoundedSystemTime t -> UTCTime
+roundedToUTCTime = systemToUTCTime . (`MkSystemTime` 0) . roundedSeconds
+{-# INLINE roundedToUTCTime #-}

src/Simplex/Messaging/Transport.hs

@@ -55,6 +55,7 @@ module Simplex.Messaging.Transport
     shortLinksSMPVersion,
     serviceCertsSMPVersion,
     newNtfCredsSMPVersion,
+    clientNoticesSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -168,6 +169,7 @@ smpBlockSize = 16384
 -- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
 -- 16 - service certificates (5/31/2025)
 -- 17 - create notification credentials with NEW (7/12/2025)
+-- 18 - support client notices (10/10/2025)
 
 data SMPVersion
 
@@ -213,6 +215,9 @@ serviceCertsSMPVersion = VersionSMP 16
 newNtfCredsSMPVersion :: VersionSMP
 newNtfCredsSMPVersion = VersionSMP 17
 
+clientNoticesSMPVersion :: VersionSMP
+clientNoticesSMPVersion = VersionSMP 18
+
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 6
 
@@ -220,13 +225,13 @@ minServerSMPRelayVersion :: VersionSMP
 minServerSMPRelayVersion = VersionSMP 6
 
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 17
+currentClientSMPRelayVersion = VersionSMP 18
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 17
+currentServerSMPRelayVersion = VersionSMP 18
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -234,7 +239,7 @@ currentServerSMPRelayVersion = VersionSMP 17
 -- to prevent client version fingerprinting by the
 -- destination relays when clients upgrade at different times.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 16
+proxiedSMPRelayVersion = VersionSMP 17
 
 -- minimal supported protocol version is 6
 -- TODO remove code that supports sending commands without batching

src/Simplex/Messaging/Transport/Credentials.hs

@@ -35,8 +35,8 @@ tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, pr
 
 privateToTls :: C.APrivateSignKey -> TLS.PrivKey
 privateToTls (C.APrivateSignKey _ k) = case k of
-  C.PrivateKeyEd25519 secret _ -> TLS.PrivKeyEd25519 secret
-  C.PrivateKeyEd448 secret _ -> TLS.PrivKeyEd448 secret
+  C.PrivateKeyEd25519 pk -> TLS.PrivKeyEd25519 pk
+  C.PrivateKeyEd448 pk -> TLS.PrivKeyEd448 pk
 
 type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)
 

src/Simplex/Messaging/Util.hs

@@ -211,17 +211,25 @@ firstRow f e a = second f . listToEither e <$> a
 maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b)
 maybeFirstRow f q = fmap f . listToMaybe <$> q
 
+maybeFirstRow' :: Functor f => b -> (a -> b) -> f [a] -> f b
+maybeFirstRow' def f q = maybe def f . listToMaybe <$> q
+
 firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
 firstRow' f e a = (f <=< listToEither e) <$> a
 
 groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
 groupOn = groupBy . eqOn
-  where
-    -- it is equivalent to groupBy ((==) `on` f),
-    -- but it redefines `on` to avoid duplicate computation for most values.
-    -- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-    -- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
-    eqOn f x = let fx = f x in \y -> fx == f y
+
+groupOn' :: Eq k => (a -> k) -> [a] -> [NonEmpty a]
+groupOn' = L.groupBy . eqOn
+
+-- it is equivalent to groupBy ((==) `on` f),
+-- but it redefines `on` to avoid duplicate computation for most values.
+-- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
+-- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
+eqOn :: Eq k => (a -> k) -> a -> a -> Bool
+eqOn f x = let fx = f x in \y -> fx == f y
+{-# INLINE eqOn #-}
 
 groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
 groupAllOn f = groupOn f . sortOn f
@@ -237,6 +245,7 @@ safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
   where
     onError _ _ = Just '?'
+{-# INLINE safeDecodeUtf8 #-}
 
 timeoutThrow :: MonadUnliftIO m => e -> Int -> ExceptT e m a -> ExceptT e m a
 timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwE e) pure

tests/AgentTests/EqInstances.hs

@@ -5,16 +5,16 @@
 module AgentTests.EqInstances where
 
 import Data.Type.Equality
-import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..), UserLinkData (..))
+import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..), UserContactData (..), UserLinkData (..))
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Client (ProxiedRelay (..))
 
-instance Eq SomeConn where
+instance (Eq rq, Eq sq) => Eq (SomeConn' rq sq) where
   SomeConn d c == SomeConn d' c' = case testEquality d d' of
     Just Refl -> c == c'
     _ -> False
 
-deriving instance Eq (Connection d)
+deriving instance (Eq rq, Eq sq) => Eq (Connection' d rq sq)
 
 deriving instance Eq (SConnType d)
 
@@ -22,6 +22,8 @@ deriving instance Eq (StoredRcvQueue s)
 
 deriving instance Eq (StoredSndQueue q)
 
+deriving instance Eq RcvQueueSub
+
 deriving instance Eq ClientNtfCreds
 
 deriving instance Eq ShortLinkCreds
@@ -30,6 +32,10 @@ deriving instance Show (ConnLinkData c)
 
 deriving instance Eq (ConnLinkData c)
 
+deriving instance Show UserContactData
+
+deriving instance Eq UserContactData
+
 deriving instance Show UserLinkData
 
 deriving instance Eq UserLinkData

tests/AgentTests/FunctionalAPITests.hs

@@ -87,10 +87,12 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT, INV, JOINED)
 import qualified Simplex.Messaging.Agent.Protocol as A
+import Simplex.Messaging.Agent.Store (Connection' (..), SomeConn' (..), StoredRcvQueue (..))
+import Simplex.Messaging.Agent.Store.AgentStore (getConn)
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -100,10 +102,12 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF)
 import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, NetworkError (..), ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange)
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
 import Simplex.Messaging.Server.QueueStore.QueueInfo
+import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..))
 import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds)
 import Simplex.Messaging.Version (VersionRange (..))
@@ -114,14 +118,16 @@ 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 (Connection' (..), StoredRcvQueue (..), SomeConn' (..))
 import Simplex.Messaging.Agent.Store.AgentStore (getConn)
 import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Postgres (PostgresQueue)
 import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
 import Simplex.Messaging.Server.QueueStore.Postgres
 import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..))
@@ -276,7 +282,7 @@ inAnyOrder g rs = withFrozenCallStack $ do
 
 createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
 createConnection c userId enableNtfs cMode clientData subMode = do
-  (connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs cMode Nothing clientData IKPQOn subMode
+  (connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs True cMode Nothing clientData IKPQOn subMode
   pure (connId, cReq)
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
@@ -306,7 +312,7 @@ deleteConnections c = A.deleteConnections c NRMInteractive
 getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
 getConnShortLink c = A.getConnShortLink c NRMInteractive
 
-setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
+setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AE (ConnShortLink c)
 setConnShortLink c = A.setConnShortLink c NRMInteractive
 
 suspendConnection :: AgentClient -> ConnId -> AE ()
@@ -363,13 +369,13 @@ functionalAPITests ps = do
       it "should connect after errors" $ testContactErrors ps False
       it "should connect after errors with client restarts" $ testContactErrors ps True
   describe "Short connection links" $ do
-    describe "should connect via 1-time short link" $ testProxyMatrix ps testInviationShortLink
-    describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync
+    describe "should connect via 1-time short link" $ testProxyMatrix ps testInvitationShortLink
+    describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInvitationShortLinkAsync
     describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink
     describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink
-    xdescribe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInviationShortLinkPrev
+    xdescribe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInvitationShortLinkPrev
     describe "server restart" $ do
-      it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps
+      it "should get 1-time link data after restart" $ testInvitationShortLinkRestart 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
@@ -433,7 +439,7 @@ functionalAPITests ps = do
   describe "Batching SMP commands" $ do
     -- disable this and enable the following test to run tests with coverage
     it "should subscribe to multiple (200) subscriptions with batching" $
-      testBatchedSubscriptions 200 10 ps
+      testBatchedSubscriptions 200 20 ps
     skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $
       it "should subscribe to multiple (6) subscriptions with batching" $
         testBatchedSubscriptions 6 3 ps
@@ -538,6 +544,10 @@ functionalAPITests ps = do
   describe "SMP queue info" $ do
     it "server should respond with queue and subscription information" $
       withSmpServer ps testServerQueueInfo
+#if !defined(dbServerPostgres)
+  describe "Client notices" $ do
+    it "should create client notice" $ testClientNotice ps
+#endif
 
 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
@@ -698,7 +708,7 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
 runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
+    (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
     (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
@@ -900,7 +910,7 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
 runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
-    (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+    (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
     (sqSecuredJoin, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
@@ -944,7 +954,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
 
 runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
 runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
-  (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
+  (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ SMSubscribe
   (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
   sentMessages abPQEnc alice bobId bob bAliceId
   (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
@@ -997,7 +1007,7 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
 testRejectContactRequest :: HasCallStack => IO ()
 testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
-    (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
     (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
@@ -1319,11 +1329,12 @@ withServer1 ps = withSmpServerStoreLogOn ps testPort . const
 withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a
 withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const
 
-testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
-testInviationShortLink viaProxy a b =
+testInvitationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
+testInvitationShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
     let userData = UserLinkData "some user data"
-    (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+        newLinkData = UserInvLinkData userData
+    (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMSubscribe
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
@@ -1354,17 +1365,19 @@ testJoinConn_ viaProxy sndSecure a bId b connReq = do
   get b ##> ("", aId, CON)
   exchangeGreetingsViaProxy viaProxy a bId b aId
 
-testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO ()
-testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
+testInvitationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO ()
+testInvitationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
   let userData = UserLinkData "some user data"
+      newLinkData = UserInvLinkData userData
   -- can't create short link with previous version
-  (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
+  (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKPQOn SMSubscribe
   testJoinConn_ viaProxy sndSecure a bId b connReq
 
-testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
-testInviationShortLinkAsync viaProxy a b = do
+testInvitationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
+testInvitationShortLinkAsync viaProxy a b = do
   let userData = UserLinkData "some user data"
-  (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
+      newLinkData = UserInvLinkData userData
+  (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMSubscribe
   (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
   strDecode (strEncode shortLink) `shouldBe` Right shortLink
   connReq' `shouldBe` connReq
@@ -1379,24 +1392,32 @@ testInviationShortLinkAsync viaProxy a b = do
     get b ##> ("", aId, CON)
     exchangeGreetingsViaProxy viaProxy a bId b aId
 
+relayLink1 :: ConnShortLink 'CMContact
+relayLink1 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
+
+relayLink2 :: ConnShortLink 'CMContact
+relayLink2 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM"
+
 testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
     let userData = UserLinkData "some user data"
-    (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
+        userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+        newLinkData = UserContactLinkData userCtData
+    (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0)
-    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
-    linkUserData connData' `shouldBe` userData
+    userCtData' `shouldBe` userCtData
     -- same user can get contact link again
-    (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink
+    (connReq2, ContactLinkData _ userCtData2) <- runRight $ getConnShortLink b 1 shortLink
     connReq2 `shouldBe` connReq
-    linkUserData connData2 `shouldBe` userData
+    userCtData2 `shouldBe` userCtData
     -- another user can get the same contact link
-    (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink
+    (connReq3, ContactLinkData _ userCtData3) <- runRight $ getConnShortLink c 1 shortLink
     connReq3 `shouldBe` connReq
-    linkUserData connData3 `shouldBe` userData
+    userCtData3 `shouldBe` userCtData
     runRight $ do
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
@@ -1412,13 +1433,15 @@ testContactShortLink viaProxy a b =
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
     let updatedData = UserLinkData "updated user data"
-    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+        updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
+        userLinkData' = UserContactLinkData updatedCtData
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
     shortLink' `shouldBe` shortLink
-    (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink
+    (connReq4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink c 1 shortLink
     connReq4 `shouldBe` connReq
-    linkUserData updatedConnData' `shouldBe` updatedData
+    updatedCtData' `shouldBe` updatedCtData
     -- one more time
-    shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+    shortLink2 <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
     shortLink2 `shouldBe` shortLink
     -- delete short link
     runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact
@@ -1428,22 +1451,24 @@ testContactShortLink viaProxy a b =
 testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
 testAddContactShortLink viaProxy a b =
   withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
-    (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
+    (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
     Right connReq <- pure $ smpDecode (smpEncode connReq0) --
     let userData = UserLinkData "some user data"
-    shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
-    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+        userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+        newLinkData = UserContactLinkData userCtData
+    shortLink <- runRight $ setConnShortLink a contactId SCMContact newLinkData Nothing
+    (connReq', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
-    linkUserData connData' `shouldBe` userData
+    userCtData' `shouldBe` userCtData
     -- same user can get contact link again
-    (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink
+    (connReq2, ContactLinkData _ userCtData2) <- runRight $ getConnShortLink b 1 shortLink
     connReq2 `shouldBe` connReq
-    linkUserData connData2 `shouldBe` userData
+    userCtData2 `shouldBe` userCtData
     -- another user can get the same contact link
-    (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink
+    (connReq3, ContactLinkData _ userCtData3) <- runRight $ getConnShortLink c 1 shortLink
     connReq3 `shouldBe` connReq
-    linkUserData connData3 `shouldBe` userData
+    userCtData3 `shouldBe` userCtData
     runRight $ do
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
@@ -1459,17 +1484,20 @@ testAddContactShortLink viaProxy a b =
       exchangeGreetingsViaProxy viaProxy a bId b aId
     -- update user data
     let updatedData = UserLinkData "updated user data"
-    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+        updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
+        userLinkData' = UserContactLinkData updatedCtData
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
     shortLink' `shouldBe` shortLink
-    (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink
+    (connReq4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink c 1 shortLink
     connReq4 `shouldBe` connReq
-    linkUserData updatedConnData' `shouldBe` updatedData
+    updatedCtData' `shouldBe` updatedCtData
 
-testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
-testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
+testInvitationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testInvitationShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
+      newLinkData = UserInvLinkData userData
   (bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $
-    runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
+    runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMOnlyCreate
   withSmpServer ps $ do
     runRight_ $ subscribeConnection a bId
     (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
@@ -1480,80 +1508,101 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
 testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
+      userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+      newLinkData = UserContactLinkData userCtData
   (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $
-    runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
+    runRight $ A.createConnection a NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing CR.IKPQOn SMOnlyCreate
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
   let updatedData = UserLinkData "updated user data"
+      updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
+      updatedLinkData = UserContactLinkData updatedCtData
   withSmpServer ps $ do
-    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
-    linkUserData connData' `shouldBe` userData
+    userCtData' `shouldBe` userCtData
     -- update user data
-    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedLinkData Nothing
     shortLink' `shouldBe` shortLink
   withSmpServer ps $ do
-    (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
     connReq4 `shouldBe` connReq
-    linkUserData updatedConnData' `shouldBe` updatedData
+    updatedCtData' `shouldBe` updatedCtData
 
 testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
   let userData = UserLinkData "some user data"
+      userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+      newLinkData = UserContactLinkData userCtData
   ((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do
-    r@(contactId, _) <- A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
-    (r,) <$> setConnShortLink a contactId SCMContact userData Nothing
+    r@(contactId, _) <- A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
+    (r,) <$> setConnShortLink a contactId SCMContact newLinkData Nothing
   Right connReq <- pure $ smpDecode (smpEncode connReq0)
   let updatedData = UserLinkData "updated user data"
+      updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
+      updatedLinkData = UserContactLinkData updatedCtData
   withSmpServer ps $ do
-    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq', ContactLinkData _  userCtData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
-    linkUserData connData' `shouldBe` userData
+    userCtData' `shouldBe` userCtData
     -- update user data
-    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedLinkData Nothing
     shortLink' `shouldBe` shortLink
   withSmpServer ps $ do
-    (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
     connReq4 `shouldBe` connReq
-    linkUserData updatedConnData' `shouldBe` updatedData
+    updatedCtData' `shouldBe` updatedCtData
 
 testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
   (contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $
-    A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
+    A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
   -- make it an "old" queue
   let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
-  () <- case testServerStoreConfig msType of
-    ASSCfg _ _ (SSCMemory (Just StorePaths {storeLogFile})) -> updateStoreLog storeLogFile
-    ASSCfg _ _ (SSCMemoryJournal {storeLogFile}) -> updateStoreLog storeLogFile
-    ASSCfg _ _ (SSCDatabaseJournal {storeCfg}) -> do
 #if defined(dbServerPostgres)
-      let AgentClient {agentEnv = Env {store}} = a
-      Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
-      st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) storeCfg
-      Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
-      closeQueueStore @(JournalQueue 'QSPostgres) st
-#else
-      error "no dbServerPostgres flag"
+      updateDbStore :: PostgresQueueStore s -> IO ()
+      updateDbStore st = do
+        let AgentClient {agentEnv = Env {store}} = a
+        Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
+        Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
+        pure ()
+#endif
+  () <- case testServerStoreConfig msType of
+    ASSCfg _ _ (SSCMemory sp_) -> mapM_ (\StorePaths {storeLogFile} -> updateStoreLog storeLogFile) sp_
+    ASSCfg _ _ SSCMemoryJournal {storeLogFile} -> updateStoreLog storeLogFile
+#if defined(dbServerPostgres)
+    ASSCfg _ _ SSCDatabaseJournal {storeCfg} -> do
+      st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) (storeCfg, True)
+      updateDbStore st
+      closeQueueStore @(JournalQueue 'QSPostgres) st
+    ASSCfg _ _ (SSCDatabase storeCfg) -> do
+      st :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False)
+      updateDbStore st
+      closeQueueStore @PostgresQueue st
+#else
+    ASSCfg _ _ SSCDatabaseJournal {} -> error "no dbServerPostgres flag"
 #endif
-    _ -> pure ()
 
   withSmpServer ps $ do
     let userData = UserLinkData "some user data"
-    shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
-    (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
+        userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+        userLinkData = UserContactLinkData userCtData
+    shortLink <- runRight $ setConnShortLink a contactId SCMContact userLinkData Nothing
+    (connReq', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
     strDecode (strEncode shortLink) `shouldBe` Right shortLink
     connReq' `shouldBe` connReq
-    linkUserData connData' `shouldBe` userData
+    userCtData' `shouldBe` userCtData
     -- update user data
     let updatedData = UserLinkData "updated user data"
-    shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
+        updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
+        userLinkData' = UserContactLinkData updatedCtData
+    shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
     shortLink' `shouldBe` shortLink
     -- check updated
-    (connReq'', updatedConnData') <- runRight $ getConnShortLink b 1 shortLink
+    (connReq'', ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
     connReq'' `shouldBe` connReq
-    linkUserData updatedConnData' `shouldBe` updatedData
+    updatedCtData' `shouldBe` updatedCtData
 
 replaceSubstringInFile :: FilePath -> T.Text -> T.Text -> IO ()
 replaceSubstringInFile filePath oldText newText = do
@@ -2252,7 +2301,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
 
 makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
-  (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
+  (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
   (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
   liftIO $ sqSecured' `shouldBe` sqSecured
@@ -2380,8 +2429,8 @@ testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
     pure ()
 
 testBatchedSubscriptions :: Int -> Int -> (ASrvTransport, AStoreType) -> IO ()
-testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
-  withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
+testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = do
+  (conns, conns') <- withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     conns <- runServers $ do
       conns <- replicateM nCreate $ makeConnection_ PQSupportOff True a b
       forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId
@@ -2390,21 +2439,23 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
       delete b aIds'
       liftIO $ threadDelay 1000000
       pure conns
-    ("", "", DOWN {}) <- nGet a
-    ("", "", DOWN {}) <- nGet a
-    ("", "", DOWN {}) <- nGet b
-    ("", "", DOWN {}) <- nGet b
+    let conns' = drop nDel conns
+        (aIds', bIds') = unzip conns'
+    down a bIds'
+    down b aIds'
+    runServers $ do
+      up a bIds'
+      up b aIds'
+    down a bIds'
+    down b aIds'
+    pure (conns, conns')
+  withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     runServers $ do
-      ("", "", UP {}) <- nGet a
-      ("", "", UP {}) <- nGet a
-      ("", "", UP {}) <- nGet b
-      ("", "", UP {}) <- nGet b
       liftIO $ threadDelay 1000000
       let (aIds, bIds) = unzip conns
-          conns' = drop nDel conns
           (aIds', bIds') = unzip conns'
-      subscribe a bIds
-      subscribe b aIds
+      subscribe a bIds'
+      subscribe b aIds'
       forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 4 a bId b aId
       void $ resubscribeConnections a bIds
       void $ resubscribeConnections b aIds
@@ -2414,14 +2465,18 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
       deleteFail a bIds'
       deleteFail b aIds'
   where
+    down c cs = do
+      ("", "", DOWN _ cs1) <- nGet c
+      ("", "", DOWN _ cs2) <- nGet c
+      liftIO $ S.fromList (cs1 ++ cs2) `shouldBe` S.fromList cs
+    up c cs = do
+      ("", "", UP _ cs1) <- nGet c
+      ("", "", UP _ cs2) <- nGet c
+      liftIO $ S.fromList (cs1 ++ cs2) `shouldBe` S.fromList cs
     subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
     subscribe c cs = do
-      r <- subscribeConnections c cs
-      liftIO $ do
-        let dc = S.fromList $ take nDel cs
-        all isRight (M.withoutKeys r dc) `shouldBe` True
-        all (== Left (CONN NOT_FOUND "")) (M.restrictKeys r dc) `shouldBe` True
-        M.keys r `shouldMatchList` cs
+      subscribeAllConnections c False Nothing
+      liftIO $ up c cs
     delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
     delete c cs = do
       r <- deleteConnections c cs
@@ -2451,8 +2506,10 @@ testBatchedPendingMessages nCreate nMsgs =
     runRight_ $ forM_ msgConns $ \(_, bId) -> sendMessage a bId SMP.noMsgFlags "hello"
     replicateM_ nMsgs $ get a =##> \case ("", cId, SENT _) -> isJust $ find ((cId ==) . snd) msgConns; _ -> False
     withB $ \b -> runRight_ $ do
-      r <- subscribeConnections b $ map fst conns
-      liftIO $ all isRight r `shouldBe` True
+      let aIds = map fst conns
+      subscribeAllConnections b False Nothing
+      ("", "", UP _ aIds') <- nGet b
+      liftIO $ S.fromList aIds' `shouldBe` S.fromList aIds
       replicateM_ nMsgs $ do
         ("", cId, Msg' msgId _ "hello") <- get b
         liftIO $ isJust (find ((cId ==) . fst) msgConns) `shouldBe` True
@@ -3558,6 +3615,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     liftIO $ threadDelay 250000
     ("", "", DOWN _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 2
 
     exchangeGreetingsMsgId 4 a bId1 b aId1
@@ -3584,6 +3642,8 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     ("", "", DOWN _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 4
     exchangeGreetingsMsgId 6 a bId1 b aId1
     exchangeGreetingsMsgId 6 a bId1' b aId1'
@@ -3619,13 +3679,13 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do
 
 #if defined(dbPostgres)
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError
+createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
 #else
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError
+createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")
@@ -3815,6 +3875,76 @@ testServerQueueInfo = do
         qDelivered <$> qiSub `shouldBe` Just msgId_
         pure msgId_
 
+testClientNotice :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testClientNotice ps = do
+  withAgent 1 agentCfg initAgentServers testDB $ \c -> do
+    (cId, _) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $
+      A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    ("", "", DOWN _ [_]) <- nGet c
+
+    addNotice c cId $ Just 1
+
+    (cId', _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
+      subscribedWithErrors c 1
+      testNotice c True
+      threadDelay 1000000
+      runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    ("", "", DOWN _ [_]) <- nGet c
+
+    addNotice c cId' $ Just 1
+
+    (cId'', _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
+      subscribedWithErrors c 1
+      testNotice c True
+      threadDelay 1000000
+      testNotice c True
+      threadDelay 1000000
+      runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+
+    addNotice c cId'' $ Just 1
+
+  withAgent 1 agentCfg initAgentServers testDB $ \c -> do
+    (cId3, _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
+      runRight_ $ subscribeAllConnections c False Nothing
+      subscribedWithErrors c 3
+      testNotice c True
+      threadDelay 2000000
+      testNotice c True
+      threadDelay 1000000
+      runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+    ("", "", DOWN _ [_]) <- nGet c
+
+    addNotice c cId3 Nothing
+
+    withSmpServerStoreLogOn ps testPort $ \_ -> do
+      subscribedWithErrors c 1
+      testNotice c False
+
+    removeNotice c cId3
+
+  withAgent 1 agentCfg initAgentServers testDB $ \c -> do
+    withSmpServerStoreLogOn ps testPort $ \_ -> do
+      runRight_ $ subscribeAllConnections c False Nothing
+      subscribedWithErrors c 4
+      void $ runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+  where
+    addNotice c cId ttl = logNotice c cId $ Just ClientNotice {ttl}
+    removeNotice c cId = logNotice c cId Nothing
+    logNotice :: AgentClient -> ConnId -> Maybe ClientNotice -> IO ()
+    logNotice c cId notice = do
+      Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction (store $ agentEnv c) (`getConn` cId)
+      withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rcvId $ SMP.BlockingInfo SMP.BRContent notice
+    subscribedWithErrors c n = do
+      ("", "", ERRS errs) <- nGet c
+      length errs `shouldBe` n
+      forM_ errs $ \case
+        (_, SMP _  (BLOCKED _)) -> pure ()
+        r -> expectationFailure $ "unexpected event: " <> show r
+    testNotice :: HasCallStack => AgentClient -> Bool -> IO ()
+    testNotice c willExpire = do
+      NOTICE "localhost" False expiresAt_ <- runLeft $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
+      isJust expiresAt_ `shouldBe` willExpire
+
 noNetworkDelay :: AgentClient -> IO ()
 noNetworkDelay a = do
   d <- waitNetwork a

tests/AgentTests/MigrationTests.hs

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

tests/AgentTests/NotificationTests.hs

@@ -205,8 +205,9 @@ checkNtfToken c = A.checkNtfToken c NRMInteractive
 verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
 verifyNtfToken c = A.verifyNtfToken c NRMInteractive
 
-runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
-runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
+runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> IO NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
+runNtfTestCfg (t, msType) baseId smpCfg ntfCfg' aCfg bCfg runTest = do
+  ntfCfg <- ntfCfg'
   ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
   let smpCfg' = withServerCfg smpCfg $ \cfg_ -> ASrvCfg qt mt cfg_ {serverStoreCfg}
   withSmpServerConfigOn t smpCfg' testPort $ \_ ->
@@ -218,7 +219,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken apns = do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -242,7 +243,7 @@ v .-> key = do
 testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration apns = do
   withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -261,7 +262,7 @@ testNtfTokenRepeatRegistration apns = do
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration apns =
   withAgentClients2 $ \a a' -> runRight_ $ do
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -290,7 +291,7 @@ testNtfTokenSecondRegistration apns =
 
 testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -311,7 +312,7 @@ testNtfTokenServerRestart t apns = do
 
 testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverify t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a -> do
     ntfData <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -334,7 +335,7 @@ testNtfTokenServerRestartReverify t apns = do
 
 testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReverifyTimeout t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     (nonce, verification) <- withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -355,7 +356,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
           SET tkn_status = ?, tkn_action = ?
           WHERE provider = ? AND device_token = ?
         |]
-        (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString)
+        (NTConfirmed, Just (NTAVerify code), PPAPNS PPApnsTest, "abcd" :: ByteString)
     Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1500000
@@ -369,7 +370,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
 
 testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregister t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a ->
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -393,7 +394,7 @@ testNtfTokenServerRestartReregister t apns = do
 
 testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestartReregisterTimeout t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
     withNtfServer t $ runRight $ do
       NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -409,7 +410,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do
           SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ?
           WHERE provider = ? AND device_token = ?
         |]
-        (NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString)
+        (NTNew, Just NTARegister, PPAPNS PPApnsTest, "abcd" :: ByteString)
     Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
     pure ()
   threadDelay 1000000
@@ -434,7 +435,7 @@ getTestNtfTokenPort a =
 
 testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
 testNtfTokenMultipleServers t apns = do
-  let tkn = DeviceToken PPApnsTest "abcd"
+  let tkn = APNSDeviceToken PPApnsTest "abcd"
   withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
     withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
       withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do
@@ -554,7 +555,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, CON)
     -- register notification token
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = APNSDeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken alice tkn NMInstant
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
       getMockNotification apns tkn
@@ -607,9 +608,9 @@ testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> A
 testNotificationSubscriptionNewConnection apns baseId alice bob =
   runRight_ $ do
     -- alice registers notification token
-    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
+    APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns
     -- bob registers notification token
-    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
+    APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns
     -- establish connection
     liftIO $ threadDelay 50000
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -645,7 +646,7 @@ testNotificationSubscriptionNewConnection apns baseId alice bob =
 
 registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken
 registerTestToken a token mode apns = do
-  let tkn = DeviceToken PPApnsTest token
+  let tkn = APNSDeviceToken PPApnsTest token
   NTRegistered <- registerNtfToken a tkn mode
   Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
     timeout 1000000 $ getMockNotification apns tkn
@@ -931,7 +932,8 @@ testMigrateToServiceSubscriptions :: HasCallStack => (ASrvTransport, AStoreType)
 testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> do
   (c1, c2, c3) <- withSmpServerConfigOn t cfgNoService testPort $ \_ -> do
     (c1, c2) <- withAPNSMockServer $ \apns -> do
-      withNtfServerCfg ntfCfgNoService $ \_ -> runRight $ do
+      cfg' <- ntfCfgNoService
+      withNtfServerCfg cfg' $ \_ -> runRight $ do
         _tkn <- registerTestToken a "abcd" NMInstant apns
         -- create 2 connections with ntfs, test delivery
         c1 <- testConnectMsg apns a b "hello"
@@ -970,27 +972,31 @@ testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> d
   serverDOWN a b 5
 
   -- Ntf server does not use server, subscriptions downgrade
-  c6 <- withAPNSMockServer $ \apns -> withSmpServer ps $ withNtfServerCfg ntfCfgNoService $ \_ -> do
-    serverUP a b 5
-    runRight $ do
-      testSendMsg apns a b c1 "msg 1"
-      testSendMsg apns a b c2 "msg 2"
-      testSendMsg apns a b c3 "msg 3"
-      testSendMsg apns a b c4 "msg 4"
-      testSendMsg apns a b c5 "msg 5"
-      testConnectMsg apns a b "msg 6"
+  c6 <- withAPNSMockServer $ \apns -> do
+    cfg' <- ntfCfgNoService
+    withSmpServer ps $ withNtfServerCfg cfg' $ \_ -> do
+      serverUP a b 5
+      runRight $ do
+        testSendMsg apns a b c1 "msg 1"
+        testSendMsg apns a b c2 "msg 2"
+        testSendMsg apns a b c3 "msg 3"
+        testSendMsg apns a b c4 "msg 4"
+        testSendMsg apns a b c5 "msg 5"
+        testConnectMsg apns a b "msg 6"
   serverDOWN a b 6
 
-  withAPNSMockServer $ \apns -> withSmpServerConfigOn t cfgNoService testPort $ \_ -> withNtfServerCfg ntfCfgNoService $ \_ -> do
-    serverUP a b 6
-    runRight_ $ do
-      testSendMsg apns a b c1 "1"
-      testSendMsg apns a b c2 "2"
-      testSendMsg apns a b c3 "3"
-      testSendMsg apns a b c4 "4"
-      testSendMsg apns a b c5 "5"
-      testSendMsg apns a b c6 "6"
-      void $ testConnectMsg apns a b "7"
+  withAPNSMockServer $ \apns -> do
+    cfg' <- ntfCfgNoService
+    withSmpServerConfigOn t cfgNoService testPort $ \_ -> withNtfServerCfg cfg' $ \_ -> do
+      serverUP a b 6
+      runRight_ $ do
+        testSendMsg apns a b c1 "1"
+        testSendMsg apns a b c2 "2"
+        testSendMsg apns a b c3 "3"
+        testSendMsg apns a b c4 "4"
+        testSendMsg apns a b c5 "5"
+        testSendMsg apns a b c6 "6"
+        void $ testConnectMsg apns a b "7"
   serverDOWN a b 7
   where
     testConnectMsg apns a b msg = do
@@ -1013,7 +1019,9 @@ testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> d
     cfgNoService = updateCfg (cfgMS msType) $ \(cfg' :: ServerConfig s) ->
       let ServerConfig {transportConfig} = cfg'
        in cfg' {transportConfig = transportConfig {askClientCert = False}} :: ServerConfig s
-    ntfCfgNoService = ntfServerCfg {useServiceCreds = False, transports = [(ntfTestPort, t, False)]}
+    ntfCfgNoService = do
+      cfg' <- ntfServerCfg
+      pure cfg' {useServiceCreds = False, transports = [(ntfTestPort, t, False)]}
 
 testMessage_ :: HasCallStack => APNSMockServer -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
 testMessage_ apns a aId b bId msg = do

tests/AgentTests/SQLiteTests.hs

@@ -46,7 +46,7 @@ import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
 import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction')
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (pattern IKPQOn)
@@ -83,7 +83,7 @@ createEncryptedStore key keepKey = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations MCError
+  Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);")
   pure st
 
@@ -204,9 +204,6 @@ cData1 =
 testPrivateAuthKey :: C.APrivateAuthKey
 testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
 
-testPublicAuthKey :: C.APublicAuthKey
-testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
-
 testPrivDhKey :: C.PrivateKeyX25519
 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"
 
@@ -232,6 +229,8 @@ rcvQueue1 =
       shortLink = Nothing,
       clientService = Nothing,
       status = New,
+      enableNtfs = True,
+      clientNoticeId = Nothing,
       dbQueueId = DBNewEntity,
       primary = True,
       dbReplaceQueueId = Nothing,
@@ -249,7 +248,6 @@ sndQueue1 =
       server = smpServer1,
       sndId = EntityId "3456",
       queueMode = Just QMMessaging,
-      sndPublicKey = testPublicAuthKey,
       sndPrivateKey = testPrivateAuthKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
@@ -264,7 +262,7 @@ sndQueue1 =
 createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue))
 createRcvConn db g cData rq cMode = runExceptT $ do
   connId <- ExceptT $ createNewConn db g cData cMode
-  rq' <- ExceptT $ updateNewConnRcv db connId rq
+  rq' <- ExceptT $ updateNewConnRcv db connId rq SMSubscribe
   pure (connId, rq')
 
 testCreateRcvConn :: SpecWith DBStore
@@ -310,7 +308,7 @@ testCreateSndConn =
     dbQueueId `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
-    Right rq@RcvQueue {dbQueueId = dbQueueId'} <- upgradeSndConnToDuplex db "conn1" rcvQueue1
+    Right rq@RcvQueue {dbQueueId = dbQueueId'} <- upgradeSndConnToDuplex db "conn1" rcvQueue1 SMSubscribe
     dbQueueId' `shouldBe` DBEntityId 1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
@@ -322,7 +320,7 @@ testCreateSndConnRandomID =
     Right (connId, sq) <- createSndConn db g cData1 {connId = ""} sndQueue1
     getConn db connId
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq))
-    Right (rq@RcvQueue {dbQueueId = dbQueueId'}) <- upgradeSndConnToDuplex db connId rcvQueue1
+    Right (rq@RcvQueue {dbQueueId = dbQueueId'}) <- upgradeSndConnToDuplex db connId rcvQueue1 SMSubscribe
     dbQueueId' `shouldBe` DBEntityId 1
     getConn db connId
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq]))
@@ -409,7 +407,6 @@ testUpgradeRcvConnToDuplex =
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = EntityId "2345",
               queueMode = Just QMMessaging,
-              sndPublicKey = testPublicAuthKey,
               sndPrivateKey = testPrivateAuthKey,
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
@@ -422,7 +419,7 @@ testUpgradeRcvConnToDuplex =
             }
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
       `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CSnd)
-    _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
+    _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1 SMSubscribe
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
       `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CDuplex)
 
@@ -446,6 +443,8 @@ testUpgradeSndConnToDuplex =
               shortLink = Nothing,
               clientService = Nothing,
               status = New,
+              enableNtfs = True,
+              clientNoticeId = Nothing,
               dbQueueId = DBNewEntity,
               rcvSwchStatus = Nothing,
               primary = True,
@@ -454,10 +453,10 @@ testUpgradeSndConnToDuplex =
               clientNtfCreds = Nothing,
               deleteErrors = 0
             }
-    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
+    upgradeSndConnToDuplex db "conn1" anotherRcvQueue SMSubscribe
       `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CRcv)
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-    upgradeSndConnToDuplex db "conn1" anotherRcvQueue
+    upgradeSndConnToDuplex db "conn1" anotherRcvQueue SMSubscribe
       `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CDuplex)
 
 testSetRcvQueueStatus :: SpecWith DBStore
@@ -470,7 +469,7 @@ testSetRcvQueueStatus =
     setRcvQueueStatus db rq Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 (rq {status = Confirmed} :: RcvQueue)))
 
 testSetSndQueueStatus :: SpecWith DBStore
 testSetSndQueueStatus =
@@ -482,7 +481,7 @@ testSetSndQueueStatus =
     setSndQueueStatus db sq Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 (sq {status = Confirmed} :: SndQueue)))
 
 testSetQueueStatusDuplex :: SpecWith DBStore
 testSetQueueStatusDuplex =
@@ -569,7 +568,7 @@ testCreateSndMsg_ db expectedPrevHash connId sq sndMsgData@SndMsgData {..} = do
     `shouldReturn` Right (internalId, internalSndId, expectedPrevHash)
   createSndMsg db connId sndMsgData
     `shouldReturn` ()
-  createSndMsgDelivery db connId sq internalId
+  createSndMsgDelivery db sq internalId
     `shouldReturn` ()
 
 testCreateSndMsg :: SpecWith DBStore
@@ -642,7 +641,7 @@ testReopenEncryptedStoreKeepKey = do
   hasMigrations st
 
 getMigrations :: DBStore -> IO Bool
-getMigrations st = not . null <$> withTransaction st getCurrentMigrations
+getMigrations st = not . null <$> withTransaction st (getCurrentMigrations Nothing)
 
 hasMigrations :: DBStore -> Expectation
 hasMigrations st = getMigrations st `shouldReturn` True
@@ -684,7 +683,7 @@ testGetPendingServerCommand st = do
     Right (Just PendingCommand {corrId}) <- getPendingServerCommand db connId Nothing
     corrId `shouldBe` "2"
 
-    Right _ <- updateNewConnRcv db connId rcvQueue1
+    Right _ <- updateNewConnRcv db connId rcvQueue1 SMSubscribe
     Right Nothing <- getPendingServerCommand db connId $ Just smpServer1
     Right () <- createCommand db "3" connId (Just smpServer1) command
     corruptCmd db "3" connId

tests/AgentTests/SchemaDump.hs

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

tests/AgentTests/ServerChoice.hs

@@ -64,7 +64,8 @@ initServers =
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
       netCfg = defaultNetworkConfig,
-      presetDomains = []
+      presetDomains = [],
+      presetServers = []
     }
 
 testChooseDifferentOperator :: IO ()

tests/AgentTests/ShortLinkTests.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -8,7 +11,8 @@ import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest)
 import AgentTests.EqInstances ()
 import Control.Concurrent.STM
 import Control.Monad.Except
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SConnectionMode (..), SMPAgentError (..), UserLinkData (..), linkUserData, supportedSMPAgentVRange)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnLinkData (..), ConnectionMode (..), ConnShortLink (..), LinkKey (..), UserConnLinkData (..), SConnectionMode (..), SMPAgentError (..), UserContactData (..), UserLinkData (..), linkUserData, supportedSMPAgentVRange)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.ShortLink as SL
 import Test.Hspec hiding (fit, it)
@@ -31,7 +35,8 @@ testInvShortLink = do
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData
+      userLinkData = UserInvLinkData userData
+      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userLinkData
       k = SL.invShortLinkKdf linkKey
   Right srvData <- runExceptT $ SL.encryptLinkData g k linkData
   -- decrypt
@@ -45,7 +50,8 @@ testInvShortLinkBadDataHash = do
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData
+      userLinkData = UserInvLinkData userData
+      (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userLinkData
   -- different key
   linkKey <- LinkKey <$> atomically (C.randomBytes 32 g)
   let k = SL.invShortLinkKdf linkKey
@@ -54,19 +60,27 @@ testInvShortLinkBadDataHash = do
   SL.decryptLinkData @'CMInvitation linkKey k srvData
     `shouldBe` Left (AGENT (A_LINK "link data hash"))
 
+relayLink1 :: ConnShortLink 'CMContact
+relayLink1 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
+
+relayLink2 :: ConnShortLink 'CMContact
+relayLink2 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM"
+
 testContactShortLink :: IO ()
 testContactShortLink = do
   -- encrypt
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
+      userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+      userLinkData = UserContactLinkData userCtData
+      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userLinkData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right srvData <- runExceptT $ SL.encryptLinkData g k linkData
   -- decrypt
-  Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k srvData
+  Right (connReq, ContactLinkData _ userCtData') <- pure $ SL.decryptLinkData @'CMContact linkKey k srvData
   connReq `shouldBe` contactConnRequest
-  linkUserData connData' `shouldBe` userData
+  userCtData' `shouldBe` userCtData
 
 testUpdateContactShortLink :: IO ()
 testUpdateContactShortLink = do
@@ -74,17 +88,21 @@ testUpdateContactShortLink = do
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
+      userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
+      userLinkData = UserContactLinkData userCtData
+      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userLinkData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData
   -- encrypt updated user data
   let updatedUserData = UserLinkData "updated user data"
-      signed = SL.encodeSignUserData SCMContact (snd sigKeys) supportedSMPAgentVRange updatedUserData
+      userCtData' = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedUserData}
+      userLinkData' = UserContactLinkData userCtData'
+      signed = SL.encodeSignUserData SCMContact (snd sigKeys) supportedSMPAgentVRange userLinkData'
   Right ud' <- runExceptT $ SL.encryptUserData g k signed
   -- decrypt
-  Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k (fd, ud')
+  Right (connReq, ContactLinkData _ userCtData'') <- pure $ SL.decryptLinkData @'CMContact linkKey k (fd, ud')
   connReq `shouldBe` contactConnRequest
-  linkUserData connData' `shouldBe` updatedUserData
+  userCtData'' `shouldBe` userCtData'
 
 testContactShortLinkBadDataHash :: IO ()
 testContactShortLinkBadDataHash = do
@@ -92,7 +110,8 @@ testContactShortLinkBadDataHash = do
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
+      userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
+      (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userLinkData
   -- different key
   linkKey <- LinkKey <$> atomically (C.randomBytes 32 g)
   let (_linkId, k) = SL.contactShortLinkKdf linkKey
@@ -107,14 +126,16 @@ testContactShortLinkBadSignature = do
   g <- C.newRandom
   sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
   let userData = UserLinkData "some user data"
-      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
+      userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
+      (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userLinkData
       (_linkId, k) = SL.contactShortLinkKdf linkKey
   Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData
   -- encrypt updated user data
   let updatedUserData = UserLinkData "updated user data"
+      userLinkData' = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = updatedUserData}
   -- another signature key
   (_, pk) <- atomically $ C.generateKeyPair @'C.Ed25519 g
-  let signed = SL.encodeSignUserData SCMContact pk supportedSMPAgentVRange updatedUserData
+  let signed = SL.encodeSignUserData SCMContact pk supportedSMPAgentVRange userLinkData'
   Right ud' <- runExceptT $ SL.encryptUserData g k signed
   -- decryption fails
   SL.decryptLinkData @'CMContact linkKey k (fd, ud')

tests/CLITests.hs

@@ -10,7 +10,6 @@ import AgentTests.FunctionalAPITests (runRight_)
 import Control.Logger.Simple
 import Control.Monad
 import qualified Crypto.PubKey.RSA as RSA
-import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as HM
 import Data.Ini (Ini (..), lookupValue, readIniFile, writeIniFile)
@@ -46,6 +45,7 @@ import UnliftIO.Exception (bracket)
 import Util
 
 #if defined(dbServerPostgres)
+import qualified Data.ByteString.Char8 as B
 import qualified Database.PostgreSQL.Simple as PSQL
 import Database.PostgreSQL.Simple.Types (Query (..))
 import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts)

tests/CoreTests/MsgStoreTests.hs

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

tests/CoreTests/StoreLogTests.hs

@@ -24,18 +24,22 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
-import Simplex.Messaging.Server.Main
 import Simplex.Messaging.Server.MsgStore.Journal
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
 import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.SystemTime
 import Simplex.Messaging.Transport (SMPServiceRole (..))
 import Simplex.Messaging.Transport.Credentials (genCredentials)
 import Test.Hspec hiding (fit, it)
 import Util
 
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.Main
+#endif
+
 testPublicAuthKey :: C.APublicAuthKey
 testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
 

tests/CoreTests/TRcvQueuesTests.hs

@@ -1,213 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module CoreTests.TRcvQueuesTests where
-
-import AgentTests.EqInstances ()
-import qualified Data.ByteString.Char8 as B
-import qualified Data.List.NonEmpty as L
-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 (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 (..), QueueMode (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC)
-import Test.Hspec hiding (fit, it)
-import UnliftIO
-import Util
-
-tRcvQueuesTests :: Spec
-tRcvQueuesTests = do
-  describe "connection API" $ do
-    it "hasConn" hasConnTest
-    it "hasConn, batch add" hasConnTestBatch
-    it "hasConn, batch idempotent" batchIdempotentTest
-    it "deleteConn" deleteConnTest
-  describe "session API" $ do
-    it "getSessQueues" getSessQueuesTest
-    it "getDelSessQueues" getDelSessQueuesTest
-  describe "queue transfer" $ do
-    it "getDelSessQueues-batchAddQueues preserves total length" removeSubsTest
-
-instance IsString EntityId where fromString = EntityId . B.pack
-
-checkDataInvariant :: RQ.Queue q => RQ.TRcvQueues q -> IO Bool
-checkDataInvariant trq = atomically $ do
-  conns <- readTVar $ RQ.getConnections trq
-  qs <- readTVar $ RQ.getRcvQueues trq
-  -- three invariant checks
-  let inv1 = all (\cId -> (S.fromList . L.toList <$> M.lookup cId conns) == Just (M.keysSet (M.filter (\q -> RQ.connId' q == cId) qs))) (M.keys conns)
-      inv2 = all (\(k, q) -> maybe False ((k `elem`) . L.toList) (M.lookup (RQ.connId' q) conns)) (M.assocs qs)
-      inv3 = all (\(k, q) -> RQ.qKey q == k) (M.assocs qs)
-  pure $ inv1 && inv2 && inv3
-
-hasConnTest :: IO ()
-hasConnTest = do
-  trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
-  atomically (RQ.hasConn "nope" trq) `shouldReturn` False
-
-hasConnTestBatch :: IO ()
-hasConnTestBatch = do
-  trq <- RQ.empty
-  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"]
-  atomically $ RQ.batchAddQueues trq qs
-  checkDataInvariant trq `shouldReturn` True
-  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
-  atomically (RQ.hasConn "nope" trq) `shouldReturn` False
-
-batchIdempotentTest :: IO ()
-batchIdempotentTest = do
-  trq <- RQ.empty
-  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"]
-  atomically $ RQ.batchAddQueues trq qs
-  checkDataInvariant trq `shouldReturn` True
-  qs' <- readTVarIO $ RQ.getRcvQueues trq
-  cs' <- readTVarIO $ RQ.getConnections trq
-  atomically $ RQ.batchAddQueues trq qs
-  checkDataInvariant trq `shouldReturn` True
-  readTVarIO (RQ.getRcvQueues trq) `shouldReturn` qs'
-  fmap L.nub <$> readTVarIO (RQ.getConnections trq) `shouldReturn` cs' -- connections get duplicated, but that doesn't appear to affect anybody
-
-deleteConnTest :: IO ()
-deleteConnTest = do
-  trq <- RQ.empty
-  atomically $ do
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.deleteConn "c1" trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.deleteConn "nope" trq
-  checkDataInvariant trq `shouldReturn` True
-  M.keys <$> readTVarIO (RQ.getConnections trq) `shouldReturn` ["c2", "c3"]
-
-getSessQueuesTest :: IO ()
-getSessQueuesTest = do
-  trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
-  checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") trq
-  checkDataInvariant trq `shouldReturn` True
-  let tSess1 = (0, "smp://1234-w==@alpha", Just "c1")
-  RQ.getSessQueues tSess1 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"]
-  atomically (RQ.hasSessQueues tSess1 trq) `shouldReturn` True
-  let tSess2 = (1, "smp://1234-w==@alpha", Just "c1")
-  RQ.getSessQueues tSess2 trq `shouldReturn` []
-  atomically (RQ.hasSessQueues tSess2 trq) `shouldReturn` False
-  let tSess3 = (0, "smp://1234-w==@alpha", Just "nope")
-  RQ.getSessQueues tSess3 trq `shouldReturn` []
-  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
-
-getDelSessQueuesTest :: IO ()
-getDelSessQueuesTest = do
-  trq <- RQ.empty
-  let qs =
-        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"),
-          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"),
-          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"),
-          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4")
-        ]
-  atomically $ RQ.batchAddQueues trq qs
-  checkDataInvariant trq `shouldReturn` True
-  -- no user
-  atomically (RQ.getDelSessQueues (2, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([], [])
-  checkDataInvariant trq `shouldReturn` True
-  -- wrong user
-  atomically (RQ.getDelSessQueues (1, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([], [])
-  checkDataInvariant trq `shouldReturn` True
-  -- connections intact
-  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
-  atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"], ["c1", "c2"])
-  checkDataInvariant trq `shouldReturn` True
-  -- connections gone
-  atomically (RQ.hasConn "c1" trq) `shouldReturn` False
-  atomically (RQ.hasConn "c2" trq) `shouldReturn` False
-  -- non-matched connections intact
-  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
-  atomically (RQ.hasConn "c4" trq) `shouldReturn` True
-
-removeSubsTest :: IO ()
-removeSubsTest = do
-  aq <- RQ.empty
-  let qs =
-        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"),
-          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"),
-          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"),
-          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4")
-        ]
-  atomically $ RQ.batchAddQueues aq qs
-
-  pq <- RQ.empty
-  atomically (totalSize aq pq) `shouldReturn` (4, 4)
-
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
-  atomically (totalSize aq pq) `shouldReturn` (4, 4)
-
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "non-existent") "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
-  atomically (totalSize aq pq) `shouldReturn` (4, 4)
-
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@localhost", Nothing) "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
-  atomically (totalSize aq pq) `shouldReturn` (4, 4)
-
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "c3") "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
-  atomically (totalSize aq pq) `shouldReturn` (4, 4)
-
-totalSize :: RQ.TRcvQueues q -> RQ.TRcvQueues q -> STM (Int, Int)
-totalSize a b = do
-  qsizeA <- M.size <$> readTVar (RQ.getRcvQueues a)
-  qsizeB <- M.size <$> readTVar (RQ.getRcvQueues b)
-  csizeA <- M.size <$> readTVar (RQ.getConnections a)
-  csizeB <- M.size <$> readTVar (RQ.getConnections b)
-  pure (qsizeA + qsizeB, csizeA + csizeB)
-
-dummyRQ :: UserId -> SMPServer -> ConnId -> RecipientId -> RcvQueue
-dummyRQ userId server connId rcvId =
-  RcvQueue
-    { userId,
-      connId,
-      server,
-      rcvId,
-      rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
-      rcvDhSecret = "01234567890123456789012345678901",
-      e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
-      e2eDhSecret = Nothing,
-      sndId = NoEntity,
-      queueMode = Just QMMessaging,
-      shortLink = Nothing,
-      clientService = Nothing,
-      status = New,
-      dbQueueId = DBEntityId 0,
-      primary = True,
-      dbReplaceQueueId = Nothing,
-      rcvSwchStatus = Nothing,
-      smpClientVersion = VersionSMPC 123,
-      clientNtfCreds = Nothing,
-      deleteErrors = 0
-    }

tests/CoreTests/TSessionSubs.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module CoreTests.TSessionSubs where
+
+import AgentTests.EqInstances ()
+import Control.Monad
+import qualified Data.ByteString.Char8 as B
+import Data.List (foldl')
+import qualified Data.Map as M
+import Data.String (IsString (..))
+import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
+import Simplex.Messaging.Agent.Store (RcvQueueSub (..))
+import qualified Simplex.Messaging.Agent.TSessionSubs as SS
+import Simplex.Messaging.Client (SMPTransportSession, TransportSessionMode (..))
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer)
+import Simplex.Messaging.Transport (SessionId)
+import Test.Hspec hiding (fit, it)
+import UnliftIO
+import Util
+
+tSessionSubsTests :: Spec
+tSessionSubsTests = it "subscription lifecycle" $ testSessionSubs
+
+instance IsString EntityId where fromString = EntityId . B.pack
+
+dumpSessionSubs :: SS.TSessionSubs -> IO (M.Map SMPTransportSession (Maybe SessionId, (M.Map RecipientId RcvQueueSub, M.Map RecipientId RcvQueueSub)))
+dumpSessionSubs =
+  readTVarIO . SS.sessionSubs
+    >=> mapM (\s -> (,) <$> readTVarIO (SS.subsSessId s) <*> SS.mapSubs id s)
+
+srv1 :: SMPServer
+srv1 = "smp://1234-w==@alpha"
+
+srv2 :: SMPServer
+srv2 = "smp://1234-w==@beta"
+
+testSessionSubs :: IO ()
+testSessionSubs = do
+  ss <- SS.emptyIO
+  ss' <- SS.emptyIO
+  let q1 = dummyRQ 1 srv1 "c1" "r1"
+      q2 = dummyRQ 1 srv1 "c2" "r2"
+      q3 = dummyRQ 1 srv2 "c3" "r3"
+      q4 = dummyRQ 1 srv2 "c4" "r4"
+      tSess1 = (1, srv1, Nothing)
+      tSess2 = (1, srv2, Nothing)
+  atomically (SS.addPendingSub tSess1 q1 ss)
+  atomically (SS.addPendingSub tSess1 q2 ss)
+  atomically (SS.hasPendingSubs tSess1 ss) `shouldReturn` True
+  atomically (SS.hasPendingSubs tSess2 ss) `shouldReturn` False
+  atomically (SS.addPendingSub tSess2 q3 ss)
+  atomically (SS.hasPendingSubs tSess2 ss) `shouldReturn` True
+  atomically (SS.batchAddPendingSubs tSess1 [q1, q2] ss')
+  atomically (SS.batchAddPendingSubs tSess2 [q3] ss')
+  atomically (SS.getPendingSubs tSess1 ss) `shouldReturn` M.fromList [("r1", q1), ("r2", q2)]
+  atomically (SS.getActiveSubs tSess1 ss) `shouldReturn` M.fromList []
+  atomically (SS.getPendingSubs tSess2 ss) `shouldReturn` M.fromList [("r3", q3)]
+  st <- dumpSessionSubs ss
+  dumpSessionSubs ss' `shouldReturn` st
+  countSubs ss `shouldReturn` (0, 3)
+  atomically (SS.hasPendingSub tSess1 (rcvId q1) ss) `shouldReturn` True
+  atomically (SS.hasActiveSub tSess1 (rcvId q1) ss) `shouldReturn` False
+  atomically (SS.hasPendingSub tSess1 (rcvId q4) ss) `shouldReturn` False
+  atomically (SS.hasActiveSub tSess1 (rcvId q4) ss) `shouldReturn` False
+  -- setting active queue without setting session ID would keep it as pending
+  atomically $ SS.addActiveSub tSess1 "123" q1 ss
+  atomically (SS.hasPendingSub tSess1 (rcvId q1) ss) `shouldReturn` True
+  atomically (SS.hasActiveSub tSess1 (rcvId q1) ss) `shouldReturn` False
+  dumpSessionSubs ss `shouldReturn` st
+  countSubs ss `shouldReturn` (0, 3)
+  -- setting active queues
+  atomically $ SS.setSessionId tSess1 "123" ss
+  atomically $ SS.addActiveSub tSess1 "123" q1 ss
+  atomically (SS.hasPendingSub tSess1 (rcvId q1) ss) `shouldReturn` False
+  atomically (SS.hasActiveSub tSess1 (rcvId q1) ss) `shouldReturn` True
+  atomically (SS.getActiveSubs tSess1 ss) `shouldReturn` M.fromList [("r1", q1)]
+  atomically (SS.getPendingSubs tSess1 ss) `shouldReturn` M.fromList [("r2", q2)]
+  countSubs ss `shouldReturn` (1, 2)
+  atomically $ SS.setSessionId tSess2 "456" ss
+  atomically $ SS.addActiveSub tSess2 "456" q4 ss
+  atomically (SS.hasPendingSub tSess2 (rcvId q4) ss) `shouldReturn` False
+  atomically (SS.hasActiveSub tSess2 (rcvId q4) ss) `shouldReturn` True
+  atomically (SS.hasActiveSub tSess1 (rcvId q4) ss) `shouldReturn` False -- wrong transport session
+  atomically (SS.getActiveSubs tSess2 ss) `shouldReturn` M.fromList [("r4", q4)]
+  atomically (SS.getPendingSubs tSess2 ss) `shouldReturn` M.fromList [("r3", q3)]
+  countSubs ss `shouldReturn` (2, 2)
+  -- setting pending queues
+  st' <- dumpSessionSubs ss
+  atomically (SS.setSubsPending TSMUser tSess1 "abc" ss) `shouldReturn` M.empty -- wrong session
+  dumpSessionSubs ss `shouldReturn` st'
+  atomically (SS.setSubsPending TSMUser tSess1 "123" ss) `shouldReturn` M.fromList [("r1", q1)]
+  atomically (SS.getActiveSubs tSess1 ss) `shouldReturn` M.fromList []
+  atomically (SS.getPendingSubs tSess1 ss) `shouldReturn` M.fromList [("r1", q1), ("r2", q2)]
+  countSubs ss `shouldReturn` (1, 3)
+  -- delete subs
+  atomically $ SS.deletePendingSub tSess1 (rcvId q1) ss
+  atomically (SS.getPendingSubs tSess1 ss) `shouldReturn` M.fromList [("r2", q2)]
+  countSubs ss `shouldReturn` (1, 2)
+  atomically $ SS.deleteSub tSess1 (rcvId q2) ss
+  atomically (SS.getPendingSubs tSess1 ss) `shouldReturn` M.fromList []
+  countSubs ss `shouldReturn` (1, 1)
+  atomically (SS.getActiveSubs tSess2 ss) `shouldReturn` M.fromList [("r4", q4)]
+  atomically $ SS.deleteSub tSess2 (rcvId q4) ss
+  atomically (SS.getActiveSubs tSess2 ss) `shouldReturn` M.fromList []
+  countSubs ss `shouldReturn` (0, 1)
+  countSubs ss' `shouldReturn` (0, 3)
+  atomically $ SS.batchDeleteSubs tSess1 [q1, q2] ss'
+  countSubs ss' `shouldReturn` (0, 1)
+
+countSubs :: SS.TSessionSubs -> IO (Int, Int)
+countSubs = fmap (foldl' (\(n1, n2) (_, (m1, m2)) -> (n1 + M.size m1, n2 + M.size m2)) (0, 0)) . dumpSessionSubs
+
+dummyRQ :: UserId -> SMPServer -> ConnId -> RecipientId -> RcvQueueSub
+dummyRQ userId server connId rcvId =
+  RcvQueueSub
+    { userId,
+      connId,
+      server,
+      rcvId,
+      rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
+      status = New,
+      enableNtfs = False,
+      clientNoticeId = Nothing,
+      dbQueueId = 0,
+      primary = True,
+      dbReplaceQueueId = Nothing
+    }

tests/NtfClient.hs

@@ -16,6 +16,7 @@
 module NtfClient where
 
 import Control.Concurrent.STM (retry)
+import Control.Exception (throwIO)
 import Control.Monad
 import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Class
@@ -44,8 +45,10 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
 import Simplex.Messaging.Notifications.Server.Env
+import Simplex.Messaging.Notifications.Server.Main (getVapidKey)
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
+import Simplex.Messaging.Notifications.Server.Push.WebPush (WebPushConfig (..))
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
@@ -124,55 +127,64 @@ testNtfClient client = do
       Right th -> client th
       Left e -> error $ show e
 
-ntfServerCfg :: NtfServerConfig
-ntfServerCfg =
-  NtfServerConfig
-    { transports = [],
-      controlPort = Nothing,
-      controlPortUserAuth = Nothing,
-      controlPortAdminAuth = Nothing,
-      subIdBytes = 24,
-      regCodeBytes = 32,
-      clientQSize = 2,
-      pushQSize = 2,
-      smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
-      apnsConfig =
-        defaultAPNSPushClientConfig
-          { apnsPort = apnsTestPort,
-            caStoreFile = "tests/fixtures/ca.crt"
-          },
-      subsBatchSize = 900,
-      inactiveClientExpiration = Just defaultInactiveClientExpiration,
-      dbStoreConfig = ntfTestDBCfg,
-      ntfCredentials = ntfTestServerCredentials,
-      useServiceCreds = True,
-      periodicNtfsInterval = 1,
-      -- stats config
-      logStatsInterval = Nothing,
-      logStatsStartTime = 0,
-      serverStatsLogFile = "tests/ntf-server-stats.daily.log",
-      serverStatsBackupFile = Nothing,
-      prometheusInterval = Nothing,
-      prometheusMetricsFile = ntfTestPrometheusMetricsFile,
-      ntfServerVRange = supportedServerNTFVRange,
-      transportConfig = mkTransportServerConfig True (Just alpnSupportedNTFHandshakes) False,
-      startOptions = defaultStartOptions
-    }
+ntfServerCfg :: IO NtfServerConfig
+ntfServerCfg = do
+  vapidKey <- getVapidKey "tests/fixtures/vapid.privkey"
+  pure
+    NtfServerConfig
+      { transports = [],
+        controlPort = Nothing,
+        controlPortUserAuth = Nothing,
+        controlPortAdminAuth = Nothing,
+        subIdBytes = 24,
+        regCodeBytes = 32,
+        clientQSize = 2,
+        pushQSize = 2,
+        smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
+        apnsConfig =
+          defaultAPNSPushClientConfig
+            { apnsPort = apnsTestPort,
+              caStoreFile = "tests/fixtures/ca.crt"
+            },
+        wpConfig = WebPushConfig {vapidKey, paddedNtfLength = 3072},
+        subsBatchSize = 900,
+        inactiveClientExpiration = Just defaultInactiveClientExpiration,
+        dbStoreConfig = ntfTestDBCfg,
+        ntfCredentials = ntfTestServerCredentials,
+        useServiceCreds = True,
+        periodicNtfsInterval = 1,
+        -- stats config
+        logStatsInterval = Nothing,
+        logStatsStartTime = 0,
+        serverStatsLogFile = "tests/ntf-server-stats.daily.log",
+        serverStatsBackupFile = Nothing,
+        prometheusInterval = Nothing,
+        prometheusMetricsFile = ntfTestPrometheusMetricsFile,
+        ntfServerVRange = supportedServerNTFVRange,
+        transportConfig = mkTransportServerConfig True (Just alpnSupportedNTFHandshakes) False,
+        startOptions = defaultStartOptions
+      }
 
-ntfServerCfgVPrev :: NtfServerConfig
+ntfServerCfgVPrev :: IO NtfServerConfig
 ntfServerCfgVPrev =
   ntfServerCfg
-    { ntfServerVRange = prevRange $ ntfServerVRange ntfServerCfg,
+    >>= \cfg -> pure $ ntfServerCfgVPrev' cfg
+
+ntfServerCfgVPrev' :: NtfServerConfig -> NtfServerConfig
+ntfServerCfgVPrev' cfg =
+  cfg
+    { ntfServerVRange = prevRange $ ntfServerVRange cfg,
       smpAgentCfg = smpAgentCfg' {smpCfg = smpCfg' {serverVRange = prevRange serverVRange'}}
     }
   where
-    smpAgentCfg' = smpAgentCfg ntfServerCfg
+    smpAgentCfg' = smpAgentCfg cfg
     smpCfg' = smpCfg smpAgentCfg'
     serverVRange' = serverVRange smpCfg'
 
 withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
-withNtfServerThreadOn t port' dbStoreConfig =
-  withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
+withNtfServerThreadOn t port' dbStoreConfig a =
+  ntfServerCfg >>= \cfg ->
+    withNtfServerCfg cfg {transports = [(port', t, False)], dbStoreConfig} a
 
 withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a
 withNtfServerCfg cfg@NtfServerConfig {transports} =
@@ -293,7 +305,8 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
 getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest
-getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do
+getMockNotification _ (WPDeviceToken _ _) = liftIO . throwIO $ userError "Invalid pusher"
+getMockNotification APNSMockServer {notifications} (APNSDeviceToken _ token) = do
   atomically $ TM.lookup token notifications >>= maybe retry readTBQueue
 
 getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest

tests/NtfServerTests.hs

@@ -107,7 +107,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
     (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-    let tkn = DeviceToken PPApnsTest "abcd"
+    let tkn = APNSDeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \apns ->
       smpTest2 t msType $ \rh sh ->
         ntfTest t $ \nh -> do
@@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
           (msgBody, "hello") #== "delivered from queue"
           Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
           -- replace token
-          let tkn' = DeviceToken PPApnsTest "efgh"
+          let tkn' = APNSDeviceToken PPApnsTest "efgh"
           RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
           tId `shouldBe` tId'
           APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <-
@@ -237,7 +237,7 @@ 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
+  let tkn = APNSDeviceToken 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

tests/NtfWPTests.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module NtfWPTests where
+
+import Control.Monad (unless)
+import Control.Monad.Except (runExceptT)
+import qualified Crypto.PubKey.ECC.Types as ECC
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Either (isLeft)
+import Data.IORef (newIORef)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Main (getVapidKey)
+import Simplex.Messaging.Notifications.Server.Push.WebPush (getVapidHeader', wpEncrypt')
+import Test.Hspec hiding (fit, it)
+import Util
+
+ntfWPTests :: Spec
+ntfWPTests = describe "NTF Protocol" $ do
+  it "decode WPDeviceToken from string" testWPDeviceTokenStrEncoding
+  it "decode invalid WPDeviceToken" testInvalidWPDeviceTokenStrEncoding
+  it "Encrypt RFC8291 example" testWPEncryption
+  it "Vapid header cache" testVapidCache
+
+testWPDeviceTokenStrEncoding :: Expectation
+testWPDeviceTokenStrEncoding = do
+  let ts = "webpush https://localhost/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  -- let ts = "apns_null test_ntf_token"
+  -- let ts = "apns_test 11111111222222223333333344444444"
+
+  let auth = either error id $ strDecode "AQ3VfRX3_F38J3ltcmMVRg"
+  let pk = either error id $ strDecode "BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  let params :: WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+  wpPath params `shouldBe` "/secret"
+  let key = wpKey params
+  wpAuth key `shouldBe` auth
+  wpP256dh key `shouldBe` pk
+
+  let pp@(WPP s) :: WPProvider = either error id $ strDecode "webpush https://localhost"
+
+  let parsed = either error id $ strDecode ts
+  parsed `shouldBe` WPDeviceToken pp params
+  -- TODO: strEncoding should be base64url _without padding_
+  -- strEncode parsed `shouldBe` ts
+
+  strEncode s <> wpPath params `shouldBe` "https://localhost/secret"
+
+testInvalidWPDeviceTokenStrEncoding :: Expectation
+testInvalidWPDeviceTokenStrEncoding = do
+  -- http-client parser parseUrlThrow is very very lax,
+  -- e.g "https://#1" is a valid URL. But that is the same parser
+  -- we use to send the requests, so that's fine.
+  let ts = "webpush https://localhost:/ AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM"
+      t = strDecode ts :: Either String DeviceToken
+  t `shouldSatisfy` isLeft
+
+-- | Example from RFC8291
+testWPEncryption :: Expectation
+testWPEncryption = do
+  let clearT :: ByteString = "When I grow up, I want to be a watermelon"
+      pParams :: WPTokenParams = either error id $ strDecode "/push/JzLQ3raZJfFBR0aqvOMsLrt54w4rJUsV BTBZMqHH6r4Tts7J_aSIgg BCVxsr7N_eNgVRqvHtD0zTZsEc6-VV-JvLexhqUzORcxaOzi6-AYWXvTBHm4bjyPjs7Vd8pZGH6SRpkNtoIAiw4"
+      salt :: ByteString = either error id $ strDecode "DGv6ra1nlYgDCS1FRnbzlw"
+      privBS :: ByteString = either error id $ strDecode "yfWPiYE-n46HLnH0KqZOF1fJJU3MYrct3AELtAQ-oRw"
+  asPriv :: ECC.PrivateNumber <- case C.uncompressDecodePrivateNumber privBS of
+    Left e -> fail $ "Cannot decode PrivateNumber from b64 " <> show e
+    Right p -> pure p
+  mCip <- runExceptT $ wpEncrypt' (wpKey pParams) asPriv salt clearT
+  cipher <- case mCip of
+    Left _ -> fail "Cannot encrypt clear text"
+    Right c -> pure c
+  strEncode cipher `shouldBe` "DGv6ra1nlYgDCS1FRnbzlwAAEABBBP4z9KsN6nGRTbVYI_c7VJSPQTBtkgcy27mlmlMoZIIgDll6e3vCYLocInmYWAmS6TlzAC8wEqKK6PBru3jl7A_yl95bQpu6cVPTpK4Mqgkf1CXztLVBSt2Ks3oZwbuwXPXLWyouBWLVWGNWQexSgSxsj_Qulcy4a-fN"
+
+testVapidCache :: Expectation
+testVapidCache = do
+  let wpaud = "https://localhost"
+  let now = 1761900906
+  cache <- newIORef Nothing
+  vapidKey <- getVapidKey "tests/fixtures/vapid.privkey"
+  v1 <- getVapidHeader' now vapidKey cache wpaud
+  v2 <- getVapidHeader' now vapidKey cache wpaud
+  v1 `shouldBe` v2
+  -- we just don't test the signature here
+  v1 `shouldContainBS` "vapid t=eyJ0eXAiOiJKV1QiLCJhbGciOiJFUzI1NiJ9.eyJleHAiOjE3NjE5MDQ1MDYsImF1ZCI6Imh0dHBzOi8vbG9jYWxob3N0Iiwic3ViIjoiaHR0cHM6Ly9naXRodWIuY29tL3NpbXBsZXgtY2hhdC9zaW1wbGV4bXEvIn0."
+  v1 `shouldContainBS` ",k=BIk7ASkEr1A1rJRGXMKi77tAGj3dRouSgZdW6S5pee7a3h7fkvd0OYQixy4yj35UFZt8hd9TwAQiybDK_HJLwJA"
+  v3 <- getVapidHeader' (now + 3600) vapidKey cache wpaud
+  v1 `shouldNotBe` v3
+  v3 `shouldContainBS` "vapid t=eyJ0eXAiOiJKV1QiLCJhbGciOiJFUzI1NiJ9."
+  v3 `shouldContainBS` ",k=BIk7ASkEr1A1rJRGXMKi77tAGj3dRouSgZdW6S5pee7a3h7fkvd0OYQixy4yj35UFZt8hd9TwAQiybDK_HJLwJA"
+
+shouldContainBS :: ByteString -> ByteString -> Expectation
+shouldContainBS actual expected =
+  unless (expected `B.isInfixOf` actual) $
+    expectationFailure $
+      "Expected ByteString to contain:\n"
+        ++ show expected
+        ++ "\nBut got:\n"
+        ++ show actual

tests/PostgresSchemaDump.hs

@@ -12,7 +12,7 @@ import Data.Maybe (fromJust, isJust)
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
 import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -30,12 +30,12 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
     testVerifySchemaDump = do
       savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "")
       savedSchema `deepseq` pure ()
-      void $ createDBStore testDBOpts migrations MCConsole
+      void $ createDBStore testDBOpts migrations (MigrationConfig MCConsole Nothing)
       getSchema srcSchemaPath `shouldReturn` savedSchema
 
     testSchemaMigrations = do
       let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations
-      Right st <- createDBStore testDBOpts noDownMigrations MCError
+      Right st <- createDBStore testDBOpts noDownMigrations (MigrationConfig MCError Nothing)
       mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations
       closeDBStore st
       whenM (doesFileExist testSchemaPath) $ removeFile testSchemaPath
@@ -44,14 +44,14 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
           putStrLn $ "down migration " <> name m
           let downMigr = fromJust $ toDownMigration m
           schema <- getSchema testSchemaPath
-          Migrations.run st $ MTRUp [m]
+          Migrations.run st Nothing $ MTRUp [m]
           schema' <- getSchema testSchemaPath
           schema' `shouldNotBe` schema
-          Migrations.run st $ MTRDown [downMigr]
+          Migrations.run st Nothing $ MTRDown [downMigr]
           unless (name m `elem` skipComparisonForDownMigrations) $ do
             schema'' <- getSchema testSchemaPath
             schema'' `shouldBe` schema
-          Migrations.run st $ MTRUp [m]
+          Migrations.run st Nothing $ MTRUp [m]
           schema''' <- getSchema testSchemaPath
           schema''' `shouldBe` schema'
 

tests/SMPAgentClient.hs

@@ -65,7 +65,8 @@ initAgentServers =
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
       netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
-      presetDomains = []
+      presetDomains = [],
+      presetServers = []
     }
 
 initAgentServers2 :: InitialAgentServers

tests/SMPClient.hs

@@ -274,9 +274,14 @@ serverStoreConfig_ useDbStoreLog = \case
   ASType SQSMemory SMSJournal ->
     ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir}
   ASType SQSPostgres SMSJournal ->
-    let dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
-        storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
-     in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
+    ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
+#if defined(dbServerPostgres)
+  ASType SQSPostgres SMSPostgres ->
+    ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg
+#endif
+  where
+    dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
+    storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
 
 cfgV7 :: AServerConfig
 cfgV7 = updateCfg cfg $ \cfg' -> cfg' {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion}

tests/SMPProxyTests.hs

@@ -224,7 +224,7 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty
 agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
-      (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+      (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
       aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
       (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
@@ -280,7 +280,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- agent connections have to be set up in advance
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
-      (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+      (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
       aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
       (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
@@ -331,7 +331,7 @@ agentViaProxyVersionError =
   withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
     Left (A.BROKER _ (TRANSPORT TEVersion)) <-
       withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
-        (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+        (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
         aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
         A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     pure ()
@@ -351,7 +351,7 @@ agentViaProxyRetryOffline = do
       let pqEnc = CR.PQEncOn
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
-          (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
+          (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
           aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
           (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
           liftIO $ sqSecured `shouldBe` True

tests/ServerTests.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module ServerTests where
 
@@ -42,10 +43,10 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (exportMessages)
-import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
+import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore)
-import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..), newMsgStore)
+import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SMSType (..), SQSType (..), newMsgStore)
 import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
 import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
 import Simplex.Messaging.Transport
@@ -59,6 +60,11 @@ import Test.HUnit
 import Test.Hspec hiding (fit, it)
 import Util
 
+#if defined(dbServerPostgres)
+import CoreTests.MsgStoreTests (testPostgresStoreConfig)
+import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages)
+#endif
+
 serverTests :: SpecWith (ASrvTransport, AStoreType)
 serverTests = do
   describe "SMP queues" $ do
@@ -915,14 +921,27 @@ testRestoreExpireMessages =
     exportStoreMessages :: AStoreType -> IO ()
     exportStoreMessages = \case
       ASType _ SMSJournal -> export
+      ASType _ SMSPostgres -> exportDB
       ASType _ SMSMemory -> pure ()
       where
         export = do
-          ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {quota = 4}
+          ms <- readWriteQueues
+          exportMessages False (StoreJournal ms) testStoreMsgsFile False
+          closeMsgStore ms
+#if defined(dbServerPostgres)
+        exportDB = do
+          readWriteQueues >>= closeMsgStore
+          ms' <- newMsgStore (testPostgresStoreConfig {quota = 4} :: PostgresMsgStoreCfg)
+          _n <- withFile testStoreMsgsFile WriteMode $ exportDbMessages False ms'
+          closeMsgStore ms'
+#else
+        exportDB = error "compiled without server_postgres flag"
+#endif
+        readWriteQueues = do
+          ms <- newMsgStore ((testJournalStoreCfg MQStoreCfg) {quota = 4} :: JournalStoreConfig 'QSMemory)
           readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog
           removeFileIfExists testStoreMsgsFile
-          exportMessages False ms testStoreMsgsFile False
-          closeMsgStore ms
+          pure ms
     runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
       testSMPClient test' `shouldReturn` ()
@@ -1271,11 +1290,11 @@ testBlockMessageQueue =
       pure (rId, sId)
 
     -- TODO [postgres] block via control port
-    withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent
+    withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent Nothing
 
     withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
-      Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
+      Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent Nothing))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
       (sId2, sId) #== "same queue ID in response"
   where
     runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a

tests/Test.hs

@@ -15,7 +15,7 @@ import CoreTests.MsgStoreTests
 import CoreTests.RetryIntervalTests
 import CoreTests.SOCKSSettings
 import CoreTests.StoreLogTests
-import CoreTests.TRcvQueuesTests
+import CoreTests.TSessionSubs
 import CoreTests.UtilTests
 import CoreTests.VersionRangeTests
 import FileDescriptionTests (fileDescriptionTests)
@@ -45,6 +45,7 @@ import AgentTests.SchemaDump (schemaDumpTest)
 #if defined(dbServerPostgres)
 import NtfServerTests (ntfServerTests)
 import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts)
+import NtfWPTests (ntfWPTests)
 import PostgresSchemaDump (postgresSchemaDumpTest)
 import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
 import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
@@ -90,7 +91,7 @@ main = do
 #else
           describe "Store log tests" storeLogTests
 #endif
-          describe "TRcvQueues tests" tRcvQueuesTests
+          describe "TSessionSubs tests" tSessionSubsTests
           describe "Util tests" utilTests
           describe "Agent core tests" agentCoreTests
 #if defined(dbServerPostgres)
@@ -102,9 +103,11 @@ main = do
               ] -- skipComparisonForDownMigrations
               testStoreDBOpts
               "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
-        around_ (postgressBracket testServerDBConnectInfo) $
-          describe "SMP server via TLS, postgres+jornal message store" $
-            before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
+        around_ (postgressBracket testServerDBConnectInfo) $ do
+          -- xdescribe "SMP server via TLS, postgres+jornal message store" $
+          --   before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
+          describe "SMP server via TLS, postgres-only message store" $
+            before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests
 #endif
         describe "SMP server via TLS, jornal message store" $ do
           describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
@@ -125,15 +128,22 @@ main = do
         around_ (postgressBracket ntfTestServerDBConnectInfo) $ do
           describe "Notifications server (SMP server: jornal store)" $
             ntfServerTests (transport @TLS, ASType SQSMemory SMSJournal)
-          around_ (postgressBracket testServerDBConnectInfo) $
-            describe "Notifications server (SMP server: postgres+jornal store)" $
-              ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal)
+          around_ (postgressBracket testServerDBConnectInfo) $ do
+            -- xdescribe "Notifications server (SMP server: postgres+jornal store)" $
+            --   ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal)
+            describe "Notifications server (SMP server: postgres-only store)" $
+              ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
         around_ (postgressBracket testServerDBConnectInfo) $ do
-          describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
-          describe "SMP proxy, postgres+jornal message store" $
-            before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
+          -- xdescribe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
+          describe "SMP client agent, server postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres)
+          -- xdescribe "SMP proxy, postgres+jornal message store" $
+          --   before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
+          describe "SMP proxy, postgres-only message store" $
+            before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
+        describe "NTF WP tests" ntfWPTests
 #endif
-        describe "SMP client agent, jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
+        -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
+        describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
         describe "SMP proxy, jornal message store" $
           before (pure $ ASType SQSMemory SMSJournal) smpProxyTests
         describe "XFTP" $ do

tests/fixtures/vapid.privkey

@@ -0,0 +1,5 @@
+-----BEGIN EC PRIVATE KEY-----
+MHcCAQEEIMTAncBq2I7G3KvW4C8Y8Heg2cbcDTobbGFQFnBiA5M/oAoGCCqGSM49
+AwEHoUQDQgAEiTsBKQSvUDWslEZcwqLvu0AaPd1Gi5KBl1bpLml57treHt+S93Q5
+hCLHLjKPflQVm3yF31PABCLJsMr8ckvAkA==
+-----END EC PRIVATE KEY-----