add connection debug

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,

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)
 

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),