diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index fdf97cb9f6..7914b5d58a 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -2153,10 +2153,53 @@ processChatCommand' vr = \case chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) agentMigrations <- withAgent getAgentMigrations pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} - DebugDelivery -> do + DebugDelivery showAll -> do ads <- mapM readTVarIO =<< readTVarIO =<< asks agentDeliveryStatuses - let collect (acId, ds) = if agentDeliveryOk ds then Nothing else Just (decodeLatin1 $ strEncode acId, ds) + let collect (acId, ds) = if not showAll && agentDeliveryOk ds then Nothing else Just (decodeLatin1 $ strEncode acId, ds) pure $ CRDebugDelivery . M.fromList . mapMaybe collect $ M.toList ads + DebugConnection acId@(AgentConnId acId') -> do + user@User {userId} <- withStore' (`getUserByAConnId` acId) >>= maybe (throwChatError undefined) pure + AS.RcvQueue {server, rcvId = rcvId', status = rqStatus} <- withAgent $ \ac -> + -- dive into agent internals + liftIOEither . (`runReaderT` agentEnv ac) . runExceptT $ AC.withStore ac $ \adb -> + ADB.getPrimaryRcvQueue adb acId' + let tSess = (userId, server, Just acId') + SMP.ProtocolServer {host, port} = server + AgentClient {activeSubs, pendingSubs, smpClients, smpSubWorkers} <- withAgent pure + inActive <- any (\AS.RcvQueue {rcvId} -> rcvId == rcvId') <$> atomically (RQ.getSessQueues tSess activeSubs) + inPending <- any (\AS.RcvQueue {rcvId} -> rcvId == rcvId') <$> atomically (RQ.getSessQueues tSess pendingSubs) + smpClient <- atomically (TM.lookup (tSess $> Nothing) smpClients) >>= mapM (\AC.SessionVar {sessionVar} -> atomically (tryReadTMVar sessionVar)) + smpClientIsolated <- atomically (TM.lookup tSess smpClients) >>= mapM (\AC.SessionVar {sessionVar} -> atomically (tryReadTMVar sessionVar)) + let smpClientStatus = case smpClient <|> smpClientIsolated of + Nothing -> "missing" + Just Nothing -> "connecting" + Just (Just (Left err)) -> tshow err + Just (Just (Right _client)) -> "connected" + subWorker <- atomically (TM.lookup (tSess $> Nothing) smpSubWorkers) >>= mapM (\AC.SessionVar {sessionVar} -> atomically (tryReadTMVar sessionVar)) + subWorkerIsolated <- atomically (TM.lookup tSess smpSubWorkers) >>= mapM (\AC.SessionVar {sessionVar} -> atomically (tryReadTMVar sessionVar)) + let subWorkerStatus = case subWorker <|> subWorkerIsolated of + Nothing -> "idle" + Just Nothing -> "waiting" + Just (Just _async) -> "working" + conn@Connection {connStatus, createdAt} <- withStore (\db -> getConnectionEntity db vr user acId) >>= \case + RcvDirectMsgConnection {entityConnection} -> pure entityConnection + RcvGroupMsgConnection {entityConnection} -> pure entityConnection + SndFileConnection {entityConnection} -> pure entityConnection + RcvFileConnection {entityConnection} -> pure entityConnection + UserContactConnection {entityConnection} -> pure entityConnection + deliveryStatus <- mapM readTVarIO . M.lookup acId =<< readTVarIO =<< asks agentDeliveryStatuses + pure $ CRDebugConnection DebugConnectionStatus + { deliveryStatus, + inActive, + inPending, + server = (decodeLatin1 $ strEncode host, port), + smpClientStatus, + subWorkerStatus, + queueStatus = tshow rqStatus, + connStatus_ = connStatus, + connAuthErrors = (authErrCounter conn, connDisabled conn), + createdAt = createdAt + } DebugLocks -> lift $ do chatLockName <- atomically . tryReadTMVar =<< asks chatLock chatEntityLocks <- getLocks =<< asks entityLocks @@ -7310,7 +7353,8 @@ chatCommandP = "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, - "/debug delivery" $> DebugDelivery, + "/debug delivery" *> (DebugDelivery <$> (" all" $> True <|> pure False)), + "/debug conn " *> (DebugConnection . AgentConnId <$> base64P), -- TODO get by decimal connId too "/debug locks" $> DebugLocks, "/debug event " *> (DebugEvent <$> jsonP), "/get stats" $> GetAgentStats, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 381927f64e..48e85d5048 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -504,8 +504,8 @@ data ChatCommand | APIStandaloneFileInfo FileDescriptionURI | QuitChat | ShowVersion - | DebugDelivery - -- | DebugConnection Int64 + | DebugDelivery Bool + | DebugConnection AgentConnId | DebugLocks | DebugEvent ChatResponse | GetAgentStats @@ -754,6 +754,7 @@ data ChatResponse | CRSQLResult {rows :: [Text]} | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]} | CRDebugDelivery {debugDelivery :: Map Text AgentDeliveryStatus} + | CRDebugConnection {debugConnection :: DebugConnectionStatus} | CRDebugLocks {chatLockName :: Maybe String, chatEntityLocks :: Map String String, agentLocks :: AgentLocks} | CRAgentStats {agentStats :: [[String]]} | CRAgentWorkersDetails {agentWorkersDetails :: AgentWorkersDetails} @@ -774,30 +775,22 @@ data ChatResponse | CRCustomChatResponse {user_ :: Maybe User, response :: Text} deriving (Show) --- entity marker + id: @34 --- using names would make a dump unshareable -type DebugAckKey = Text - -data DebugAck = DebugAck - { -- from agentConnStatuses - 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 - lastOK :: Maybe UTCTime, -- server got ACK, waiting for new messages - -- from getAgentSubscriptions, via rId +data DebugConnectionStatus = DebugConnectionStatus + { deliveryStatus :: Maybe AgentDeliveryStatus, + -- from agent's TRecvQ via rcvId inActive :: Bool, -- should the delivery work right now? inPending :: Bool, -- is there a temporary error? - -- from some receive queue - 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 receive queue + queueStatus :: Text, + server :: (Text, String), -- what's the server for this connection? -- XXX: reveals private servers and association + smpClientStatus :: Text, -- is there an active client for it? + subWorkerStatus :: Text, -- a session was recently restarted and tries to resubscribe -- from Connection - connStatus_ :: Maybe ConnStatus, -- does the protocol permits delivery - connAuthErrors :: Maybe (Int, Bool), -- number of AUTH errors before connection gets disabled - createdAt :: Maybe UTCTime + connStatus_ :: ConnStatus, -- does the protocol permits delivery + connAuthErrors :: (Int, Bool), -- number of AUTH errors before connection gets disabled + createdAt :: UTCTime } - deriving Show + deriving (Show) -- XXX: attach NetworkConfig ? -- TransportSessionMode ? @@ -1504,9 +1497,7 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHSR") ''RemoteHostStopReason) $(JQ.deriveJSON defaultJSON ''AgentDeliveryStatus) --- $(JQ.deriveJSON defaultJSON ''DebugDelivery) - --- $(JQ.deriveJSON defaultJSON ''DebugConnection) +$(JQ.deriveJSON defaultJSON ''DebugConnectionStatus) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index df288149e2..26c36f94f1 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -352,6 +352,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe <> (" :: " <> plain (T.unwords $ T.lines query)) in ("Chat queries" : map viewQuery chatQueries) <> [""] <> ("Agent queries" : map viewQuery agentQueries) CRDebugDelivery ads -> [plain $ LB.unpack (J.encode ads)] + CRDebugConnection cs -> [plain $ LB.unpack (J.encode cs)] CRDebugLocks {chatLockName, chatEntityLocks, agentLocks} -> [ maybe "no chat lock" (("chat lock: " <>) . plain) chatLockName, plain $ "chat entity locks: " <> LB.unpack (J.encode chatEntityLocks),