From a96e491c2f8dbc472df597389b1007471b2635b9 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 07:12:31 +0000
Subject: [PATCH 01/12] agent, ntf server: add lookupOrInsertIO, use it for
 locks and stats

---
 src/Simplex/Messaging/Agent/Client.hs         | 10 ++++----
 src/Simplex/Messaging/Agent/Lock.hs           | 23 +++++--------------
 .../Messaging/Notifications/Server/Stats.hs   |  5 +---
 src/Simplex/Messaging/TMap.hs                 |  7 ++++++
 4 files changed, 18 insertions(+), 27 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index d892fcad03..6ce01542e5 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -1102,17 +1102,15 @@ withConnLocks AgentClient {connLocks} = withLocksMap connLocks
 {-# INLINE withConnLocks #-}
 
 withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a
-withLockMap = withGetLock . getMapLock
+withLockMap = withGetLock . getPutMapLock
 {-# INLINE withLockMap #-}
 
 withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a
-withLocksMap = withGetLocks . getMapLock
+withLocksMap = withGetLocks . getPutMapLock
 {-# INLINE withLocksMap #-}
 
-getMapLock :: Ord k => TMap k Lock -> k -> STM Lock
-getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
-  where
-    newLock = createLock >>= \l -> TM.insert key l locks $> l
+getPutMapLock :: Ord k => TMap k Lock -> k -> Text -> IO Lock
+getPutMapLock locks key name = TM.lookupOrInsertIO key (newTMVar name) locks >>= either pure (\l -> atomically $ putTMVar l name $> l)
 
 withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
 withClient_ c nm tSess@(_, srv, _) action = do
diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs
index 081c53b680..e7c2dd45bc 100644
--- a/src/Simplex/Messaging/Agent/Lock.hs
+++ b/src/Simplex/Messaging/Agent/Lock.hs
@@ -1,6 +1,5 @@
 module Simplex.Messaging.Agent.Lock
   ( Lock,
-    createLock,
     createLockIO,
     withLock,
     withLock',
@@ -12,7 +11,6 @@ where
 import Control.Monad (void)
 import Control.Monad.Except (ExceptT (..), runExceptT)
 import Control.Monad.IO.Unlift
-import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -22,10 +20,6 @@ import UnliftIO.STM
 
 type Lock = TMVar Text
 
-createLock :: STM Lock
-createLock = newEmptyTMVar
-{-# INLINE createLock #-}
-
 createLockIO :: IO Lock
 createLockIO = newEmptyTMVarIO
 {-# INLINE createLockIO #-}
@@ -40,20 +34,15 @@ withLock' lock name =
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
 
-withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> Text -> m a -> m a
-withGetLock getLock key name a =
+withGetLock :: MonadUnliftIO m => (k -> Text -> IO Lock) -> k -> Text -> m a -> m a
+withGetLock getPutLock key name a =
   E.bracket
-    (atomically $ getPutLock getLock key name)
+    (liftIO $ getPutLock key name)
     (atomically . takeTMVar)
     (const a)
 
-withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> Text -> m a -> m a
-withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
+withGetLocks :: MonadUnliftIO m => (k -> Text -> IO Lock) -> Set k -> Text -> m a -> m a
+withGetLocks getPutLock keys name = E.bracket holdLocks releaseLocks . const
   where
-    holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
+    holdLocks = forConcurrently (S.toList keys) $ \key -> liftIO $ getPutLock key name
     releaseLocks = mapM_ (atomically . takeTMVar)
-
--- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
--- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.
-getPutLock :: (k -> STM Lock) -> k -> Text -> STM Lock
-getPutLock getLock key name = getLock key >>= \l -> putTMVar l name $> l
diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs
index 18a746a8d8..7d093138ae 100644
--- a/src/Simplex/Messaging/Notifications/Server/Stats.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs
@@ -338,8 +338,5 @@ getStatsByServer s = readTVarIO s >>= fmap (StatsByServerData . M.toList) . mapM
 setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO ()
 setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s
 
--- double lookup avoids STM transaction with a shared map in most cases
 incServerStat :: Text -> TMap Text (TVar Int) -> IO ()
-incServerStat h s = TM.lookupIO h s >>= atomically . maybe newServerStat (`modifyTVar'` (+ 1))
-  where
-    newServerStat = TM.lookup h s >>= maybe (TM.insertM h (newTVar 1) s) (`modifyTVar'` (+ 1))
+incServerStat h s = TM.lookupOrInsertIO h (newTVar 1) s >>= either (\_ -> pure ()) (atomically . (`modifyTVar'` (+ 1)))
diff --git a/src/Simplex/Messaging/TMap.hs b/src/Simplex/Messaging/TMap.hs
index b09158d5fb..ed1003f404 100644
--- a/src/Simplex/Messaging/TMap.hs
+++ b/src/Simplex/Messaging/TMap.hs
@@ -14,6 +14,7 @@ module Simplex.Messaging.TMap
     insertM,
     delete,
     lookupInsert,
+    lookupOrInsertIO,
     lookupDelete,
     adjust,
     update,
@@ -77,6 +78,12 @@ lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a)
 lookupInsert k v m = stateTVar m $ M.alterF (,Just v) k
 {-# INLINE lookupInsert #-}
 
+-- double lookup avoids STM transaction with a shared map in most cases
+lookupOrInsertIO :: Ord k => k -> STM a -> TMap k a -> IO (Either a a)
+lookupOrInsertIO k new m = lookupIO k m >>= maybe (atomically lookupOrInsert) (pure . Right)
+  where
+    lookupOrInsert = M.lookup k <$> readTVar m >>= maybe (new >>= \v -> Left v <$ insert k v m) (pure . Right)
+
 lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
 lookupDelete k m = stateTVar m $ M.alterF (,Nothing) k
 {-# INLINE lookupDelete #-}

From 65ddaecd7b40753a7370f77fd7c9325c3d86d5c5 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 09:21:03 +0000
Subject: [PATCH 02/12] agent, server: use lookupOrInsertIO for map entries

---
 src/Simplex/FileTransfer/Client/Agent.hs      | 12 +---
 src/Simplex/Messaging/Agent/Client.hs         | 32 ++++-------
 src/Simplex/Messaging/Agent/Lock.hs           | 21 +++++--
 src/Simplex/Messaging/Client/Agent.hs         | 21 ++++---
 src/Simplex/Messaging/Notifications/Server.hs |  2 +-
 .../Messaging/Notifications/Server/Env.hs     |  2 +-
 src/Simplex/Messaging/Server.hs               | 56 ++++++-------------
 src/Simplex/Messaging/Session.hs              | 16 ++++--
 8 files changed, 76 insertions(+), 86 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
index d5faea92f9..55cae5d3cd 100644
--- a/src/Simplex/FileTransfer/Client/Agent.hs
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -75,7 +75,7 @@ type ME a = ExceptT XFTPClientAgentError IO a
 
 getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
 getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
-  atomically getClientVar >>= either newXFTPClient waitForXFTPClient
+  liftIO getClientVar >>= either newXFTPClient waitForXFTPClient
   where
     connectClient :: ME XFTPClient
     connectClient =
@@ -88,14 +88,8 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
       atomically $ TM.delete srv xftpClients
       logInfo $ "disconnected from " <> showServer srv
 
-    getClientVar :: STM (Either XFTPClientVar XFTPClientVar)
-    getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv xftpClients
-      where
-        newClientVar :: STM XFTPClientVar
-        newClientVar = do
-          var <- newEmptyTMVar
-          TM.insert srv var xftpClients
-          pure var
+    getClientVar :: IO (Either XFTPClientVar XFTPClientVar)
+    getClientVar = TM.lookupOrInsertIO srv newEmptyTMVar xftpClients
 
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 6ce01542e5..bf7ac6ac87 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -408,15 +408,12 @@ getAgentWorker = getAgentWorker' id pure
 
 getAgentWorker' :: forall a k e m. (Ord k, Show k, AnyError e, MonadUnliftIO m) => (a -> Worker) -> (Worker -> STM a) -> String -> Bool -> AgentClient -> k -> TMap k a -> (a -> ExceptT e m ()) -> m a
 getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do
-  atomically (getWorker >>= maybe createWorker whenExists) >>= \w -> runWorker w $> w
+  liftIO (TM.lookupOrInsertIO key createWorker ws) >>= either pure whenExists >>= \w -> runWorker w $> w
   where
     getWorker = TM.lookup key ws
-    createWorker = do
-      w <- fromW =<< newWorker c
-      TM.insert key w ws
-      pure w
+    createWorker = fromW =<< newWorker c
     whenExists w
-      | hasWork = hasWorkToDo (toW w) $> w
+      | hasWork = atomically (hasWorkToDo $ toW w) $> w
       | otherwise = pure w
     runWorker w = runWorkerAsync (toW w) runWork
       where
@@ -696,12 +693,12 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
   unlessM (readTVarIO active) $ throwE INACTIVE
   proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
   ts <- liftIO getCurrentTime
-  (tSess, auth) <- atomically $ proxiedTransportSession proxySrv
+  (tSess, auth) <- liftIO $ proxiedTransportSession proxySrv
   withGetSessVar workerSeq tSess smpClients ts (newProxyClient tSess auth ts) (waitForProxyClient tSess auth)
   where
-    proxiedTransportSession :: SMPServerWithAuth -> STM (SMPTransportSession, Maybe SMP.BasicAuth)
+    proxiedTransportSession :: SMPServerWithAuth -> IO (SMPTransportSession, Maybe SMP.BasicAuth)
     proxiedTransportSession proxySrv = do
-      ProtoServerWithAuth srv auth <- TM.lookup destSess smpProxiedRelays >>= maybe (TM.insert destSess proxySrv smpProxiedRelays $> proxySrv) pure
+      ProtoServerWithAuth srv auth <- either id id <$> TM.lookupOrInsertIO destSess (pure proxySrv) smpProxiedRelays
       pure ((userId, srv, qId), auth)
     newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
     newProxyClient tSess auth ts v = do
@@ -1102,15 +1099,15 @@ withConnLocks AgentClient {connLocks} = withLocksMap connLocks
 {-# INLINE withConnLocks #-}
 
 withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> Text -> m a -> m a
-withLockMap = withGetLock . getPutMapLock
+withLockMap = withGetLock . getMapLock
 {-# INLINE withLockMap #-}
 
 withLocksMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> Text -> m a -> m a
-withLocksMap = withGetLocks . getPutMapLock
+withLocksMap = withGetLocks . getMapLock
 {-# INLINE withLocksMap #-}
 
-getPutMapLock :: Ord k => TMap k Lock -> k -> Text -> IO Lock
-getPutMapLock locks key name = TM.lookupOrInsertIO key (newTMVar name) locks >>= either pure (\l -> atomically $ putTMVar l name $> l)
+getMapLock :: Ord k => TMap k Lock -> k -> IO Lock
+getMapLock locks key = either id id <$> TM.lookupOrInsertIO key createLock locks
 
 withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
 withClient_ c nm tSess@(_, srv, _) action = do
@@ -1960,18 +1957,13 @@ sendInvitation c nm userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {s
 
 getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
 getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
-  atomically createTakeGetLock
+  liftIO createTakeGetLock
   msg_ <- withSMPClient c NRMInteractive rq "GET" $ \smp ->
     getSMPMessage smp rcvPrivateKey rcvId
   mapM decryptMeta msg_
   where
     decryptMeta msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage rq msg
-    createTakeGetLock = TM.alterF takeLock (server, rcvId) $ getMsgLocks c
-      where
-        takeLock l_ = do
-          l <- maybe (newTMVar ()) pure l_
-          takeTMVar l
-          pure $ Just l
+    createTakeGetLock = TM.lookupOrInsertIO (server, rcvId) newEmptyTMVar (getMsgLocks c) >>= either (\_ -> pure ()) (atomically . takeTMVar)
 {-# INLINE getQueueMessage #-}
 
 decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs
index e7c2dd45bc..0068911f00 100644
--- a/src/Simplex/Messaging/Agent/Lock.hs
+++ b/src/Simplex/Messaging/Agent/Lock.hs
@@ -1,5 +1,6 @@
 module Simplex.Messaging.Agent.Lock
   ( Lock,
+    createLock,
     createLockIO,
     withLock,
     withLock',
@@ -11,6 +12,7 @@ where
 import Control.Monad (void)
 import Control.Monad.Except (ExceptT (..), runExceptT)
 import Control.Monad.IO.Unlift
+import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -20,6 +22,10 @@ import UnliftIO.STM
 
 type Lock = TMVar Text
 
+createLock :: STM Lock
+createLock = newEmptyTMVar
+{-# INLINE createLock #-}
+
 createLockIO :: IO Lock
 createLockIO = newEmptyTMVarIO
 {-# INLINE createLockIO #-}
@@ -34,15 +40,18 @@ withLock' lock name =
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
 
-withGetLock :: MonadUnliftIO m => (k -> Text -> IO Lock) -> k -> Text -> m a -> m a
-withGetLock getPutLock key name a =
+withGetLock :: MonadUnliftIO m => (k -> IO Lock) -> k -> Text -> m a -> m a
+withGetLock getLock key name a =
   E.bracket
-    (liftIO $ getPutLock key name)
+    (liftIO $ getPutLock getLock key name)
     (atomically . takeTMVar)
     (const a)
 
-withGetLocks :: MonadUnliftIO m => (k -> Text -> IO Lock) -> Set k -> Text -> m a -> m a
-withGetLocks getPutLock keys name = E.bracket holdLocks releaseLocks . const
+withGetLocks :: MonadUnliftIO m => (k -> IO Lock) -> Set k -> Text -> m a -> m a
+withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
   where
-    holdLocks = forConcurrently (S.toList keys) $ \key -> liftIO $ getPutLock key name
+    holdLocks = forConcurrently (S.toList keys) $ \key -> liftIO $ getPutLock getLock key name
     releaseLocks = mapM_ (atomically . takeTMVar)
+
+getPutLock :: (k -> IO Lock) -> k -> Text -> IO Lock
+getPutLock getLock key name = getLock key >>= \l -> atomically (putTMVar l name) $> l
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index 0d59f00b8f..3969937da0 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -420,7 +420,7 @@ subscribeQueuesNtfs = subscribeQueues_
 
 subscribeQueues_ :: ServiceParty p => SMPClientAgent p -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
 subscribeQueues_ ca srv subs = do
-  atomically $ addPendingSubs ca srv $ L.toList subs
+  addSubsIO_ (pendingQueueSubs ca) srv $ M.fromList $ L.toList subs
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Right smp -> smpSubscribeQueues ca smp srv subs
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
@@ -480,7 +480,7 @@ subscribeServiceNtfs = subscribeService_
 
 subscribeService_ :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPServer -> ServiceSub -> IO ()
 subscribeService_ ca srv serviceSub = do
-  atomically $ setPendingServiceSub ca srv $ Just serviceSub
+  setServiceSubIO_ pendingServiceSubs ca srv $ Just serviceSub
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Right smp -> smpSubscribeService ca smp srv serviceSub
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
@@ -512,7 +512,7 @@ smpSubscribeService ca smp srv serviceSub@(ServiceSub serviceId n idsHash) = cas
     serviceAvailable THClientService {serviceRole, serviceId = serviceId'} =
       serviceId == serviceId' && partyServiceRole (agentParty ca) == serviceRole
     notifyUnavailable = do
-      atomically $ setPendingServiceSub ca srv Nothing
+      setServiceSubIO_ pendingServiceSubs ca srv Nothing
       notify ca $ CAServiceUnavailable srv serviceSub -- this will resubscribe all queues directly
     sessId = sessionId $ thParams smp
 
@@ -534,10 +534,6 @@ addActiveSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, (SessionId, C.APriv
 addActiveSubs = addSubsList_ . activeQueueSubs
 {-# INLINE addActiveSubs #-}
 
-addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> STM ()
-addPendingSubs = addSubsList_ . pendingQueueSubs
-{-# INLINE addPendingSubs #-}
-
 addSubsList_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [(QueueId, s)] -> STM ()
 addSubsList_ subs srv ss = addSubs_ subs srv $ M.fromList ss
   -- where
@@ -549,6 +545,9 @@ addSubs_ subs srv ss =
     Just m -> TM.union ss m
     _ -> TM.insertM srv (newTVar ss) subs
 
+addSubsIO_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> IO ()
+addSubsIO_ subs srv ss = TM.lookupOrInsertIO srv (newTVar ss) subs >>= either (\_ -> pure ()) (atomically . TM.union ss)
+
 setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceSub, SessionId) -> STM ()
 setActiveServiceSub = setServiceSub_ activeServiceSubs
 {-# INLINE setActiveServiceSub #-}
@@ -568,6 +567,14 @@ setServiceSub_ subsSel ca srv sub =
     Just v -> writeTVar v sub
     Nothing -> TM.insertM srv (newTVar sub) (subsSel ca)
 
+setServiceSubIO_ ::
+  (SMPClientAgent p -> TMap SMPServer (TVar (Maybe sub))) ->
+  SMPClientAgent p ->
+  SMPServer ->
+  Maybe sub ->
+  IO ()
+setServiceSubIO_ subsSel ca srv sub = TM.lookupOrInsertIO srv (newTVar sub) (subsSel ca) >>= either (\_ -> pure ()) (atomically . (`writeTVar` sub))
+
 updateActiveServiceSub :: SMPClientAgent p -> SMPServer -> (ServiceSub, SessionId) -> STM ()
 updateActiveServiceSub ca srv sub@(ServiceSub serviceId' n' idsHash', sessId') =
   TM.lookup srv (activeServiceSubs ca) >>= \case
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 51687abddb..735774394c 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -495,7 +495,7 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
     >>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSub)
   where
     getSubscriberVar :: IO (Either SMPSubscriberVar SMPSubscriberVar)
-    getSubscriberVar = atomically . getSessVar subscriberSeq smpServer smpSubscribers =<< getCurrentTime
+    getSubscriberVar = getSessVarIO subscriberSeq smpServer smpSubscribers =<< getCurrentTime
 
     createSMPSubscriber :: SMPSubscriberVar -> IO (Maybe SMPSubscriber)
     createSMPSubscriber v =
diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs
index d7f772a876..1ad6e09b64 100644
--- a/src/Simplex/Messaging/Notifications/Server/Env.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Env.hs
@@ -207,7 +207,7 @@ getPushClient :: NtfPushServer -> PushProvider -> IO (PushProviderClient, PushCl
 getPushClient s@NtfPushServer {apnsConfig = APNSPushClientConfig {reconnectInterval}} pp =
   withRetryIntervalCount reconnectInterval $ \n _delay loop -> do
     ts <- getCurrentTime
-    E.try (atomically (getSessVar (pushClientSeq s) pp (pushClients s) ts) >>= either (newPushClient s pp) waitForPushClient) >>= \case
+    E.try (getSessVarIO (pushClientSeq s) pp (pushClients s) ts >>= either (newPushClient s pp) waitForPushClient) >>= \case
       Right result -> pure result
       Left e
         | n < 2 -> do
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index f38f0f829b..216249c88c 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1768,20 +1768,14 @@ client
               fmap (either ((,Nothing) . err) id) $ liftIO $ runExceptT $ do
                 msg' <- forM msg_ $ \msg -> liftIO $ do
                   ts <- getSystemSeconds
-                  sub <- maybe (atomically getSub) pure sub_
+                  sub <- maybe getSub pure sub_
                   atomically $ setDelivered sub msg ts
                   unless hasSub $ incStat $ qSub stats
                   pure (NoCorrId, entId, MSG (encryptMsg qr msg))
                 pure ((corrId, entId, SOK clntServiceId), msg')
 
-        getSub :: STM Sub
-        getSub =
-          TM.lookup entId (subscriptions clnt) >>= \case
-            Just sub -> pure sub
-            Nothing -> do
-              sub <- newSubscription NoSub
-              TM.insert entId sub $ subscriptions clnt
-              pure sub
+        getSub :: IO Sub
+        getSub = either id id <$> TM.lookupOrInsertIO entId (newSubscription NoSub) (subscriptions clnt)
 
         subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
         subscribeNewQueue rId QueueRec {rcvServiceId} = do
@@ -1795,10 +1789,14 @@ client
         -- clients that use GET are not added to server subscribers
         getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
         getMessage q qr = do
-          atomically (TM.lookup entId $ subscriptions clnt) >>= \case
-            Nothing ->
-              atomically newSub >>= (`getMessage_` Nothing)
-            Just s@Sub {subThread} ->
+          -- Here we don't account for this client as subscribed in the server
+          -- and don't notify other subscribed clients.
+          -- This is tracked as "subscription" in the client to prevent these
+          -- clients from being able to subscribe.
+          liftIO (TM.lookupOrInsertIO entId newProhibitedSub $ subscriptions clnt) >>= \case
+            Left s ->
+              getMessage_ s Nothing
+            Right s@Sub {subThread} ->
               case subThread of
                 ProhibitSub ->
                   atomically (swapTVar (delivered s) Nothing)
@@ -1809,15 +1807,6 @@ client
                   incStat $ msgGetProhibited stats
                   pure $ err $ CMD PROHIBITED
           where
-            newSub :: STM Sub
-            newSub = do
-              s <- newProhibitedSub
-              TM.insert entId s $ subscriptions clnt
-              -- Here we don't account for this client as subscribed in the server
-              -- and don't notify other subscribed clients.
-              -- This is tracked as "subscription" in the client to prevent these
-              -- clients from being able to subscribe.
-              pure s
             getMessage_ :: Sub -> Maybe (MsgId, SystemSeconds) -> M s (Transmission BrokerMsg)
             getMessage_ s delivered_ = do
               stats <- asks serverStats
@@ -1899,21 +1888,15 @@ client
                 incSrvStat srvAssocRemoved
                 -- getSubscription may be Just for receiving service, where clientSubs also hold active deliveries for service subscriptions.
                 -- For notification service it can only be Just if storage and session states diverge.
-                r <- atomically $ getSubscription >>= newSub
+                r <- getSubscription
                 atomically writeSub
                 pure r
               Nothing -> do
-                r@(hasSub, _) <- atomically $ getSubscription >>= newSub
+                r@(hasSub, _) <- getSubscription
                 unless hasSub $ atomically writeSub
                 pure r
               where
-                getSubscription = TM.lookup entId $ clientSubs clnt
-                newSub = \case
-                  Just sub -> pure (True, Just sub)
-                  Nothing -> do
-                    sub <- mkSub
-                    TM.insert entId sub $ clientSubs clnt
-                    pure (False, Just sub)
+                getSubscription = either ((False,) . Just) ((True,) . Just) <$> TM.lookupOrInsertIO entId mkSub (clientSubs clnt)
 
         subscribeServiceMessages :: ServiceId -> (Int64, IdsHash) -> M s BrokerMsg
         subscribeServiceMessages serviceId expected =
@@ -1943,7 +1926,7 @@ client
               Right qMsg_ -> case qMsg_ of
                 Nothing -> pure (qCnt + 1, msgCnt, dupCnt, evts)
                 Just (qr, msg) ->
-                  atomically (getSubscription rId) >>= \case
+                  getSubscription rId >>= \case
                     Nothing -> pure (qCnt + 1, msgCnt, dupCnt + 1, evts)
                     Just sub -> do
                       ts <- getSystemSeconds
@@ -1951,14 +1934,11 @@ client
                       atomically $ writeTBQueue msgQ [(NoCorrId, rId, MSG (encryptMsg qr msg))]
                       pure (qCnt + 1, msgCnt + 1, dupCnt, evts)
             getSubscription rId =
-              TM.lookup rId (subscriptions clnt) >>= \case
+              TM.lookupOrInsertIO rId (newSubscription NoSub) (subscriptions clnt) >>= \case
                 -- If delivery subscription already exists, then there is no need to deliver message.
                 -- It may have been created when the message is sent after service subscription is created.
-                Just _sub -> pure Nothing
-                Nothing -> do
-                  sub <- newSubscription NoSub
-                  TM.insert rId sub $ subscriptions clnt
-                  pure $ Just sub
+                Right _sub -> pure Nothing
+                Left sub -> pure $ Just sub
 
         subscribeServiceNotifications :: ServiceId -> (Int64, IdsHash) -> M s BrokerMsg
         subscribeServiceNotifications serviceId expected =
diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs
index 16ff3c934e..d979d2042f 100644
--- a/src/Simplex/Messaging/Session.hs
+++ b/src/Simplex/Messaging/Session.hs
@@ -5,6 +5,7 @@
 module Simplex.Messaging.Session
   ( SessionVar (..),
     getSessVar,
+    getSessVarIO,
     removeSessVar,
     withGetSessVar,
     withGetSessVar',
@@ -32,12 +33,19 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur
   where
     newSessionVar :: STM (SessionVar a)
     newSessionVar = do
-      sessionVar <- newEmptyTMVar
-      sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
-      let v = SessionVar {sessionVar, sessionVarId, sessionVarTs}
+      v <- createSessionVar sessSeq sessionVarTs
       TM.insert sessKey v vs
       pure v
 
+getSessVarIO :: Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> IO (Either (SessionVar a) (SessionVar a))
+getSessVarIO sessSeq sessKey vs sessionVarTs = TM.lookupOrInsertIO sessKey (createSessionVar sessSeq sessionVarTs) vs
+
+createSessionVar :: TVar Int -> UTCTime -> STM (SessionVar a)
+createSessionVar sessSeq sessionVarTs = do
+  sessionVar <- newEmptyTMVar
+  sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
+  pure SessionVar {sessionVar, sessionVarId, sessionVarTs}
+
 removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
 removeSessVar v sessKey vs =
   TM.lookup sessKey vs >>= \case
@@ -64,7 +72,7 @@ withGetSessVar' ::
   (SessionVar a -> m b) -> (SessionVar a -> m b) -> m b
 withGetSessVar' sessSeq sessKey vs ts onNew onExisting =
   bracketOnError
-    (liftIO $ atomically $ getSessVar sessSeq sessKey vs ts)
+    (liftIO $ getSessVarIO sessSeq sessKey vs ts)
     (either (liftIO . atomically . dropEmptySessVar) (\_ -> pure ()))
     (either onNew onExisting)
   where

From 2372c0fa86534ef88345996cdd4275a94cc1c399 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 09:47:44 +0000
Subject: [PATCH 03/12] agent: use lookupOrInsertIO for server stats, keep GET
 lock in one transaction

---
 src/Simplex/FileTransfer/Agent.hs             | 22 +++----
 src/Simplex/Messaging/Agent.hs                | 36 +++++------
 src/Simplex/Messaging/Agent/Client.hs         | 60 ++++++++++++-------
 .../Messaging/Agent/NtfSubSupervisor.hs       |  6 +-
 src/Simplex/Messaging/Client/Agent.hs         | 13 ++--
 src/Simplex/Messaging/TMap.hs                 |  1 +
 6 files changed, 77 insertions(+), 61 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index d839833630..0f7b19b65e 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -210,7 +210,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            atomically $ incXFTPServerStat c userId srv downloadAttempts
+            incXFTPServerStat c userId srv downloadAttempts
             downloadFileChunk fc replica approvedRelays
               `catchAllErrors` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
@@ -222,7 +222,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
               liftIO $ assertAgentForeground c
               loop
             retryDone e = do
-              atomically . incXFTPServerStat c userId srv $ case e of
+              incXFTPServerStat c userId srv $ case e of
                 XFTP _ XFTP.AUTH -> downloadAuthErrs
                 _ -> downloadErrs
               rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) e
@@ -247,8 +247,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do
               Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize)
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
         pure (entityId, complete, RFPROG rcvd total)
-      atomically $ incXFTPServerStat c userId srv downloads
-      atomically $ incXFTPServerSizeStat c userId srv downloadsSize (fromIntegral $ toKB chSize)
+      incXFTPServerStat c userId srv downloads
+      incXFTPServerSizeStat c userId srv downloadsSize (fromIntegral $ toKB chSize)
       notify c entityId progress
       when complete . lift . void $
         getXFTPRcvWorker True c Nothing
@@ -536,7 +536,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            atomically $ incXFTPServerStat c userId srv uploadAttempts
+            incXFTPServerStat c userId srv uploadAttempts
             uploadFileChunk cfg fc replica
               `catchAllErrors` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
@@ -548,7 +548,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
               liftIO $ assertAgentForeground c
               loop
             retryDone e = do
-              atomically $ incXFTPServerStat c userId srv uploadErrs
+              incXFTPServerStat c userId srv uploadErrs
               sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) e
     uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM ()
     uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath, chunkSize = chSize}, digest = chunkDigest} replica = do
@@ -566,8 +566,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
       let uploaded = uploadedSize chunks
           total = totalSize chunks
           complete = all chunkUploaded chunks
-      atomically $ incXFTPServerStat c userId srv uploads
-      atomically $ incXFTPServerSizeStat c userId srv uploadsSize (fromIntegral $ toKB chSize)
+      incXFTPServerStat c userId srv uploads
+      incXFTPServerSizeStat c userId srv uploadsSize (fromIntegral $ toKB chSize)
       notify c sndFileEntityId $ SFPROG uploaded total
       when complete $ do
         (sndDescr, rcvDescrs) <- sndFileToDescrs sf
@@ -715,7 +715,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            atomically $ incXFTPServerStat c userId srv deleteAttempts
+            incXFTPServerStat c userId srv deleteAttempts
             deleteChunkReplica
               `catchAllErrors` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
@@ -727,12 +727,12 @@ runXFTPDelWorker c srv Worker {doWork} = do
               liftIO $ assertAgentForeground c
               loop
             retryDone e = do
-              atomically $ incXFTPServerStat c userId srv deleteErrs
+              incXFTPServerStat c userId srv deleteErrs
               delWorkerInternalError c deletedSndChunkReplicaId e
             deleteChunkReplica = do
               agentXFTPDeleteChunk c userId replica
               withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
-              atomically $ incXFTPServerStat c userId srv deletions
+              incXFTPServerStat c userId srv deletions
 
 delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
 delWorkerInternalError c deletedSndChunkReplicaId e = do
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 5862f3b7cd..72c0a14eae 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1169,7 +1169,7 @@ createRcvQueue c nm userId connId srvWithAuth@(ProtoServerWithAuth srv _) enable
   (rq, qUri, tSess, sessId, serviceId_) <-
     newRcvQueue_ c nm userId connId srvWithAuth vr qd (isJust ntfServer_) subMode nonce_ e2eKeys
       `catchAllErrors` \e -> liftIO (print e) >> throwE e
-  atomically $ incSMPServerStat c userId srv connCreated
+  incSMPServerStatIO c userId srv connCreated
   rq' <- withStore c $ \db -> updateNewConnRcv db connId rq subMode
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId serviceId_
   mapM_ (newQueueNtfSubscription c rq') ntfServer_
@@ -1709,7 +1709,7 @@ createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue ->
 createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
   ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
   (rq, qUri, tSess, sessId, serviceId_) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation (isJust ntfServer_) subMode
-  atomically $ incSMPServerStat c userId (qServer rq) connCreated
+  incSMPServerStatIO c userId (qServer rq) connCreated
   let qInfo = toVersionT qUri smpClientVersion
   rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq subMode
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId serviceId_
@@ -2426,7 +2426,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
           secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM ()
           secure rq@RcvQueue {server} senderKey = do
             secureQueue c NRMBackground rq senderKey
-            atomically $ incSMPServerStat c userId server connSecured
+            incSMPServerStatIO c userId server connSecured
             withStore' c $ \db -> setRcvQueueStatus db rq Secured
       where
         withServer a = case server_ of
@@ -2647,7 +2647,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
               let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e
               case e of
                 SMP _ SMP.QUOTA -> do
-                  atomically $ incSMPServerStat c userId server sentQuotaErrs
+                  incSMPServerStatIO c userId server sentQuotaErrs
                   case msgType of
                     AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                     AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -2659,7 +2659,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                           notify $ MWARN (unId msgId) e
                           retrySndMsg RISlow
                 SMP _ SMP.AUTH -> do
-                  atomically $ incSMPServerStat c userId server sentAuthErrs
+                  incSMPServerStatIO c userId server sentAuthErrs
                   case msgType of
                     AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                     AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -2698,7 +2698,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                           when (serverHostError e) $ notify $ MWARN (unId msgId) e
                           retrySndMsg RIFast
                   | otherwise -> do
-                      atomically $ incSMPServerStat c userId server sentOtherErrs
+                      incSMPServerStatIO c userId server sentOtherErrs
                       notifyDel msgId err
               where
                 retrySndMsg riMode = do
@@ -2725,7 +2725,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                       -- because it can be sent before HELLO is received
                       -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO
                       when (status == Active) $ do
-                        atomically $ incSMPServerStat c userId (qServer rq) connCompleted
+                        incSMPServerStatIO c userId (qServer rq) connCompleted
                         notify $ CON pqEncryption
                     -- this branch should never be reached as receive queue is created before the confirmation,
                     _ -> logError "HELLO sent without receive queue"
@@ -2800,7 +2800,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
         pure msgIds_
       forM_ (L.nonEmpty msgIds_) $ \msgIds -> do
         notify $ MERRS (L.map unId msgIds) err
-      atomically $ incSMPServerStat' c userId server sentExpiredErrs (length msgIds_ + 1)
+      incSMPServerStatIO' c userId server sentExpiredErrs (length msgIds_ + 1)
     delMsg :: InternalId -> AM ()
     delMsg = delMsgKeep False
     delMsgKeep :: Bool -> InternalId -> AM ()
@@ -2959,16 +2959,16 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
 
 ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM (Maybe ATransmission)
 ackQueueMessage c rq@RcvQueue {userId, connId, server, rcvSwchStatus} srvMsgId = do
-  atomically $ incSMPServerStat c userId server ackAttempts
+  incSMPServerStatIO c userId server ackAttempts
   tryAllErrors (sendAck c rq srvMsgId) >>= \case
     Right drained -> sendMsgNtf ackMsgs $ drained && rcvSwchStatus == Just RSReceivedQEND
     Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs False
     Left e -> do
-      unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs
+      unless (temporaryOrHostError e) $ incSMPServerStatIO c userId server ackOtherErrs
       throwE e
   where
     sendMsgNtf stat ended = do
-      atomically $ incSMPServerStat c userId server stat
+      incSMPServerStatIO c userId server stat
       ifM (liftIO $ hasGetLock c rq)
         (do atomically $ releaseGetLock c rq
             brokerTs_ <- eitherToMaybe <$> tryAllErrors (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId)
@@ -3084,7 +3084,7 @@ deleteConnQueues c nm waitDelivery ntf rqs = do
             | otherwise -> do
                 deleteConnRcvQueue db rq
                 -- attempts and successes are counted in deleteQueues function
-                atomically $ incSMPServerStat c userId server connDeleted
+                incSMPServerStatIO c userId server connDeleted
                 pure ((rq, Right ()), Just (Just e))
     notify = when ntf . atomically . writeTBQueue (subQ c)
     connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
@@ -3626,7 +3626,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
   connIds <- readTVarIO upConnIds
   unless (null connIds) $ do
     notify' "" $ UP srv connIds
-    atomically $ incSMPServerStat' c userId srv connSubscribed $ length connIds
+    incSMPServerStatIO' c userId srv connSubscribed $ length connIds
   readTVarIO serviceRQs >>= processRcvServiceAssocs c srv
   where
     withRcvConn :: SMP.RecipientId -> (forall c. RcvQueue -> Connection c -> AM ()) -> AM' ()
@@ -3679,7 +3679,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
       pendingMsgs =
         withConnLock c connId "processSMP" $ case smpMsg of
           SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> do
-            atomically $ incSMPServerStat c userId srv recvMsgs
+            incSMPServerStatIO c userId srv recvMsgs
             void . handleNotifyAck $ do
               msg' <- decryptSMPMessage rq msg
               handleNotifyAck $ case msg' of
@@ -3765,7 +3765,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                 | otherwise = pure conn'
                           Right Nothing -> prohibited "msg: bad agent msg" >> ack
                           Left e@(AGENT A_DUPLICATE {}) -> do
-                            atomically $ incSMPServerStat c userId srv recvDuplicates
+                            incSMPServerStatIO c userId srv recvDuplicates
                             withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
                               Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
                                 | userAck -> ackDel internalId
@@ -3788,7 +3788,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                           _ -> ack
                               _ -> checkDuplicateHash e encryptedMsgHash >> ack
                           Left (AGENT (A_CRYPTO e)) -> do
-                            atomically $ incSMPServerStat c userId srv recvCryptoErrs
+                            incSMPServerStatIO c userId srv recvCryptoErrs
                             exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash
                             unless exists notifySync
                             ack
@@ -3803,7 +3803,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                   notify $ RSYNC rss' (Just e) cStats
                                   withStore' c $ \db -> setConnRatchetSync db connId rss'
                           Left e -> do
-                            atomically $ incSMPServerStat c userId srv recvErrs
+                            incSMPServerStatIO c userId srv recvErrs
                             checkDuplicateHash e encryptedMsgHash >> ack
                         where
                           checkDuplicateHash :: AgentErrorType -> ByteString -> AM ()
@@ -4047,7 +4047,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                     -- this branch is executed by the accepting party in duplexHandshake mode (v2)
                     -- (was executed by initiating party in v1 that is no longer supported)
                     | sndStatus == Active -> do
-                        atomically $ incSMPServerStat c userId srv connCompleted
+                        incSMPServerStatIO c userId srv connCompleted
                         notify $ CON pqEncryption
                     | otherwise -> enqueueDuplexHello sq
                   _ -> pure ()
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index bf7ac6ac87..4adf5a0b5e 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -173,6 +173,8 @@ module Simplex.Messaging.Agent.Client
     withNextSrv,
     incSMPServerStat,
     incSMPServerStat',
+    incSMPServerStatIO,
+    incSMPServerStatIO',
     incXFTPServerStat,
     incXFTPServerStat',
     incXFTPServerSizeStat,
@@ -413,7 +415,7 @@ getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do
     getWorker = TM.lookup key ws
     createWorker = fromW =<< newWorker c
     whenExists w
-      | hasWork = atomically (hasWorkToDo $ toW w) $> w
+      | hasWork = atomically $ hasWorkToDo (toW w) $> w
       | otherwise = pure w
     runWorker w = runWorkerAsync (toW w) runWork
       where
@@ -1161,11 +1163,11 @@ sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags
   fst <$> sendOrProxySMPCommand c nm userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
   where
     sendViaProxy smp proxySess = do
-      atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
-      atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts
+      incSMPServerStatIO c userId destSrv sentViaProxyAttempts
+      incSMPServerStatIO c userId (protocolClientServer' smp) sentProxiedAttempts
       proxySMPMessage smp nm proxySess spKey_ senderId msgFlags msg
     sendDirectly smp = do
-      atomically $ incSMPServerStat c userId destSrv sentDirectAttempts
+      incSMPServerStatIO c userId destSrv sentDirectAttempts
       sendSMPMessage smp nm spKey_ senderId msgFlags msg
 
 sendOrProxySMPCommand ::
@@ -1241,8 +1243,8 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn
               sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
       case r of
         Right r'@(srv_, _) -> do
-          atomically $ incSMPServerStat c userId destSrv sentViaProxy
-          forM_ srv_ $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
+          incSMPServerStatIO c userId destSrv sentViaProxy
+          forM_ srv_ $ \proxySrv -> incSMPServerStatIO c userId proxySrv sentProxied
           pure r'
         Left e
           | serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
@@ -1250,7 +1252,7 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn
     sendDirectly tSess =
       withLogClient_ c nm tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
         tryAllErrors (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case
-          Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect)
+          Right r -> r <$ incSMPServerStatIO c userId destSrv sentDirect
           Left e -> throwE e
 
 ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
@@ -1706,7 +1708,7 @@ subscribeSessQueues_ c withEvents qs = sendClientBatch_ "SUB" False subscribe_ c
     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'
+      incSMPServerStatIO' c userId srv connSubAttempts $ length qs'
       rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs'
       cs_ <-
         if withEvents
@@ -1957,13 +1959,18 @@ sendInvitation c nm userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {s
 
 getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
 getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
-  liftIO createTakeGetLock
+  atomically createTakeGetLock
   msg_ <- withSMPClient c NRMInteractive rq "GET" $ \smp ->
     getSMPMessage smp rcvPrivateKey rcvId
   mapM decryptMeta msg_
   where
     decryptMeta msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage rq msg
-    createTakeGetLock = TM.lookupOrInsertIO (server, rcvId) newEmptyTMVar (getMsgLocks c) >>= either (\_ -> pure ()) (atomically . takeTMVar)
+    createTakeGetLock = TM.alterF takeLock (server, rcvId) $ getMsgLocks c
+      where
+        takeLock l_ = do
+          l <- maybe (newTMVar ()) pure l_
+          takeTMVar l
+          pure $ Just l
 {-# INLINE getQueueMessage #-}
 
 decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
@@ -2106,10 +2113,10 @@ deleteQueues c nm = sendTSessionBatches "DEL" mkSMPTSession deleteQueues_ c nm
   where
     deleteQueues_ smp rqs = do
       let (userId, srv, _) = transportSession' smp
-      atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs
+      incSMPServerStatIO' c userId srv connDelAttempts $ length rqs
       rs <- sendBatch deleteSMPQueues smp nm rqs
       let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs
-      atomically $ incSMPServerStat' c userId srv connDeleted successes
+      incSMPServerStatIO' c userId srv connDeleted successes
       pure rs
 
 -- This is only used in background
@@ -2569,28 +2576,34 @@ incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1
 incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM ()
 incSMPServerStat' = incServerStat (\AgentClient {smpServersStats = s} -> s) newAgentSMPServerStats
 
-incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM ()
+incSMPServerStatIO :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> m ()
+incSMPServerStatIO c userId srv sel = incSMPServerStatIO' c userId srv sel 1
+
+incSMPServerStatIO' :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> m ()
+incSMPServerStatIO' = incServerStatIO (\AgentClient {smpServersStats = s} -> s) newAgentSMPServerStats
+
+incXFTPServerStat :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> m ()
 incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1
 {-# INLINE incXFTPServerStat #-}
 
-incXFTPServerStat' :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> STM ()
+incXFTPServerStat' :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> m ()
 incXFTPServerStat' = incXFTPServerStat_
 {-# INLINE incXFTPServerStat' #-}
 
-incXFTPServerSizeStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> STM ()
+incXFTPServerSizeStat :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> m ()
 incXFTPServerSizeStat = incXFTPServerStat_
 {-# INLINE incXFTPServerSizeStat #-}
 
-incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM ()
-incXFTPServerStat_ = incServerStat (\AgentClient {xftpServersStats = s} -> s) newAgentXFTPServerStats
+incXFTPServerStat_ :: (MonadIO m, Num n) => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> m ()
+incXFTPServerStat_ = incServerStatIO (\AgentClient {xftpServersStats = s} -> s) newAgentXFTPServerStats
 {-# INLINE incXFTPServerStat_ #-}
 
-incNtfServerStat :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> STM ()
+incNtfServerStat :: MonadIO m => AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> m ()
 incNtfServerStat c userId srv sel = incNtfServerStat' c userId srv sel 1
 {-# INLINE incNtfServerStat #-}
 
-incNtfServerStat' :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> Int -> STM ()
-incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats
+incNtfServerStat' :: MonadIO m => AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> Int -> m ()
+incNtfServerStat' = incServerStatIO (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats
 {-# INLINE incNtfServerStat' #-}
 
 incServerStat :: Num n => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> STM ()
@@ -2602,6 +2615,13 @@ incServerStat statsSel mkNewStats c userId srv sel n = do
       modifyTVar' (sel newStats) (+ n)
       TM.insert (userId, srv) newStats (statsSel c)
 
+incServerStatIO :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
+incServerStatIO statsSel mkNewStats c userId srv sel n =
+  liftIO $ TM.lookupOrInsertIO (userId, srv) newStats (statsSel c) >>= either (\_ -> pure ()) (atomically . incStat)
+  where
+    newStats = mkNewStats >>= \s -> s <$ incStat s
+    incStat s = modifyTVar' (sel s) (+ n)
+
 data AgentServersSummary = AgentServersSummary
   { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
     xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData,
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 7153abcbfd..b86fbd5eb6 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -323,7 +323,7 @@ runNtfWorker c srv Worker {doWork} =
     incStatByUserId :: NtfServer -> (AgentNtfServerStats -> TVar Int) -> [NtfSubscription] -> AM' ()
     incStatByUserId ntfServer sel ss =
       forM_ (M.assocs userIdsCounts) $ \(userId, count) ->
-        atomically $ incNtfServerStat' c userId ntfServer sel count
+        incNtfServerStat' c userId ntfServer sel count
       where
         userIdsCounts = foldl' (\acc NtfSubscription {userId} -> M.insertWith (+) userId 1 acc) M.empty ss
     -- NSADelete and NSARotate are deprecated, but their processing is kept for legacy db records;
@@ -361,10 +361,10 @@ runNtfWorker c srv Worker {doWork} =
       Just nSubId ->
         lift getNtfToken >>= \case
           Just tkn@NtfToken {ntfServer} -> do
-            atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
+            incNtfServerStat c userId ntfServer ntfDelAttempts
             tryAllErrors (agentNtfDeleteSubscription c nSubId tkn) >>= \case
               Right _ -> do
-                atomically $ incNtfServerStat c userId ntfServer ntfDeleted
+                incNtfServerStat c userId ntfServer ntfDeleted
                 continue'
               Left e
                 | temporaryOrHostError e -> pure $ Just sub -- don't continue, retry
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index 3969937da0..f0b036d979 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -480,7 +480,7 @@ subscribeServiceNtfs = subscribeService_
 
 subscribeService_ :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPServer -> ServiceSub -> IO ()
 subscribeService_ ca srv serviceSub = do
-  setServiceSubIO_ pendingServiceSubs ca srv $ Just serviceSub
+  setServiceSubIO_ (pendingServiceSubs ca) srv $ Just serviceSub
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Right smp -> smpSubscribeService ca smp srv serviceSub
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
@@ -512,7 +512,7 @@ smpSubscribeService ca smp srv serviceSub@(ServiceSub serviceId n idsHash) = cas
     serviceAvailable THClientService {serviceRole, serviceId = serviceId'} =
       serviceId == serviceId' && partyServiceRole (agentParty ca) == serviceRole
     notifyUnavailable = do
-      setServiceSubIO_ pendingServiceSubs ca srv Nothing
+      setServiceSubIO_ (pendingServiceSubs ca) srv Nothing
       notify ca $ CAServiceUnavailable srv serviceSub -- this will resubscribe all queues directly
     sessId = sessionId $ thParams smp
 
@@ -567,13 +567,8 @@ setServiceSub_ subsSel ca srv sub =
     Just v -> writeTVar v sub
     Nothing -> TM.insertM srv (newTVar sub) (subsSel ca)
 
-setServiceSubIO_ ::
-  (SMPClientAgent p -> TMap SMPServer (TVar (Maybe sub))) ->
-  SMPClientAgent p ->
-  SMPServer ->
-  Maybe sub ->
-  IO ()
-setServiceSubIO_ subsSel ca srv sub = TM.lookupOrInsertIO srv (newTVar sub) (subsSel ca) >>= either (\_ -> pure ()) (atomically . (`writeTVar` sub))
+setServiceSubIO_ :: TMap SMPServer (TVar (Maybe sub)) -> SMPServer -> Maybe sub -> IO ()
+setServiceSubIO_ subs srv sub = TM.lookupOrInsertIO srv (newTVar sub) subs >>= either (\_ -> pure ()) (atomically . (`writeTVar` sub))
 
 updateActiveServiceSub :: SMPClientAgent p -> SMPServer -> (ServiceSub, SessionId) -> STM ()
 updateActiveServiceSub ca srv sub@(ServiceSub serviceId' n' idsHash', sessId') =
diff --git a/src/Simplex/Messaging/TMap.hs b/src/Simplex/Messaging/TMap.hs
index ed1003f404..b8d447118e 100644
--- a/src/Simplex/Messaging/TMap.hs
+++ b/src/Simplex/Messaging/TMap.hs
@@ -83,6 +83,7 @@ lookupOrInsertIO :: Ord k => k -> STM a -> TMap k a -> IO (Either a a)
 lookupOrInsertIO k new m = lookupIO k m >>= maybe (atomically lookupOrInsert) (pure . Right)
   where
     lookupOrInsert = M.lookup k <$> readTVar m >>= maybe (new >>= \v -> Left v <$ insert k v m) (pure . Right)
+{-# INLINE lookupOrInsertIO #-}
 
 lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
 lookupDelete k m = stateTVar m $ M.alterF (,Nothing) k

From 3f52646797171886f46c6e4b29b948ddfee40a50 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 10:10:08 +0000
Subject: [PATCH 04/12] smp server: update getSubscription comment for
 lookupOrInsertIO result

---
 src/Simplex/Messaging/Server.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 216249c88c..db4c3fd3ad 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1886,8 +1886,8 @@ client
               Just _ -> do
                 -- unassociation already done in prepareBatchSubs
                 incSrvStat srvAssocRemoved
-                -- getSubscription may be Just for receiving service, where clientSubs also hold active deliveries for service subscriptions.
-                -- For notification service it can only be Just if storage and session states diverge.
+                -- getSubscription may find a subscription for receiving service, where clientSubs also hold active deliveries for service subscriptions.
+                -- For notification service it can only find one if storage and session states diverge.
                 r <- getSubscription
                 atomically writeSub
                 pure r

From fdff662911bd48e57e4c0569b52558bf7d908732 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 12:31:24 +0000
Subject: [PATCH 05/12] agent, server: keep original function names, reduce
 diff

---
 src/Simplex/Messaging/Agent.hs        | 50 ++++++++++----------
 src/Simplex/Messaging/Agent/Client.hs | 67 ++++++++++-----------------
 src/Simplex/Messaging/Client/Agent.hs | 16 +++----
 src/Simplex/Messaging/Server.hs       | 17 ++++---
 src/Simplex/Messaging/Session.hs      | 12 ++---
 5 files changed, 72 insertions(+), 90 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 72c0a14eae..c47c0c44ac 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -1169,7 +1169,7 @@ createRcvQueue c nm userId connId srvWithAuth@(ProtoServerWithAuth srv _) enable
   (rq, qUri, tSess, sessId, serviceId_) <-
     newRcvQueue_ c nm userId connId srvWithAuth vr qd (isJust ntfServer_) subMode nonce_ e2eKeys
       `catchAllErrors` \e -> liftIO (print e) >> throwE e
-  incSMPServerStatIO c userId srv connCreated
+  incSMPServerStat c userId srv connCreated
   rq' <- withStore c $ \db -> updateNewConnRcv db connId rq subMode
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId serviceId_
   mapM_ (newQueueNtfSubscription c rq') ntfServer_
@@ -1709,7 +1709,7 @@ createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue ->
 createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
   ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
   (rq, qUri, tSess, sessId, serviceId_) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation (isJust ntfServer_) subMode
-  incSMPServerStatIO c userId (qServer rq) connCreated
+  incSMPServerStat c userId (qServer rq) connCreated
   let qInfo = toVersionT qUri smpClientVersion
   rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq subMode
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId serviceId_
@@ -2426,7 +2426,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
           secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM ()
           secure rq@RcvQueue {server} senderKey = do
             secureQueue c NRMBackground rq senderKey
-            incSMPServerStatIO c userId server connSecured
+            incSMPServerStat c userId server connSecured
             withStore' c $ \db -> setRcvQueueStatus db rq Secured
       where
         withServer a = case server_ of
@@ -2647,7 +2647,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
               let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e
               case e of
                 SMP _ SMP.QUOTA -> do
-                  incSMPServerStatIO c userId server sentQuotaErrs
+                  incSMPServerStat c userId server sentQuotaErrs
                   case msgType of
                     AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                     AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -2659,7 +2659,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                           notify $ MWARN (unId msgId) e
                           retrySndMsg RISlow
                 SMP _ SMP.AUTH -> do
-                  incSMPServerStatIO c userId server sentAuthErrs
+                  incSMPServerStat c userId server sentAuthErrs
                   case msgType of
                     AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                     AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -2698,7 +2698,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                           when (serverHostError e) $ notify $ MWARN (unId msgId) e
                           retrySndMsg RIFast
                   | otherwise -> do
-                      incSMPServerStatIO c userId server sentOtherErrs
+                      incSMPServerStat c userId server sentOtherErrs
                       notifyDel msgId err
               where
                 retrySndMsg riMode = do
@@ -2725,7 +2725,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
                       -- because it can be sent before HELLO is received
                       -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO
                       when (status == Active) $ do
-                        incSMPServerStatIO c userId (qServer rq) connCompleted
+                        incSMPServerStat c userId (qServer rq) connCompleted
                         notify $ CON pqEncryption
                     -- this branch should never be reached as receive queue is created before the confirmation,
                     _ -> logError "HELLO sent without receive queue"
@@ -2800,7 +2800,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
         pure msgIds_
       forM_ (L.nonEmpty msgIds_) $ \msgIds -> do
         notify $ MERRS (L.map unId msgIds) err
-      incSMPServerStatIO' c userId server sentExpiredErrs (length msgIds_ + 1)
+      incSMPServerStat' c userId server sentExpiredErrs (length msgIds_ + 1)
     delMsg :: InternalId -> AM ()
     delMsg = delMsgKeep False
     delMsgKeep :: Bool -> InternalId -> AM ()
@@ -2959,16 +2959,16 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
 
 ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM (Maybe ATransmission)
 ackQueueMessage c rq@RcvQueue {userId, connId, server, rcvSwchStatus} srvMsgId = do
-  incSMPServerStatIO c userId server ackAttempts
+  incSMPServerStat c userId server ackAttempts
   tryAllErrors (sendAck c rq srvMsgId) >>= \case
     Right drained -> sendMsgNtf ackMsgs $ drained && rcvSwchStatus == Just RSReceivedQEND
     Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs False
     Left e -> do
-      unless (temporaryOrHostError e) $ incSMPServerStatIO c userId server ackOtherErrs
+      unless (temporaryOrHostError e) $ incSMPServerStat c userId server ackOtherErrs
       throwE e
   where
     sendMsgNtf stat ended = do
-      incSMPServerStatIO c userId server stat
+      incSMPServerStat c userId server stat
       ifM (liftIO $ hasGetLock c rq)
         (do atomically $ releaseGetLock c rq
             brokerTs_ <- eitherToMaybe <$> tryAllErrors (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId)
@@ -3084,7 +3084,7 @@ deleteConnQueues c nm waitDelivery ntf rqs = do
             | otherwise -> do
                 deleteConnRcvQueue db rq
                 -- attempts and successes are counted in deleteQueues function
-                incSMPServerStatIO c userId server connDeleted
+                incSMPServerStat c userId server connDeleted
                 pure ((rq, Right ()), Just (Just e))
     notify = when ntf . atomically . writeTBQueue (subQ c)
     connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
@@ -3626,7 +3626,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
   connIds <- readTVarIO upConnIds
   unless (null connIds) $ do
     notify' "" $ UP srv connIds
-    incSMPServerStatIO' c userId srv connSubscribed $ length connIds
+    incSMPServerStat' c userId srv connSubscribed $ length connIds
   readTVarIO serviceRQs >>= processRcvServiceAssocs c srv
   where
     withRcvConn :: SMP.RecipientId -> (forall c. RcvQueue -> Connection c -> AM ()) -> AM' ()
@@ -3639,20 +3639,22 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
             Right () -> pure ()
     processSubOk :: RcvQueue -> TVar [ConnId] -> TVar [RcvQueue] -> Maybe SMP.ServiceId -> IO ()
     processSubOk rq@RcvQueue {connId} upConnIds serviceRQs serviceId_ =
-      atomically . whenM (isPendingSub rq) $ do
+      void . whenPendingSub rq $ do
         SS.addActiveSub tSess sessId serviceId_ rq $ currentSubs c
         modifyTVar' upConnIds (connId :)
         when (isJust serviceId_ && serviceId_ == clientServiceId_) $ modifyTVar' serviceRQs (rq :)
     clientServiceId_ = (\THClientService {serviceId} -> serviceId) <$> (clientService =<< thAuth)
     processSubErr :: RcvQueue -> SMPClientError -> AM' ()
     processSubErr rq@RcvQueue {connId} e = do
-      atomically . whenM (isPendingSub rq) $
-        failSubscription c tSess rq e >> incSMPServerStat c userId srv connSubErrs
+      whenM (whenPendingSub rq $ failSubscription c tSess rq e) $
+        incSMPServerStat c userId srv connSubErrs
       processClientNotice rq e
       notifyErr connId e
-    isPendingSub :: RcvQueue -> STM Bool
-    isPendingSub rq = do
-      pending <- (&&) <$> SS.hasPendingSub tSess (queueId rq) (currentSubs c) <*> activeClientSession c tSess sessId
+    whenPendingSub :: MonadIO m => RcvQueue -> STM () -> m Bool
+    whenPendingSub rq action = do
+      pending <- atomically $ do
+        pending <- (&&) <$> SS.hasPendingSub tSess (queueId rq) (currentSubs c) <*> activeClientSession c tSess sessId
+        pending <$ when pending action
       unless pending $ incSMPServerStat c userId srv connSubIgnored
       pure pending
     processClientNotice rq e =
@@ -3679,7 +3681,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
       pendingMsgs =
         withConnLock c connId "processSMP" $ case smpMsg of
           SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> do
-            incSMPServerStatIO c userId srv recvMsgs
+            incSMPServerStat c userId srv recvMsgs
             void . handleNotifyAck $ do
               msg' <- decryptSMPMessage rq msg
               handleNotifyAck $ case msg' of
@@ -3765,7 +3767,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                 | otherwise = pure conn'
                           Right Nothing -> prohibited "msg: bad agent msg" >> ack
                           Left e@(AGENT A_DUPLICATE {}) -> do
-                            incSMPServerStatIO c userId srv recvDuplicates
+                            incSMPServerStat c userId srv recvDuplicates
                             withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
                               Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
                                 | userAck -> ackDel internalId
@@ -3788,7 +3790,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                           _ -> ack
                               _ -> checkDuplicateHash e encryptedMsgHash >> ack
                           Left (AGENT (A_CRYPTO e)) -> do
-                            incSMPServerStatIO c userId srv recvCryptoErrs
+                            incSMPServerStat c userId srv recvCryptoErrs
                             exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash
                             unless exists notifySync
                             ack
@@ -3803,7 +3805,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                                   notify $ RSYNC rss' (Just e) cStats
                                   withStore' c $ \db -> setConnRatchetSync db connId rss'
                           Left e -> do
-                            incSMPServerStatIO c userId srv recvErrs
+                            incSMPServerStat c userId srv recvErrs
                             checkDuplicateHash e encryptedMsgHash >> ack
                         where
                           checkDuplicateHash :: AgentErrorType -> ByteString -> AM ()
@@ -4047,7 +4049,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                     -- this branch is executed by the accepting party in duplexHandshake mode (v2)
                     -- (was executed by initiating party in v1 that is no longer supported)
                     | sndStatus == Active -> do
-                        incSMPServerStatIO c userId srv connCompleted
+                        incSMPServerStat c userId srv connCompleted
                         notify $ CON pqEncryption
                     | otherwise -> enqueueDuplexHello sq
                   _ -> pure ()
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 4adf5a0b5e..588c569265 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -173,8 +173,6 @@ module Simplex.Messaging.Agent.Client
     withNextSrv,
     incSMPServerStat,
     incSMPServerStat',
-    incSMPServerStatIO,
-    incSMPServerStatIO',
     incXFTPServerStat,
     incXFTPServerStat',
     incXFTPServerSizeStat,
@@ -1163,11 +1161,11 @@ sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags
   fst <$> sendOrProxySMPCommand c nm userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
   where
     sendViaProxy smp proxySess = do
-      incSMPServerStatIO c userId destSrv sentViaProxyAttempts
-      incSMPServerStatIO c userId (protocolClientServer' smp) sentProxiedAttempts
+      incSMPServerStat c userId destSrv sentViaProxyAttempts
+      incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts
       proxySMPMessage smp nm proxySess spKey_ senderId msgFlags msg
     sendDirectly smp = do
-      incSMPServerStatIO c userId destSrv sentDirectAttempts
+      incSMPServerStat c userId destSrv sentDirectAttempts
       sendSMPMessage smp nm spKey_ senderId msgFlags msg
 
 sendOrProxySMPCommand ::
@@ -1243,8 +1241,8 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn
               sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
       case r of
         Right r'@(srv_, _) -> do
-          incSMPServerStatIO c userId destSrv sentViaProxy
-          forM_ srv_ $ \proxySrv -> incSMPServerStatIO c userId proxySrv sentProxied
+          incSMPServerStat c userId destSrv sentViaProxy
+          forM_ srv_ $ \proxySrv -> incSMPServerStat c userId proxySrv sentProxied
           pure r'
         Left e
           | serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
@@ -1252,7 +1250,7 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn
     sendDirectly tSess =
       withLogClient_ c nm tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
         tryAllErrors (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case
-          Right r -> r <$ incSMPServerStatIO c userId destSrv sentDirect
+          Right r -> r <$ incSMPServerStat c userId destSrv sentDirect
           Left e -> throwE e
 
 ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
@@ -1558,18 +1556,15 @@ 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: " <>)
 
-processSubResults :: AgentClient -> SMPTransportSession -> SessionId -> Maybe ServiceId -> NonEmpty (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) -> STM ([RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)])
-processSubResults c tSess@(userId, srv, _) sessId serviceId_ rs = do
+processSubResults :: AgentClient -> SMPTransportSession -> SessionId -> Maybe ServiceId -> NonEmpty (RcvQueueSub, Either SMPClientError (Maybe ServiceId)) -> STM ([RcvQueueSub], [(RcvQueueSub, Maybe ClientNotice)], [(AgentSMPServerStats -> TVar Int, Int)])
+processSubResults c tSess sessId serviceId_ rs = do
   pendingSubs <- SS.getPendingQueueSubs tSess $ currentSubs c
   let (failed, subscribed@(qs, sQs), notices, ignored) = foldr (partitionResults pendingSubs) (M.empty, ([], []), [], 0) rs
-  unless (M.null failed) $ do
-    incSMPServerStat' c userId srv connSubErrs $ M.size failed
+  unless (M.null failed) $
     failSubscriptions c tSess failed
-  unless (null qs && null sQs) $ do
-    incSMPServerStat' c userId srv connSubscribed $ length qs + length sQs
+  unless (null qs && null sQs) $
     SS.batchAddActiveSubs tSess sessId serviceId_ subscribed $ currentSubs c
-  unless (ignored == 0) $ incSMPServerStat' c userId srv connSubIgnored ignored
-  pure (sQs, notices)
+  pure (sQs, notices, [(connSubErrs, M.size failed), (connSubscribed, length qs + length sQs), (connSubIgnored, ignored)])
   where
     partitionResults ::
       Map SMP.RecipientId RcvQueueSub ->
@@ -1708,20 +1703,21 @@ subscribeSessQueues_ c withEvents qs = sendClientBatch_ "SUB" False subscribe_ c
     subscribe_ :: SMPClient -> NonEmpty RcvQueueSub -> IO (BatchResponses RcvQueueSub SMPClientError (Maybe ServiceId), Bool)
     subscribe_ smp qs' = do
       let (userId, srv, _) = tSess
-      incSMPServerStatIO' c userId srv connSubAttempts $ length qs'
+      incSMPServerStat' c userId srv connSubAttempts $ length qs'
       rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs'
       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, (serviceQs, notices)) <- atomically $ do
-          r@(_, (_, notices)) <- ifM
+        (active, (serviceQs, notices, stats)) <- atomically $ do
+          r@(_, (_, notices, _)) <- ifM
             (activeClientSession c tSess sessId)
             ((True,) <$> processSubResults c tSess sessId (smpClientServiceId smp) rs)
-            ((False, ([], [])) <$ incSMPServerStat' c userId srv connSubIgnored (length rs))
+            (pure (False, ([], [], [(connSubIgnored, length rs)])))
           unless (null notices) $ takeTMVar $ clientNoticesLock c
           pure r
+        forM_ stats $ \(sel, n) -> unless (n == 0) $ incSMPServerStat' c userId srv sel n
         unless (null serviceQs) $ void $
           processRcvServiceAssocs c srv serviceQs `runReaderT` agentEnv c
         unless (null notices) $ void $
@@ -2113,10 +2109,10 @@ deleteQueues c nm = sendTSessionBatches "DEL" mkSMPTSession deleteQueues_ c nm
   where
     deleteQueues_ smp rqs = do
       let (userId, srv, _) = transportSession' smp
-      incSMPServerStatIO' c userId srv connDelAttempts $ length rqs
+      incSMPServerStat' c userId srv connDelAttempts $ length rqs
       rs <- sendBatch deleteSMPQueues smp nm rqs
       let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs
-      incSMPServerStatIO' c userId srv connDeleted successes
+      incSMPServerStat' c userId srv connDeleted successes
       pure rs
 
 -- This is only used in background
@@ -2570,18 +2566,12 @@ withNextSrv c userId srvsSel triedHosts usedSrvs action = do
   atomically $ writeTVar triedHosts tried'
   action srvAuth
 
-incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()
+incSMPServerStat :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> m ()
 incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1
 
-incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM ()
+incSMPServerStat' :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> m ()
 incSMPServerStat' = incServerStat (\AgentClient {smpServersStats = s} -> s) newAgentSMPServerStats
 
-incSMPServerStatIO :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> m ()
-incSMPServerStatIO c userId srv sel = incSMPServerStatIO' c userId srv sel 1
-
-incSMPServerStatIO' :: MonadIO m => AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> m ()
-incSMPServerStatIO' = incServerStatIO (\AgentClient {smpServersStats = s} -> s) newAgentSMPServerStats
-
 incXFTPServerStat :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> m ()
 incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1
 {-# INLINE incXFTPServerStat #-}
@@ -2595,7 +2585,7 @@ incXFTPServerSizeStat = incXFTPServerStat_
 {-# INLINE incXFTPServerSizeStat #-}
 
 incXFTPServerStat_ :: (MonadIO m, Num n) => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> m ()
-incXFTPServerStat_ = incServerStatIO (\AgentClient {xftpServersStats = s} -> s) newAgentXFTPServerStats
+incXFTPServerStat_ = incServerStat (\AgentClient {xftpServersStats = s} -> s) newAgentXFTPServerStats
 {-# INLINE incXFTPServerStat_ #-}
 
 incNtfServerStat :: MonadIO m => AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> m ()
@@ -2603,20 +2593,11 @@ incNtfServerStat c userId srv sel = incNtfServerStat' c userId srv sel 1
 {-# INLINE incNtfServerStat #-}
 
 incNtfServerStat' :: MonadIO m => AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> Int -> m ()
-incNtfServerStat' = incServerStatIO (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats
+incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats
 {-# INLINE incNtfServerStat' #-}
 
-incServerStat :: Num n => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> STM ()
-incServerStat statsSel mkNewStats c userId srv sel n = do
-  TM.lookup (userId, srv) (statsSel c) >>= \case
-    Just v -> modifyTVar' (sel v) (+ n)
-    Nothing -> do
-      newStats <- mkNewStats
-      modifyTVar' (sel newStats) (+ n)
-      TM.insert (userId, srv) newStats (statsSel c)
-
-incServerStatIO :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
-incServerStatIO statsSel mkNewStats c userId srv sel n =
+incServerStat :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
+incServerStat statsSel mkNewStats c userId srv sel n =
   liftIO $ TM.lookupOrInsertIO (userId, srv) newStats (statsSel c) >>= either (\_ -> pure ()) (atomically . incStat)
   where
     newStats = mkNewStats >>= \s -> s <$ incStat s
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index f0b036d979..b9a321f397 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -420,7 +420,7 @@ subscribeQueuesNtfs = subscribeQueues_
 
 subscribeQueues_ :: ServiceParty p => SMPClientAgent p -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
 subscribeQueues_ ca srv subs = do
-  addSubsIO_ (pendingQueueSubs ca) srv $ M.fromList $ L.toList subs
+  addPendingSubs ca srv $ L.toList subs
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Right smp -> smpSubscribeQueues ca smp srv subs
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
@@ -480,7 +480,7 @@ subscribeServiceNtfs = subscribeService_
 
 subscribeService_ :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPServer -> ServiceSub -> IO ()
 subscribeService_ ca srv serviceSub = do
-  setServiceSubIO_ (pendingServiceSubs ca) srv $ Just serviceSub
+  atomically $ setPendingServiceSub ca srv $ Just serviceSub
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Right smp -> smpSubscribeService ca smp srv serviceSub
     Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
@@ -512,7 +512,7 @@ smpSubscribeService ca smp srv serviceSub@(ServiceSub serviceId n idsHash) = cas
     serviceAvailable THClientService {serviceRole, serviceId = serviceId'} =
       serviceId == serviceId' && partyServiceRole (agentParty ca) == serviceRole
     notifyUnavailable = do
-      setServiceSubIO_ (pendingServiceSubs ca) srv Nothing
+      atomically $ setPendingServiceSub ca srv Nothing
       notify ca $ CAServiceUnavailable srv serviceSub -- this will resubscribe all queues directly
     sessId = sessionId $ thParams smp
 
@@ -534,6 +534,10 @@ addActiveSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, (SessionId, C.APriv
 addActiveSubs = addSubsList_ . activeQueueSubs
 {-# INLINE addActiveSubs #-}
 
+addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> IO ()
+addPendingSubs ca srv ss = TM.lookupIO srv (pendingQueueSubs ca) >>= atomically . maybe (addSubsList_ (pendingQueueSubs ca) srv ss) (TM.union $ M.fromList ss)
+{-# INLINE addPendingSubs #-}
+
 addSubsList_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [(QueueId, s)] -> STM ()
 addSubsList_ subs srv ss = addSubs_ subs srv $ M.fromList ss
   -- where
@@ -545,9 +549,6 @@ addSubs_ subs srv ss =
     Just m -> TM.union ss m
     _ -> TM.insertM srv (newTVar ss) subs
 
-addSubsIO_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> IO ()
-addSubsIO_ subs srv ss = TM.lookupOrInsertIO srv (newTVar ss) subs >>= either (\_ -> pure ()) (atomically . TM.union ss)
-
 setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceSub, SessionId) -> STM ()
 setActiveServiceSub = setServiceSub_ activeServiceSubs
 {-# INLINE setActiveServiceSub #-}
@@ -567,9 +568,6 @@ setServiceSub_ subsSel ca srv sub =
     Just v -> writeTVar v sub
     Nothing -> TM.insertM srv (newTVar sub) (subsSel ca)
 
-setServiceSubIO_ :: TMap SMPServer (TVar (Maybe sub)) -> SMPServer -> Maybe sub -> IO ()
-setServiceSubIO_ subs srv sub = TM.lookupOrInsertIO srv (newTVar sub) subs >>= either (\_ -> pure ()) (atomically . (`writeTVar` sub))
-
 updateActiveServiceSub :: SMPClientAgent p -> SMPServer -> (ServiceSub, SessionId) -> STM ()
 updateActiveServiceSub ca srv sub@(ServiceSub serviceId' n' idsHash', sessId') =
   TM.lookup srv (activeServiceSubs ca) >>= \case
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index db4c3fd3ad..67062b2e6e 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1789,11 +1789,7 @@ client
         -- clients that use GET are not added to server subscribers
         getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
         getMessage q qr = do
-          -- Here we don't account for this client as subscribed in the server
-          -- and don't notify other subscribed clients.
-          -- This is tracked as "subscription" in the client to prevent these
-          -- clients from being able to subscribe.
-          liftIO (TM.lookupOrInsertIO entId newProhibitedSub $ subscriptions clnt) >>= \case
+          liftIO (TM.lookupOrInsertIO entId newSub $ subscriptions clnt) >>= \case
             Left s ->
               getMessage_ s Nothing
             Right s@Sub {subThread} ->
@@ -1807,6 +1803,14 @@ client
                   incStat $ msgGetProhibited stats
                   pure $ err $ CMD PROHIBITED
           where
+            newSub :: STM Sub
+            newSub = do
+              s <- newProhibitedSub
+              -- Here we don't account for this client as subscribed in the server
+              -- and don't notify other subscribed clients.
+              -- This is tracked as "subscription" in the client to prevent these
+              -- clients from being able to subscribe.
+              pure s
             getMessage_ :: Sub -> Maybe (MsgId, SystemSeconds) -> M s (Transmission BrokerMsg)
             getMessage_ s delivered_ = do
               stats <- asks serverStats
@@ -1938,7 +1942,8 @@ client
                 -- If delivery subscription already exists, then there is no need to deliver message.
                 -- It may have been created when the message is sent after service subscription is created.
                 Right _sub -> pure Nothing
-                Left sub -> pure $ Just sub
+                Left sub ->
+                  pure $ Just sub
 
         subscribeServiceNotifications :: ServiceId -> (Int64, IdsHash) -> M s BrokerMsg
         subscribeServiceNotifications serviceId expected =
diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs
index d979d2042f..817f0baa00 100644
--- a/src/Simplex/Messaging/Session.hs
+++ b/src/Simplex/Messaging/Session.hs
@@ -33,18 +33,14 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur
   where
     newSessionVar :: STM (SessionVar a)
     newSessionVar = do
-      v <- createSessionVar sessSeq sessionVarTs
+      sessionVar <- newEmptyTMVar
+      sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
+      let v = SessionVar {sessionVar, sessionVarId, sessionVarTs}
       TM.insert sessKey v vs
       pure v
 
 getSessVarIO :: Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> IO (Either (SessionVar a) (SessionVar a))
-getSessVarIO sessSeq sessKey vs sessionVarTs = TM.lookupOrInsertIO sessKey (createSessionVar sessSeq sessionVarTs) vs
-
-createSessionVar :: TVar Int -> UTCTime -> STM (SessionVar a)
-createSessionVar sessSeq sessionVarTs = do
-  sessionVar <- newEmptyTMVar
-  sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
-  pure SessionVar {sessionVar, sessionVarId, sessionVarTs}
+getSessVarIO sessSeq sessKey vs ts = TM.lookupIO sessKey vs >>= maybe (atomically $ getSessVar sessSeq sessKey vs ts) (pure . Right)
 
 removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
 removeSessVar v sessKey vs =

From d86fcb209f95ff2afbc933ed454a079c638b19b5 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 12:51:55 +0000
Subject: [PATCH 06/12] agent, server: simplify incServerStat and getMessage

---
 src/Simplex/Messaging/Agent/Client.hs | 8 +++-----
 src/Simplex/Messaging/Server.hs       | 3 +--
 2 files changed, 4 insertions(+), 7 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 588c569265..2e92d602af 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -2597,11 +2597,9 @@ incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newA
 {-# INLINE incNtfServerStat' #-}
 
 incServerStat :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
-incServerStat statsSel mkNewStats c userId srv sel n =
-  liftIO $ TM.lookupOrInsertIO (userId, srv) newStats (statsSel c) >>= either (\_ -> pure ()) (atomically . incStat)
-  where
-    newStats = mkNewStats >>= \s -> s <$ incStat s
-    incStat s = modifyTVar' (sel s) (+ n)
+incServerStat statsSel mkNewStats c userId srv sel n = liftIO $ do
+  v <- either id id <$> TM.lookupOrInsertIO (userId, srv) mkNewStats (statsSel c)
+  atomically $ modifyTVar' (sel v) (+ n)
 
 data AgentServersSummary = AgentServersSummary
   { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 67062b2e6e..d1f96b41d6 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1790,8 +1790,7 @@ client
         getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
         getMessage q qr = do
           liftIO (TM.lookupOrInsertIO entId newSub $ subscriptions clnt) >>= \case
-            Left s ->
-              getMessage_ s Nothing
+            Left s -> getMessage_ s Nothing
             Right s@Sub {subThread} ->
               case subThread of
                 ProhibitSub ->

From d737974915d1c62099385fd18cb16b309b396f85 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 17:36:05 +0000
Subject: [PATCH 07/12] agent, ntf server: stat under whenPendingSub,
 lookupOrInsertIO in addPendingSubs

---
 src/Simplex/Messaging/Agent.hs                | 20 +++++++++----------
 src/Simplex/Messaging/Client/Agent.hs         |  4 +++-
 .../Messaging/Notifications/Server/Stats.hs   |  2 +-
 3 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index c47c0c44ac..275bb8a841 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -3639,24 +3639,24 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
             Right () -> pure ()
     processSubOk :: RcvQueue -> TVar [ConnId] -> TVar [RcvQueue] -> Maybe SMP.ServiceId -> IO ()
     processSubOk rq@RcvQueue {connId} upConnIds serviceRQs serviceId_ =
-      void . whenPendingSub rq $ do
-        SS.addActiveSub tSess sessId serviceId_ rq $ currentSubs c
-        modifyTVar' upConnIds (connId :)
-        when (isJust serviceId_ && serviceId_ == clientServiceId_) $ modifyTVar' serviceRQs (rq :)
+      whenPendingSub rq addSub $ pure ()
+      where
+        addSub = do
+          SS.addActiveSub tSess sessId serviceId_ rq $ currentSubs c
+          modifyTVar' upConnIds (connId :)
+          when (isJust serviceId_ && serviceId_ == clientServiceId_) $ modifyTVar' serviceRQs (rq :)
     clientServiceId_ = (\THClientService {serviceId} -> serviceId) <$> (clientService =<< thAuth)
     processSubErr :: RcvQueue -> SMPClientError -> AM' ()
     processSubErr rq@RcvQueue {connId} e = do
-      whenM (whenPendingSub rq $ failSubscription c tSess rq e) $
-        incSMPServerStat c userId srv connSubErrs
+      whenPendingSub rq (failSubscription c tSess rq e) $ incSMPServerStat c userId srv connSubErrs
       processClientNotice rq e
       notifyErr connId e
-    whenPendingSub :: MonadIO m => RcvQueue -> STM () -> m Bool
-    whenPendingSub rq action = do
+    whenPendingSub :: MonadIO m => RcvQueue -> STM () -> m () -> m ()
+    whenPendingSub rq action afterAction = do
       pending <- atomically $ do
         pending <- (&&) <$> SS.hasPendingSub tSess (queueId rq) (currentSubs c) <*> activeClientSession c tSess sessId
         pending <$ when pending action
-      unless pending $ incSMPServerStat c userId srv connSubIgnored
-      pure pending
+      if pending then afterAction else incSMPServerStat c userId srv connSubIgnored
     processClientNotice rq e =
       forM_ (smpErrorClientNotice e) $ \notice_ ->
         E.bracket_
diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs
index b9a321f397..8020e52510 100644
--- a/src/Simplex/Messaging/Client/Agent.hs
+++ b/src/Simplex/Messaging/Client/Agent.hs
@@ -535,7 +535,9 @@ addActiveSubs = addSubsList_ . activeQueueSubs
 {-# INLINE addActiveSubs #-}
 
 addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> IO ()
-addPendingSubs ca srv ss = TM.lookupIO srv (pendingQueueSubs ca) >>= atomically . maybe (addSubsList_ (pendingQueueSubs ca) srv ss) (TM.union $ M.fromList ss)
+addPendingSubs ca srv ss = TM.lookupOrInsertIO srv (newTVar ss') (pendingQueueSubs ca) >>= mapM_ (atomically . TM.union ss')
+  where
+    ss' = M.fromList ss
 {-# INLINE addPendingSubs #-}
 
 addSubsList_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [(QueueId, s)] -> STM ()
diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs
index 7d093138ae..b23fc6301b 100644
--- a/src/Simplex/Messaging/Notifications/Server/Stats.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs
@@ -339,4 +339,4 @@ setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO ()
 setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s
 
 incServerStat :: Text -> TMap Text (TVar Int) -> IO ()
-incServerStat h s = TM.lookupOrInsertIO h (newTVar 1) s >>= either (\_ -> pure ()) (atomically . (`modifyTVar'` (+ 1)))
+incServerStat h s = TM.lookupOrInsertIO h (newTVar 1) s >>= mapM_ (atomically . (`modifyTVar'` (+ 1)))

From d069e1e6a94cdd2824c2dbe422c84f693fc571f4 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 17:57:05 +0000
Subject: [PATCH 08/12] smp server, session: use lookupOrInsertIO directly,
 drop the newSub alias

---
 src/Simplex/Messaging/Server.hs  | 28 ++++++++++------------------
 src/Simplex/Messaging/Session.hs | 12 ++++++++----
 2 files changed, 18 insertions(+), 22 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index d1f96b41d6..7369b1da4c 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1789,7 +1789,11 @@ client
         -- clients that use GET are not added to server subscribers
         getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
         getMessage q qr = do
-          liftIO (TM.lookupOrInsertIO entId newSub $ subscriptions clnt) >>= \case
+          -- Here we don't account for this client as subscribed in the server
+          -- and don't notify other subscribed clients.
+          -- This is tracked as "subscription" in the client to prevent these
+          -- clients from being able to subscribe.
+          liftIO (TM.lookupOrInsertIO entId newProhibitedSub $ subscriptions clnt) >>= \case
             Left s -> getMessage_ s Nothing
             Right s@Sub {subThread} ->
               case subThread of
@@ -1802,14 +1806,6 @@ client
                   incStat $ msgGetProhibited stats
                   pure $ err $ CMD PROHIBITED
           where
-            newSub :: STM Sub
-            newSub = do
-              s <- newProhibitedSub
-              -- Here we don't account for this client as subscribed in the server
-              -- and don't notify other subscribed clients.
-              -- This is tracked as "subscription" in the client to prevent these
-              -- clients from being able to subscribe.
-              pure s
             getMessage_ :: Sub -> Maybe (MsgId, SystemSeconds) -> M s (Transmission BrokerMsg)
             getMessage_ s delivered_ = do
               stats <- asks serverStats
@@ -1930,19 +1926,15 @@ client
                 Nothing -> pure (qCnt + 1, msgCnt, dupCnt, evts)
                 Just (qr, msg) ->
                   getSubscription rId >>= \case
-                    Nothing -> pure (qCnt + 1, msgCnt, dupCnt + 1, evts)
-                    Just sub -> do
+                    -- If delivery subscription already exists, then there is no need to deliver message.
+                    -- It may have been created when the message is sent after service subscription is created.
+                    Right _sub -> pure (qCnt + 1, msgCnt, dupCnt + 1, evts)
+                    Left sub -> do
                       ts <- getSystemSeconds
                       atomically $ setDelivered sub msg ts
                       atomically $ writeTBQueue msgQ [(NoCorrId, rId, MSG (encryptMsg qr msg))]
                       pure (qCnt + 1, msgCnt + 1, dupCnt, evts)
-            getSubscription rId =
-              TM.lookupOrInsertIO rId (newSubscription NoSub) (subscriptions clnt) >>= \case
-                -- If delivery subscription already exists, then there is no need to deliver message.
-                -- It may have been created when the message is sent after service subscription is created.
-                Right _sub -> pure Nothing
-                Left sub ->
-                  pure $ Just sub
+            getSubscription rId = TM.lookupOrInsertIO rId (newSubscription NoSub) (subscriptions clnt)
 
         subscribeServiceNotifications :: ServiceId -> (Int64, IdsHash) -> M s BrokerMsg
         subscribeServiceNotifications serviceId expected =
diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs
index 817f0baa00..6857e0bdef 100644
--- a/src/Simplex/Messaging/Session.hs
+++ b/src/Simplex/Messaging/Session.hs
@@ -33,14 +33,18 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur
   where
     newSessionVar :: STM (SessionVar a)
     newSessionVar = do
-      sessionVar <- newEmptyTMVar
-      sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
-      let v = SessionVar {sessionVar, sessionVarId, sessionVarTs}
+      v <- createSessionVar sessSeq sessionVarTs
       TM.insert sessKey v vs
       pure v
 
 getSessVarIO :: Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> IO (Either (SessionVar a) (SessionVar a))
-getSessVarIO sessSeq sessKey vs ts = TM.lookupIO sessKey vs >>= maybe (atomically $ getSessVar sessSeq sessKey vs ts) (pure . Right)
+getSessVarIO sessSeq sessKey vs ts = TM.lookupOrInsertIO sessKey (createSessionVar sessSeq ts) vs
+
+createSessionVar :: TVar Int -> UTCTime -> STM (SessionVar a)
+createSessionVar sessSeq sessionVarTs = do
+  sessionVar <- newEmptyTMVar
+  sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
+  pure SessionVar {sessionVar, sessionVarId, sessionVarTs}
 
 removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
 removeSessVar v sessKey vs =

From 2331c95ee3c7ea49e74dd0e1dd37a838b7141991 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 18:19:40 +0000
Subject: [PATCH 09/12] agent, server: fromEither, remove unused
 incXFTPServerStat'

---
 src/Simplex/Messaging/Agent.hs        |  2 +-
 src/Simplex/Messaging/Agent/Client.hs | 11 +++--------
 src/Simplex/Messaging/Server.hs       |  2 +-
 src/Simplex/Messaging/Util.hs         |  5 +++++
 4 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 275bb8a841..ec96c607ea 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -2359,7 +2359,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
                     secureQueue c NRMBackground rq' senderKey
                     -- we may add more statistics special to queue rotation later on,
                     -- not accounting secure during rotation for now:
-                    -- atomically $ incSMPServerStat c userId server connSecured
+                    -- incSMPServerStat c userId server connSecured
                     rq1' <- withStore' c $ \db -> setRcvQueueStatus db rq' Secured >> setRcvSwitchStatus db rq1 (Just RSSendingQUSE)
                     void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
                     withStore' c (`deleteCommand` cmdId)
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 2e92d602af..86e2bb8c3e 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -174,7 +174,6 @@ module Simplex.Messaging.Agent.Client
     incSMPServerStat,
     incSMPServerStat',
     incXFTPServerStat,
-    incXFTPServerStat',
     incXFTPServerSizeStat,
     incNtfServerStat,
     incNtfServerStat',
@@ -698,7 +697,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
   where
     proxiedTransportSession :: SMPServerWithAuth -> IO (SMPTransportSession, Maybe SMP.BasicAuth)
     proxiedTransportSession proxySrv = do
-      ProtoServerWithAuth srv auth <- either id id <$> TM.lookupOrInsertIO destSess (pure proxySrv) smpProxiedRelays
+      ProtoServerWithAuth srv auth <- fromEither <$> TM.lookupOrInsertIO destSess (pure proxySrv) smpProxiedRelays
       pure ((userId, srv, qId), auth)
     newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
     newProxyClient tSess auth ts v = do
@@ -1107,7 +1106,7 @@ withLocksMap = withGetLocks . getMapLock
 {-# INLINE withLocksMap #-}
 
 getMapLock :: Ord k => TMap k Lock -> k -> IO Lock
-getMapLock locks key = either id id <$> TM.lookupOrInsertIO key createLock locks
+getMapLock locks key = fromEither <$> TM.lookupOrInsertIO key createLock locks
 
 withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
 withClient_ c nm tSess@(_, srv, _) action = do
@@ -2576,10 +2575,6 @@ incXFTPServerStat :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentX
 incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1
 {-# INLINE incXFTPServerStat #-}
 
-incXFTPServerStat' :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> m ()
-incXFTPServerStat' = incXFTPServerStat_
-{-# INLINE incXFTPServerStat' #-}
-
 incXFTPServerSizeStat :: MonadIO m => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> m ()
 incXFTPServerSizeStat = incXFTPServerStat_
 {-# INLINE incXFTPServerSizeStat #-}
@@ -2598,7 +2593,7 @@ incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newA
 
 incServerStat :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
 incServerStat statsSel mkNewStats c userId srv sel n = liftIO $ do
-  v <- either id id <$> TM.lookupOrInsertIO (userId, srv) mkNewStats (statsSel c)
+  v <- fromEither <$> TM.lookupOrInsertIO (userId, srv) mkNewStats (statsSel c)
   atomically $ modifyTVar' (sel v) (+ n)
 
 data AgentServersSummary = AgentServersSummary
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 7369b1da4c..68b4efb07e 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1775,7 +1775,7 @@ client
                 pure ((corrId, entId, SOK clntServiceId), msg')
 
         getSub :: IO Sub
-        getSub = either id id <$> TM.lookupOrInsertIO entId (newSubscription NoSub) (subscriptions clnt)
+        getSub = fromEither <$> TM.lookupOrInsertIO entId (newSubscription NoSub) (subscriptions clnt)
 
         subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
         subscribeNewQueue rId QueueRec {rcvServiceId} = do
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index de6884b848..fcebd9f66d 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -44,6 +44,7 @@ module Simplex.Messaging.Util
     catchAllOwnErrors,
     catchAllOwnErrors',
     eitherToMaybe,
+    fromEither,
     listToEither,
     firstRow,
     maybeFirstRow,
@@ -339,6 +340,10 @@ eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
 
+fromEither :: Either a a -> a
+fromEither = either id id
+{-# INLINE fromEither #-}
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e

From d1847744be97f20698419b4b5110a3827abe3d70 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 18:26:09 +0000
Subject: [PATCH 10/12] util: hide UnliftIO fromEither where Util fromEither is
 used

---
 src/Simplex/Messaging/Server.hs | 2 +-
 src/Simplex/Messaging/Util.hs   | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 68b4efb07e..6b0b36c24b 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -131,7 +131,7 @@ import System.Mem.Weak (deRefWeak)
 import UnliftIO (timeout)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
-import UnliftIO.Exception
+import UnliftIO.Exception hiding (fromEither)
 import UnliftIO.IO
 import UnliftIO.STM
 
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index fcebd9f66d..b99bb5caf8 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -98,7 +98,7 @@ import Data.Word (Word8)
 import Foreign.ForeignPtr (withForeignPtr)
 import Foreign.Storable (peekByteOff, pokeByteOff)
 import GHC.Conc (labelThread, myThreadId, threadDelay)
-import UnliftIO hiding (atomicModifyIORef')
+import UnliftIO hiding (atomicModifyIORef', fromEither)
 import qualified UnliftIO.Exception as UE
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()

From 9f34df3236eadbae61ec9938dc707861efa164f0 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 18:41:36 +0000
Subject: [PATCH 11/12] agent, server: use either id id, remove fromEither

---
 src/Simplex/Messaging/Agent/Client.hs | 6 +++---
 src/Simplex/Messaging/Server.hs       | 4 ++--
 src/Simplex/Messaging/Util.hs         | 7 +------
 3 files changed, 6 insertions(+), 11 deletions(-)

diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 86e2bb8c3e..5276b93cff 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -697,7 +697,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
   where
     proxiedTransportSession :: SMPServerWithAuth -> IO (SMPTransportSession, Maybe SMP.BasicAuth)
     proxiedTransportSession proxySrv = do
-      ProtoServerWithAuth srv auth <- fromEither <$> TM.lookupOrInsertIO destSess (pure proxySrv) smpProxiedRelays
+      ProtoServerWithAuth srv auth <- either id id <$> TM.lookupOrInsertIO destSess (pure proxySrv) smpProxiedRelays
       pure ((userId, srv, qId), auth)
     newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
     newProxyClient tSess auth ts v = do
@@ -1106,7 +1106,7 @@ withLocksMap = withGetLocks . getMapLock
 {-# INLINE withLocksMap #-}
 
 getMapLock :: Ord k => TMap k Lock -> k -> IO Lock
-getMapLock locks key = fromEither <$> TM.lookupOrInsertIO key createLock locks
+getMapLock locks key = either id id <$> TM.lookupOrInsertIO key createLock locks
 
 withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
 withClient_ c nm tSess@(_, srv, _) action = do
@@ -2593,7 +2593,7 @@ incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newA
 
 incServerStat :: (MonadIO m, Num n) => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> m ()
 incServerStat statsSel mkNewStats c userId srv sel n = liftIO $ do
-  v <- fromEither <$> TM.lookupOrInsertIO (userId, srv) mkNewStats (statsSel c)
+  v <- either id id <$> TM.lookupOrInsertIO (userId, srv) mkNewStats (statsSel c)
   atomically $ modifyTVar' (sel v) (+ n)
 
 data AgentServersSummary = AgentServersSummary
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 6b0b36c24b..7369b1da4c 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -131,7 +131,7 @@ import System.Mem.Weak (deRefWeak)
 import UnliftIO (timeout)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
-import UnliftIO.Exception hiding (fromEither)
+import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
 
@@ -1775,7 +1775,7 @@ client
                 pure ((corrId, entId, SOK clntServiceId), msg')
 
         getSub :: IO Sub
-        getSub = fromEither <$> TM.lookupOrInsertIO entId (newSubscription NoSub) (subscriptions clnt)
+        getSub = either id id <$> TM.lookupOrInsertIO entId (newSubscription NoSub) (subscriptions clnt)
 
         subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
         subscribeNewQueue rId QueueRec {rcvServiceId} = do
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index b99bb5caf8..de6884b848 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/src/Simplex/Messaging/Util.hs
@@ -44,7 +44,6 @@ module Simplex.Messaging.Util
     catchAllOwnErrors,
     catchAllOwnErrors',
     eitherToMaybe,
-    fromEither,
     listToEither,
     firstRow,
     maybeFirstRow,
@@ -98,7 +97,7 @@ import Data.Word (Word8)
 import Foreign.ForeignPtr (withForeignPtr)
 import Foreign.Storable (peekByteOff, pokeByteOff)
 import GHC.Conc (labelThread, myThreadId, threadDelay)
-import UnliftIO hiding (atomicModifyIORef', fromEither)
+import UnliftIO hiding (atomicModifyIORef')
 import qualified UnliftIO.Exception as UE
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -340,10 +339,6 @@ eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
 
-fromEither :: Either a a -> a
-fromEither = either id id
-{-# INLINE fromEither #-}
-
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e

From 5a43c4124c2db7e7dd9b3a6751a6a72ceacd27c7 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 26 Oct 2026 19:58:40 +0000
Subject: [PATCH 12/12] agent, server: keep isPendingSub, reword service
 delivery comment

---
 src/Simplex/Messaging/Agent.hs  | 32 +++++++++++++++++---------------
 src/Simplex/Messaging/Server.hs |  3 +--
 2 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index ec96c607ea..a474c86a45 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -3589,7 +3589,7 @@ data ACKd = ACKd | ACKPending
 -- It cannot be finally, as sometimes it needs to be ACK+DEL,
 -- and sometimes ACK has to be sent from the consumer.
 processSMPTransmissions :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> AM' ()
-processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandleParams {thAuth, sessionId = sessId}, ts) = do
+processSMPTransmissions c@AgentClient {subQ, smpServersStats} (tSess@(userId, srv, _), THandleParams {thAuth, sessionId = sessId}, ts) = do
   upConnIds <- newTVarIO []
   serviceRQs <- newTVarIO ([] :: [RcvQueue])
   forM_ ts $ \(entId, t) -> case t of
@@ -3638,25 +3638,27 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
             Left e -> notify' connId (ERR e)
             Right () -> pure ()
     processSubOk :: RcvQueue -> TVar [ConnId] -> TVar [RcvQueue] -> Maybe SMP.ServiceId -> IO ()
-    processSubOk rq@RcvQueue {connId} upConnIds serviceRQs serviceId_ =
-      whenPendingSub rq addSub $ pure ()
-      where
-        addSub = do
-          SS.addActiveSub tSess sessId serviceId_ rq $ currentSubs c
-          modifyTVar' upConnIds (connId :)
-          when (isJust serviceId_ && serviceId_ == clientServiceId_) $ modifyTVar' serviceRQs (rq :)
+    processSubOk rq@RcvQueue {connId} upConnIds serviceRQs serviceId_ = do
+      srvStats <- getSrvStats
+      atomically . whenM (isPendingSub srvStats rq) $ do
+        SS.addActiveSub tSess sessId serviceId_ rq $ currentSubs c
+        modifyTVar' upConnIds (connId :)
+        when (isJust serviceId_ && serviceId_ == clientServiceId_) $ modifyTVar' serviceRQs (rq :)
     clientServiceId_ = (\THClientService {serviceId} -> serviceId) <$> (clientService =<< thAuth)
     processSubErr :: RcvQueue -> SMPClientError -> AM' ()
     processSubErr rq@RcvQueue {connId} e = do
-      whenPendingSub rq (failSubscription c tSess rq e) $ incSMPServerStat c userId srv connSubErrs
+      srvStats <- liftIO getSrvStats
+      atomically . whenM (isPendingSub srvStats rq) $
+        failSubscription c tSess rq e >> modifyTVar' (connSubErrs srvStats) (+ 1)
       processClientNotice rq e
       notifyErr connId e
-    whenPendingSub :: MonadIO m => RcvQueue -> STM () -> m () -> m ()
-    whenPendingSub rq action afterAction = do
-      pending <- atomically $ do
-        pending <- (&&) <$> SS.hasPendingSub tSess (queueId rq) (currentSubs c) <*> activeClientSession c tSess sessId
-        pending <$ when pending action
-      if pending then afterAction else incSMPServerStat c userId srv connSubIgnored
+    isPendingSub :: AgentSMPServerStats -> RcvQueue -> STM Bool
+    isPendingSub srvStats rq = do
+      pending <- (&&) <$> SS.hasPendingSub tSess (queueId rq) (currentSubs c) <*> activeClientSession c tSess sessId
+      unless pending $ modifyTVar' (connSubIgnored srvStats) (+ 1)
+      pure pending
+    getSrvStats :: IO AgentSMPServerStats
+    getSrvStats = either id id <$> TM.lookupOrInsertIO (userId, srv) newAgentSMPServerStats smpServersStats
     processClientNotice rq e =
       forM_ (smpErrorClientNotice e) $ \notice_ ->
         E.bracket_
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 7369b1da4c..30133885d7 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -1926,8 +1926,7 @@ client
                 Nothing -> pure (qCnt + 1, msgCnt, dupCnt, evts)
                 Just (qr, msg) ->
                   getSubscription rId >>= \case
-                    -- If delivery subscription already exists, then there is no need to deliver message.
-                    -- It may have been created when the message is sent after service subscription is created.
+                    -- delivered via the existing subscription, e.g. made by SEND after SUBS
                     Right _sub -> pure (qCnt + 1, msgCnt, dupCnt + 1, evts)
                     Left sub -> do
                       ts <- getSystemSeconds