core: enhance server test result handling with additional server info (#7357)

* core: enhance server test result handling with additional server info

* simpler

* nix

---------

Co-authored-by: Ed Asriyan <service.github@asriyan.me>
This commit is contained in:
Evgeny
2026-08-09 16:09:29 +01:00
committed by GitHub
co-authored by Ed Asriyan
parent e04e080a3d
commit 24816b66fe
6 changed files with 13 additions and 7 deletions
+1 -1
View File
@@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: ee4dd0d8ded0f66f70a8890ce09d69e3610aa276
tag: e3d53428a0c5776f9682264a56436ce97bc3eff8
source-repository-package
type: git
+1 -1
View File
@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."ee4dd0d8ded0f66f70a8890ce09d69e3610aa276" = "0zahz4011adavfz680wkcqvcrl2f9zjdx6dly6yqkcin4bpr6v3k";
"https://github.com/simplex-chat/simplexmq.git"."e3d53428a0c5776f9682264a56436ce97bc3eff8" = "1i3x4q6sc8w6hndrmmrsgc15di0bz6w29r4y5cr985rvs9c2mx7d";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
+2 -1
View File
@@ -70,6 +70,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Chat.Util (liftIOEither)
import Simplex.FileTransfer.Description (FileDescriptionURI)
import Simplex.Messaging.Server.Information (ServerPublicInfo)
import Simplex.Messaging.Agent (AgentClient, DatabaseDiff, SubscriptionsInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg, Worker)
@@ -781,7 +782,7 @@ data ChatResponse
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure, serverInfo :: Maybe (Either String ServerPublicInfo)}
| CRChatRelayTestResult {user :: User, relayProfile :: Maybe RelayProfile, relayTestFailure :: Maybe RelayTestFailure}
| CRServerOperatorConditions {conditions :: ServerOperatorConditions}
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
+3 -2
View File
@@ -1675,8 +1675,9 @@ processChatCommand cxt nm = \case
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
Just Refl -> pure $ AUS SDBNew $ newUserServer srv
Nothing -> throwCmdError $ "incorrect server protocol: " <> B.unpack (strEncode srv)
APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user ->
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a nm (aUserId user) server)
APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> do
r <- lift $ withAgent' $ \a -> testProtocolServer a nm (aUserId user) server
pure $ uncurry (CRServerTestResult user srv) $ either ((,Nothing) . Just) (Nothing,) r
TestProtoServer srv -> withUser $ \User {userId} ->
processChatCommand cxt nm $ APITestProtoServer userId srv
APITestChatRelay userId address -> withUserId userId $ \user -> do
+1 -1
View File
@@ -3887,7 +3887,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
Just author -> action author
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
withVerifiedMsg :: MsgEncodingI e => GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
withVerifiedMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
case verified of
Just verifiedMsg -> Just <$> action verifiedMsg
+5 -1
View File
@@ -126,7 +126,11 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
CRChatContentTypes cts -> [plain $ "Chat content types: " <> T.intercalate ", " (map (safeDecodeUtf8 . strEncode) cts)]
CRChatTags u tags -> ttyUser u [viewJSON tags]
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
CRServerTestResult u srv testFailure info -> ttyUser u $ viewServerTestResult srv testFailure <> maybe [] viewServerInfo info
where
viewServerInfo = \case
Left e -> [plain $ "Server Info Error: " <> T.pack e]
Right i -> [plain $ "Server Info: " <> tshow i]
CRChatRelayTestResult u relayProfile_ relayTestFailure_ -> ttyUser u $ viewRelayTestResult relayProfile_ relayTestFailure_
CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca
CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)