diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 410d9aa648..efb20c8ffb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -91,14 +91,18 @@ import qualified Simplex.FileTransfer.Description as FD import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, getAgentWorkersDetails, getAgentWorkersSummary, temporaryAgentError, withLockMap) +import qualified Simplex.Messaging.Agent.Client as AC import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig) import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) +import qualified Simplex.Messaging.Agent.Store as AS import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection) +import qualified Simplex.Messaging.Agent.Store.SQLite as ADB import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import Simplex.Messaging.Client (defaultNetworkConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) @@ -2149,14 +2153,55 @@ processChatCommand' vr = \case chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) agentMigrations <- withAgent getAgentMigrations pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} - DebugAcks -> lift $ do + DebugAcks -> do acs <- mapM readTVarIO =<< readTVarIO =<< asks agentConnStatuses - liftIO $ print acs - -- acs' <- forM (M.toList acs) $ \(acId, agentConnStatus) -> do - -- debugAckKey <- error "TODO: resolve connId into DebugAckKey" - -- let da = error "TODO: DebugAck {}" - -- pure (debugAckKey, da) - pure $ CRDebugAcks mempty -- (M.fromList acs') + fmap (CRDebugAcks . M.fromList) . forM (M.toList acs) $ \(acId@(AgentConnId acId'), agentConnStatus) -> do + user_ <- withStore' (`getUserByAConnId` acId) + + rq' <- withAgent $ \ac -> liftIO . (`runReaderT` agentEnv ac) . runExceptT $ do + AS.RcvQueue {server, rcvId, status, smpClientVersion} <- AC.withStore ac (`ADB.getPrimaryRcvQueue` acId') + pure (server, (rcvId, status, smpClientVersion)) + + (inActive, inPending) <- case (user_, rq') of + (Just User {userId}, Right (srv, (rcvId', _, _))) -> do + let tSess = (userId, srv, Just acId') + withAgent $ \AgentClient {activeSubs, pendingSubs} -> do + active <- atomically (RQ.getSessQueues tSess activeSubs) + pending <- atomically (RQ.getSessQueues tSess pendingSubs) + pure + ( any (\AS.RcvQueue {rcvId} -> rcvId == rcvId') active, + any (\AS.RcvQueue {rcvId} -> rcvId == rcvId') pending + ) + _ -> pure (False, False) + + entity_ <- forM user_ $ \user -> withStore (\db -> getConnectionEntity db vr user acId) + conn_ <- forM entity_ $ \case + RcvDirectMsgConnection {entityConnection} -> pure entityConnection + RcvGroupMsgConnection {entityConnection} -> pure entityConnection + SndFileConnection {entityConnection} -> pure entityConnection + RcvFileConnection {entityConnection} -> pure entityConnection + UserContactConnection {entityConnection} -> pure entityConnection + + let AgentConnStatus {lastCmd, lastCmdTag, lastMsg, ackSent, okRcvd} = agentConnStatus + pure + ( decodeLatin1 $ strEncode acId, + DebugAck + { lastCmd = Just (decodeLatin1 $ strEncode lastCmdTag, lastCmd), + lastMsg, + lastAck = ackSent, + lastOK = okRcvd, + inActive, + inPending, + server = either (const Nothing) (\(SMP.ProtocolServer {host, port}, _) -> Just (decodeLatin1 . strEncode $ L.head host, port)) rq', + hasSMPClient = True, -- TODO + hasSubWorker = False, -- TODO + hasDeliveryWorker = False, -- TODO + connStatus_ = (\Connection {connStatus} -> connStatus) <$> conn_, + -- agent connstatus? + connAuthErrors = (\c@Connection {authErrCounter} -> (authErrCounter, connDisabled c)) <$> conn_, + createdAt = (\Connection {createdAt} -> createdAt) <$> conn_ + } + ) DebugLocks -> lift $ do chatLockName <- atomically . tryReadTMVar =<< asks chatLock chatEntityLocks <- getLocks =<< asks entityLocks diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8dfa20a695..35270a836c 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -776,21 +776,23 @@ data DebugAck = DebugAck lastCmd :: Maybe (Text, UTCTime), -- was there ANY command result delivered here? lastMsg :: Maybe UTCTime, -- if yes, the ACK should happen lastAck :: Maybe UTCTime, -- if sent, the OK should happen or a new MSG - lasOK :: Maybe UTCTime, -- server got ACK, waiting for new messages + lastOK :: Maybe UTCTime, -- server got ACK, waiting for new messages -- from getAgentSubscriptions, via rId inActive :: Bool, -- should the delivery work right now? inPending :: Bool, -- is there a temporary error? -- from some receive queue - host :: TransportHost, -- what's the server for this connection? + server :: Maybe (Text, String), -- what's the server for this connection? -- XXX: reveals private servers and association hasSMPClient :: Bool, -- is there an active client for it? hasSubWorker :: Bool, -- a session was recently restarted and tries to resubscribe hasDeliveryWorker :: Bool, -- connection's delivery worker is active, double-take on session status -- from Connection - connStatus_ :: ConnStatus, -- does the protocol permits delivery - connAuthErrors :: (Int, Bool), -- number of AUTH errors before connection gets disabled - createdAt :: UTCTime + connStatus_ :: Maybe ConnStatus, -- does the protocol permits delivery + connAuthErrors :: Maybe (Int, Bool), -- number of AUTH errors before connection gets disabled + createdAt :: Maybe UTCTime } deriving Show +-- XXX: attach NetworkConfig ? +-- TransportSessionMode ? -- some of these can only be used as command responses allowRemoteEvent :: ChatResponse -> Bool