smp server: remove locks for deleted queues, additional statistics for objects in memory (#1498)

* smp server: remove locks for deleted queues, additional statistics for objects in memory

* version

* reduce queue cache usage

* less caching, refactor

* comments

* revert version

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

@@ -35,7 +35,6 @@ import Control.Monad.Trans.Except
 import Data.ByteString.Builder (Builder)
 import qualified Data.ByteString.Builder as BB
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Bitraversable (bimapM)
 import Data.Either (fromRight)
@@ -155,37 +154,48 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
       -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
 
-  getQueue_ :: DirectParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: DirectParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
   getQueue_ st mkQ party qId = case party of
     SRecipient -> getRcvQueue qId
-    SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue
-    SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue
+    SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
+    -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
+    SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
     where
       PostgresQueueStore {queues, senders, notifiers} = st
-      getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right)
-      loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure ()
-      loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders
-      loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare
-      loadQueue condition insertRef =
-        E.uninterruptibleMask_ $ runExceptT $ do
-          (rId, qRec) <-
-            withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
-              DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
-          liftIO $ do
-            sq <- mkQ rId qRec -- loaded queue
-            -- This lock prevents the scenario when the queue is added to cache,
-            -- while another thread is proccessing the same queue in withAllMsgQueues
-            -- without adding it to cache, possibly trying to open the same files twice.
-            -- Alse see comment in idleDeleteExpiredMsgs.
-            withQueueLock sq "getQueue_" $ atomically $
-              -- checking the cache again for concurrent reads,
-              -- use previously loaded queue if exists.
-              TM.lookup rId queues >>= \case
-                Just sq' -> pure sq'
-                Nothing -> do
-                  insertRef rId
-                  TM.insert rId sq queues
-                  pure sq
+      getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
+      loadRcvQueue = do
+        (rId, qRec) <- loadQueue " WHERE recipient_id = ?"
+        liftIO $ cacheQueue rId qRec $ \_ -> pure () -- recipient map already checked, not caching sender ref
+      loadSndQueue = do
+        (rId, qRec) <- loadQueue " WHERE sender_id = ?"
+        liftIO $
+          TM.lookupIO rId queues -- checking recipient map first
+            >>= maybe (cacheQueue rId qRec cacheSender) (atomically (cacheSender rId) $>)
+      loadNtfQueue = do
+        (rId, qRec) <- loadQueue " WHERE notifier_id = ?"
+        liftIO $
+          TM.lookupIO rId queues -- checking recipient map first, not creating lock in map, not caching queue
+            >>= maybe (mkQ False rId qRec) pure
+      mask = E.uninterruptibleMask_ . runExceptT
+      cacheSender rId = TM.insert qId rId senders
+      loadQueue condition =
+        withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
+          DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
+      cacheQueue rId qRec insertRef = do
+        sq <- mkQ True rId qRec -- loaded queue
+        -- This lock prevents the scenario when the queue is added to cache,
+        -- while another thread is proccessing the same queue in withAllMsgQueues
+        -- without adding it to cache, possibly trying to open the same files twice.
+        -- Alse see comment in idleDeleteExpiredMsgs.
+        withQueueLock sq "getQueue_" $ atomically $
+          -- checking the cache again for concurrent reads,
+          -- use previously loaded queue if exists.
+          TM.lookup rId queues >>= \case
+            Just sq' -> pure sq'
+            Nothing -> do
+              insertRef rId
+              TM.insert rId sq queues
+              pure sq
 
   secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
   secureQueue st sq sKey =
@@ -289,7 +299,9 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
       DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
     atomically $ writeTVar qr Nothing
     atomically $ TM.delete (senderId q) $ senders st
-    forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st
+    forM_ (notifier q) $ \NtfCreds {notifierId} -> do
+      atomically $ TM.delete notifierId $ notifiers st
+      atomically $ TM.delete notifierId $ notifierLocks st
     mq_ <- atomically $ swapTVar (msgQueue sq) Nothing
     withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
     pure (q, mq_)

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

@@ -92,7 +92,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
       hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier]
       hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
 
-  getQueue_ :: DirectParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: DirectParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
   getQueue_ st _ party qId =
     maybe (Left AUTH) Right <$> case party of
       SRecipient -> TM.lookupIO qId queues

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

@@ -29,7 +29,7 @@ class StoreQueueClass q => QueueStoreClass q s where
   loadedQueues :: s -> TMap RecipientId q
   compactQueues :: s -> IO Int64
   addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
-  getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ :: DirectParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
   secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
   addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
   deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId))