From 414b019ad49f0023ce29fc9266b02ebba2f430a8 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 24 Aug 2023 23:19:48 +0100
Subject: [PATCH] agent: function to debug agent subscriptions (#834)

* agent: function to debug agent subscriptions

* add Show instances
---
 src/Simplex/Messaging/Agent.hs            |  2 ++
 src/Simplex/Messaging/Agent/Client.hs     | 29 ++++++++++++++++++++++-
 src/Simplex/Messaging/Agent/TRcvQueues.hs |  5 ++--
 3 files changed, 33 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index ae0f4e212..d0b089600 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -35,6 +35,7 @@ module Simplex.Messaging.Agent
     AgentClient (..),
     AgentMonad,
     AgentErrorMonad,
+    SubscriptionsInfo (..),
     getSMPAgentClient,
     disconnectAgentClient,
     resumeAgentClient,
@@ -96,6 +97,7 @@ module Simplex.Messaging.Agent
     debugAgentLocks,
     getAgentStats,
     resetAgentStats,
+    getAgentSubscriptions,
     logConnection,
   )
 where
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 09de8166d..78828f9da 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -71,6 +71,8 @@ module Simplex.Messaging.Agent.Client
     removeSubscription,
     hasActiveSubscription,
     agentClientStore,
+    getAgentSubscriptions,
+    SubscriptionsInfo (..),
     AgentOperation (..),
     AgentOpState (..),
     AgentState (..),
@@ -127,6 +129,7 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
+import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Word (Word16)
@@ -147,7 +150,7 @@ import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import Simplex.Messaging.Agent.TAsyncs
-import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues)
+import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
@@ -1340,3 +1343,27 @@ withNextSrv c userId usedSrvs initUsed action = do
         used' = if null unused then initUsed else srv : used
     writeTVar usedSrvs $! used'
   action srvAuth
+
+data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text}
+  deriving (Show, Generic)
+
+instance ToJSON SubInfo where toEncoding = J.genericToEncoding J.defaultOptions
+
+data SubscriptionsInfo = SubscriptionsInfo
+  { activeSubscriptions :: [SubInfo],
+    pendingSubscriptions :: [SubInfo]
+  }
+  deriving (Show, Generic)
+
+instance ToJSON SubscriptionsInfo where toEncoding = J.genericToEncoding J.defaultOptions
+
+getAgentSubscriptions :: MonadIO m => AgentClient -> m SubscriptionsInfo
+getAgentSubscriptions c = do
+  activeSubscriptions <- getSubs activeSubs
+  pendingSubscriptions <- getSubs pendingSubs
+  pure $ SubscriptionsInfo {activeSubscriptions, pendingSubscriptions}
+  where
+    getSubs sel = map subInfo . M.keys <$> readTVarIO (getRcvQueues $ sel c)
+    subInfo (uId, srv, rId) = SubInfo {userId = uId, server = enc srv, rcvId = enc rId}
+    enc :: StrEncoding a => a -> Text
+    enc = decodeLatin1 . strEncode
diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs
index bc116c2e3..6af2a4ed4 100644
--- a/src/Simplex/Messaging/Agent/TRcvQueues.hs
+++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs
@@ -1,5 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
 module Simplex.Messaging.Agent.TRcvQueues
-  ( TRcvQueues,
+  ( TRcvQueues (getRcvQueues),
     empty,
     clear,
     deleteConn,
@@ -22,7 +23,7 @@ import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 
-newtype TRcvQueues = TRcvQueues (TMap (UserId, SMPServer, RecipientId) RcvQueue)
+newtype TRcvQueues = TRcvQueues {getRcvQueues :: TMap (UserId, SMPServer, RecipientId) RcvQueue}
 
 empty :: STM TRcvQueues
 empty = TRcvQueues <$> TM.empty