From 3df24251620af8a33dc0a7993d8db7bafc0265e4 Mon Sep 17 00:00:00 2001
From: Evgeny <evgeny@poberezkin.com>
Date: Mon, 9 Jun 2025 12:47:35 +0100
Subject: [PATCH] smp server: use separate database pool for reading queues and
 creating service records (#1561)

---
 .../Messaging/Server/QueueStore/Postgres.hs     | 17 +++++++++++++----
 1 file changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs
index 20307ac9d..0a1554897 100644
--- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs
+++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs
@@ -210,7 +210,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       mask = E.uninterruptibleMask_ . runExceptT
       cacheSender rId = TM.insert qId rId senders
       loadQueue condition =
-        withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
+        withFastDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
           DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
       cacheQueue rId qRec insertRef = do
         sq <- mkQ True rId qRec -- loaded queue
@@ -391,7 +391,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
   getCreateService st sr@ServiceRec {serviceId = newSrvId, serviceRole, serviceCertHash = XV.Fingerprint fp} =
     withLockMap (serviceLocks st) fp "getCreateService" $ E.uninterruptibleMask_ $ runExceptT $ do
       (serviceId, new) <-
-        withDB "getCreateService" st $ \db ->
+        withFastDB "getCreateService" st $ \db ->
           maybeFirstRow id (DB.query db "SELECT service_id, service_role FROM services WHERE service_cert_hash = ?" (Only (Binary fp))) >>= \case
             Just (serviceId, role)
               | role == serviceRole -> pure $ Right (serviceId, False)
@@ -640,10 +640,19 @@ assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH))
 
 withDB' :: Text -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
 withDB' op st action = withDB op st $ fmap Right . action
+{-# INLINE withDB' #-}
+
+withFastDB :: forall a q. Text -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
+withFastDB op st = withDB_ op st True
+{-# INLINE withFastDB #-}
 
 withDB :: forall a q. Text -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
-withDB op st action =
-  ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure
+withDB op st = withDB_ op st False
+{-# INLINE withDB #-}
+
+withDB_ :: forall a q. Text -> PostgresQueueStore q -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
+withDB_ op st priority action =
+  ExceptT $ E.try (withTransactionPriority (dbStore st) priority action) >>= either logErr pure
   where
     logErr :: E.SomeException -> IO (Either ErrorType a)
     logErr e = logError ("STORE: " <> err) $> Left (STORE err)