Merge branch 'master' into master-ghc9

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

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

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