diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e071efbed..716123b02 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -38,6 +38,7 @@ module Simplex.Messaging.Agent AgentClient (..), AgentMonad, AgentErrorMonad, + SubscriptionsInfo (..), getSMPAgentClient, disconnectAgentClient, resumeAgentClient, @@ -99,6 +100,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 e81b9e16f..ac0a1079d 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -72,6 +72,9 @@ module Simplex.Messaging.Agent.Client removeSubscription, hasActiveSubscription, agentClientStore, + getAgentSubscriptions, + SubscriptionsInfo (..), + SubInfo (..), AgentOperation (..), AgentOpState (..), AgentState (..), @@ -129,6 +132,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) @@ -149,7 +153,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 () @@ -1342,3 +1346,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