core, ui: chat relay test (#6736)

2026-05-11 08:27:11 +00:00 · 2026-04-02 15:36:36 +00:00
parent 42fe94752c
commit a14a66db14
40 changed files with 1670 additions and 148 deletions
@@ -173,6 +173,7 @@ newChatController
    deliveryTaskWorkers <- TM.emptyIO
    deliveryJobWorkers <- TM.emptyIO
    relayRequestWorkers <- TM.emptyIO
+    chatRelayTests <- TM.emptyIO
    expireCIThreads <- TM.emptyIO
    expireCIFlags <- TM.emptyIO
    cleanupManagerAsync <- newTVarIO Nothing
@@ -216,6 +217,7 @@ newChatController
          deliveryTaskWorkers,
          deliveryJobWorkers,
          relayRequestWorkers,
+          chatRelayTests,
          expireCIThreads,
          expireCIFlags,
          cleanupManagerAsync,
@@ -250,6 +250,7 @@ data ChatController = ChatController
    deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker,
    deliveryJobWorkers :: TMap DeliveryWorkerKey Worker,
    relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework
+    chatRelayTests :: TMap ConnId RelayTest,
    expireCIThreads :: TMap UserId (Maybe (Async ())),
    expireCIFlags :: TMap UserId Bool,
    cleanupManagerAsync :: TVar (Maybe (Async ())),
@@ -398,9 +399,8 @@ data ChatCommand
  | TestProtoServer AProtoServerWithAuth
  | GetUserChatRelays
  | SetUserChatRelays [CLINewRelay]
-  -- TODO [relays] commands to test chat relay
-  -- | APITestChatRelay UserId ConnLinkContact
-  -- | TestChatRelay ConnLinkContact
+  | APITestChatRelay UserId ShortLinkContact
+  | TestChatRelay ShortLinkContact
  | APIGetServerOperators
  | APISetServerOperators (NonEmpty ServerOperator)
  | SetServerOperators (NonEmpty ServerOperatorRoles)
@@ -649,6 +649,26 @@ data RelayConnectionResult = RelayConnectionResult
  }
  deriving (Show)

+data RelayTestStep
+  = RTSGetLink
+  | RTSDecodeLink
+  | RTSConnect
+  | RTSWaitResponse
+  | RTSVerify
+  deriving (Show)
+
+data RelayTestFailure = RelayTestFailure
+  { rtfStep :: RelayTestStep,
+    rtfError :: ChatError
+  }
+  deriving (Show)
+
+data RelayTest = RelayTest
+  { challenge :: ByteString,
+    rootKey :: C.PublicKeyEd25519,
+    result :: TMVar (Maybe RelayTestFailure)
+  }
+
 data ChatResponse
  = CRActiveUser {user :: User}
  | CRUsersList {users :: [UserInfo]}
@@ -665,6 +685,7 @@ data ChatResponse
  | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
  | CRChatItemId User (Maybe ChatItemId)
  | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
+  | CRChatRelayTestResult {user :: User, relayProfile :: Maybe RelayProfile, relayTestFailure :: Maybe RelayTestFailure}
  | CRServerOperatorConditions {conditions :: ServerOperatorConditions}
  | CRUserServers {user :: User, userServers :: [UserOperatorServers]}
  | CRUserServersValidation {user :: User, serverErrors :: [UserServersError], serverWarnings :: [UserServersWarning]}
@@ -1351,6 +1372,7 @@ data ChatErrorType
  | CEConnectionIncognitoChangeProhibited
  | CEConnectionUserChangeProhibited
  | CEPeerChatVRangeIncompatible
+  | CERelayTestError {message :: String}
  | CEInternalError {message :: String}
  | CEException {message :: String}
  deriving (Show, Exception)
@@ -1679,6 +1701,10 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "TE") ''TerminalEvent)

 $(JQ.deriveJSON defaultJSON ''RelayConnectionResult)

+$(JQ.deriveJSON (enumJSON $ dropPrefix "RTS") ''RelayTestStep)
+
+$(JQ.deriveJSON defaultJSON ''RelayTestFailure)
+
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse)

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CEvt") ''ChatEvent)
@@ -115,6 +115,7 @@ import System.Exit (ExitCode, exitSuccess)
 import System.FilePath (takeExtension, takeFileName, (</>))
 import System.IO (Handle, IOMode (..))
 import System.Random (randomRIO)
+import System.Timeout (timeout)
 import UnliftIO.Async
 import UnliftIO.Concurrent (forkIO, threadDelay)
 import UnliftIO.Directory
@@ -1489,6 +1490,46 @@ processChatCommand vr nm = \case
    lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a nm (aUserId user) server)
  TestProtoServer srv -> withUser $ \User {userId} ->
    processChatCommand vr nm $ APITestProtoServer userId srv
+  APITestChatRelay userId address -> withUserId userId $ \user -> do
+    let failAt step e = pure $ CRChatRelayTestResult user Nothing (Just $ RelayTestFailure step e)
+    r <- tryAllErrors $ getShortLinkConnReq nm user address
+    case r of
+      Left e -> failAt RTSGetLink e
+      Right (FixedLinkData {rootKey, linkConnReq = cReq}, cData) -> do
+        relayProfile_ <- liftIO $ decodeLinkUserData cData
+        case relayProfile_ of
+          Nothing -> failAt RTSDecodeLink (ChatError $ CERelayTestError "no relay address link data")
+          Just RelayAddressLinkData {relayProfile} -> do
+            let failWithProfile step e =
+                  pure $ CRChatRelayTestResult user (Just relayProfile) (Just $ RelayTestFailure step e)
+            lift (withAgent' $ \a -> connRequestPQSupport a PQSupportOff cReq) >>= \case
+              Nothing -> failWithProfile RTSConnect (ChatError $ CERelayTestError "invalid connection request")
+              Just (agentV, _) -> do
+                let chatV = agentToChatVersion agentV
+                subMode <- chatReadVar subscriptionMode
+                connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq PQSupportOff
+                conn@Connection {connId = testCId} <- withFastStore $ \db ->
+                  createRelayTestConnection db vr user connId ConnPrepared chatV subMode
+                challenge <- drgRandomBytes 32
+                testVar <- newEmptyTMVarIO
+                let acId = aConnId conn
+                    relayTest = RelayTest {challenge, rootKey, result = testVar}
+                chatRelayTests_ <- asks chatRelayTests
+                atomically $ TM.insert acId relayTest chatRelayTests_
+                testResult <- tryAllErrors $ do
+                  dm <- encodeConnInfo $ XGrpRelayTest challenge Nothing
+                  void $ withAgent $ \a -> joinConnection a nm (aUserId user) acId True cReq dm PQSupportOff subMode
+                  liftIO $ timeout 40000000 $ atomically $ takeTMVar testVar
+                atomically $ TM.delete acId chatRelayTests_
+                withFastStore' $ \db -> deleteConnectionRecord db user testCId
+                deleteAgentConnectionAsync acId
+                case testResult of
+                  Left e -> failWithProfile RTSConnect e
+                  Right Nothing -> failWithProfile RTSWaitResponse (ChatError $ CERelayTestError "timeout")
+                  Right (Just Nothing) -> pure $ CRChatRelayTestResult user (Just relayProfile) Nothing
+                  Right (Just (Just failure)) -> pure $ CRChatRelayTestResult user (Just relayProfile) (Just failure)
+  TestChatRelay address -> withUser $ \User {userId} ->
+    processChatCommand vr nm $ APITestChatRelay userId address
  GetUserChatRelays -> withUser $ \user -> do
    srvs <- withFastStore (`getUserServers` user)
    liftIO $ CRUserServers user <$> groupByOperator (onlyRelays srvs)
@@ -2161,14 +2202,16 @@ processChatCommand vr nm = \case
    CRContactsList user <$> withFastStore' (\db -> getUserContacts db vr user)
  ListContacts -> withUser $ \User {userId} ->
    processChatCommand vr nm $ APIListContacts userId
-  APICreateMyAddress userId -> withUserId userId $ \user@User {userChatRelay} -> do
+  APICreateMyAddress userId -> withUserId userId $ \user@User {profile = LocalProfile {displayName}, userChatRelay} -> do
    withFastStore' (\db -> runExceptT $ getUserAddress db user) >>= \case
      Left SEUserContactLinkNotFound -> pure ()
      Left e -> throwError $ ChatErrorStore e
      Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink
    subMode <- chatReadVar subscriptionMode
-    -- TODO [relays] relay: add relay profile, identity, key to link data?
-    let userData = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing
+    -- TODO [relays] relay: add identity, key to link data?
+    let userData
+          | isTrue userChatRelay = encodeShortLinkData $ RelayAddressLinkData {relayProfile = RelayProfile {name = displayName}}
+          | otherwise = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing
        userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
    -- TODO [certs rcv]
    (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode
@@ -4504,6 +4547,8 @@ cleanupManager = do
      liftIO $ threadDelay' stepDelay
      cleanupInProgressGroups user `catchAllErrors` eToView
      liftIO $ threadDelay' stepDelay
+      cleanupStaleRelayTestConns user `catchAllErrors` eToView
+      liftIO $ threadDelay' stepDelay
    cleanupTimedItems cleanupInterval user = do
      ts <- liftIO getCurrentTime
      let startTimedThreadCutoff = addUTCTime cleanupInterval ts
@@ -4523,6 +4568,13 @@ cleanupManager = do
      inProgressGroups <- withStore' $ \db -> getInProgressGroups db vr user cutoffTs
      forM_ inProgressGroups $ \gInfo ->
        deleteInProgressGroup user gInfo `catchAllErrors` eToView
+    cleanupStaleRelayTestConns user = do
+      ts <- liftIO getCurrentTime
+      let cutoffTs = addUTCTime (-300) ts
+      staleConns <- withStore' $ \db -> getStaleRelayTestConns db user cutoffTs
+      forM_ staleConns $ \acId -> do
+        deleteAgentConnectionAsync acId
+        withStore' $ \db -> deleteConnectionByAgentConnId db user acId
    cleanupMessages = do
      ts <- liftIO getCurrentTime
      let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
@@ -4767,6 +4819,8 @@ chatCommandP =
      "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP),
      "/smp" $> GetUserProtoServers (AProtocolType SPSMP),
      "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP),
+      "/_relay test " *> (APITestChatRelay <$> A.decimal <* A.space <*> strP),
+      "/relay test " *> (TestChatRelay <$> strP),
      "/relays " *> (SetUserChatRelays <$> chatRelaysP),
      "/relays" $> GetUserChatRelays,
      "/_operators" $> APIGetServerOperators,
@@ -406,15 +406,41 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
    processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVersion, peerChatVRange, viaUserContactLink, customUserProfileId, connectionCode} = \case
      Nothing -> case agentMsg of
        CONF confId pqSupport _ connInfo -> do
-          conn' <- processCONFpqSupport conn pqSupport
-          -- [incognito] send saved profile
-          (conn'', gInfo_) <- saveConnInfo conn' connInfo
-          incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
-          let profileToSend = case gInfo_ of
-                Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
-                Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
-          -- [async agent commands] no continuation needed, but command should be asynchronous for stability
-          allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
+          chatRelayTests_ <- asks chatRelayTests
+          relayTest_ <- atomically $ TM.lookup agentConnId chatRelayTests_
+          case relayTest_ of
+            Just RelayTest {challenge, rootKey, result = testVar} -> do
+              r <- tryAllErrors $ do
+                ChatMessage {chatMsgEvent} <- parseChatMessage conn connInfo
+                case chatMsgEvent of
+                  XGrpRelayTest _challenge sigBytes_ ->
+                    case sigBytes_ of
+                      Just sigBytes -> case C.decodeSignature sigBytes of
+                        Right sig
+                          | C.verify' rootKey sig challenge ->
+                              atomically $ putTMVar testVar Nothing
+                          | otherwise ->
+                              atomically $ putTMVar testVar (Just $ RelayTestFailure RTSVerify (ChatError $ CERelayTestError "invalid signature"))
+                        Left e ->
+                          atomically $ putTMVar testVar (Just $ RelayTestFailure RTSVerify (ChatError $ CERelayTestError $ "signature decoding failed: " <> e))
+                      Nothing ->
+                        atomically $ putTMVar testVar (Just $ RelayTestFailure RTSVerify (ChatError $ CERelayTestError "no signature in response"))
+                  _ ->
+                    atomically $ putTMVar testVar (Just $ RelayTestFailure RTSWaitResponse (ChatError $ CERelayTestError "unexpected message type"))
+              case r of
+                Left e ->
+                  atomically $ putTMVar testVar (Just $ RelayTestFailure RTSWaitResponse e)
+                Right () -> pure ()
+            Nothing -> do
+              conn' <- processCONFpqSupport conn pqSupport
+              -- [incognito] send saved profile
+              (conn'', gInfo_) <- saveConnInfo conn' connInfo
+              incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
+              let profileToSend = case gInfo_ of
+                    Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
+                    Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
+              -- [async agent commands] no continuation needed, but command should be asynchronous for stability
+              allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
        INFO pqSupport connInfo -> do
          processINFOpqSupport conn pqSupport
          void $ saveConnInfo conn connInfo
@@ -1247,6 +1273,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
          XMember p joiningMemberId joiningMemberKey -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey
          XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport
          XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
+          XGrpRelayTest challenge _ -> xGrpRelayTest invId chatVRange challenge
          -- TODO show/log error, other events in contact request
          _ -> pure ()
      LINK _link auData ->
@@ -1453,6 +1480,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
        xGrpRelayInv invId chatVRange groupRelayInv = do
          (_gInfo, _ownerMember) <- withStore $ \db -> createRelayRequestGroup db vr user groupRelayInv invId chatVRange
          lift $ void $ getRelayRequestWorker True
+        xGrpRelayTest :: InvitationId -> VersionRangeChat -> ByteString -> CM ()
+        xGrpRelayTest invId chatVRange challenge = do
+          privKey_ <- withAgent $ \a -> getConnLinkPrivKey a (aConnId conn)
+          case privKey_ of
+            Nothing -> eToView $ ChatError (CEInternalError "no short link key for relay address")
+            Just privKey -> do
+              let sig = C.signatureBytes $ C.sign' privKey challenge
+                  msg = XGrpRelayTest challenge (Just sig)
+              subMode <- chatReadVar subscriptionMode
+              chatVR <- chatVersionRange
+              let chatV = chatVR `peerConnChatVersion` chatVRange
+              (cmdId, acId) <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV
+              withFastStore $ \db -> do
+                Connection {connId = testCId} <- createRelayTestConnection db vr user acId ConnAccepted chatV subMode
+                liftIO $ setCommandConnId db user cmdId testCId
        -- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays
        -- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember)
        memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> MemberKey -> CM ()
@@ -46,6 +46,7 @@ import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime, nominalDay)
 import Language.Haskell.TH.Syntax (lift)
 import Simplex.Chat.Operators.Conditions
+import Simplex.Chat.Protocol (RelayProfile (..))
 import Simplex.Chat.Types (ShortLinkContact, User)
 import Simplex.Chat.Types.Shared (RelayStatus)
 import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
@@ -263,7 +264,7 @@ deriving instance Show AUserChatRelay
 data UserChatRelay' s = UserChatRelay
  { chatRelayId :: DBEntityId' s,
    address :: ShortLinkContact,
-    name :: Text,
+    relayProfile :: RelayProfile,
    domains :: [Text],
    preset :: Bool,
    tested :: Maybe Bool,
@@ -340,7 +341,7 @@ newChatRelay = newChatRelay_ False True

 newChatRelay_ :: Bool -> Bool -> Text -> [Text] -> ShortLinkContact -> NewUserChatRelay
 newChatRelay_ preset enabled name domains !address =
-  UserChatRelay {chatRelayId = DBNewEntity, address, name, domains, preset, tested = Nothing, enabled, deleted = False}
+  UserChatRelay {chatRelayId = DBNewEntity, address, relayProfile = RelayProfile {name}, domains, preset, tested = Nothing, enabled, deleted = False}

 -- This function should be used inside DB transaction to update conditions in the database
 -- it evaluates to (current conditions, and conditions to add)
@@ -543,11 +544,11 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other
    chatRelayErrs uss = concatMap duplicateErrs_ cRelays
      where
        cRelays = filter (\(AUCR _ UserChatRelay {deleted}) -> not deleted) $ userChatRelays uss
-        duplicateErrs_ (AUCR _ UserChatRelay {name, address}) =
+        duplicateErrs_ (AUCR _ UserChatRelay {relayProfile = RelayProfile {name}, address}) =
          [USEDuplicateChatRelayName name | name `elem` duplicateNames]
            <> [USEDuplicateChatRelayAddress name address | address `elem` duplicateAddresses]
        duplicateNames = snd $ foldl' addDuplicate (S.empty, S.empty) allNames
-        allNames = map (\(AUCR _ UserChatRelay {name}) -> name) cRelays
+        allNames = map (\(AUCR _ UserChatRelay {relayProfile = RelayProfile {name}}) -> name) cRelays
        duplicateAddresses = snd $ foldl' addAddress ([], []) allAddresses
        allAddresses = map (\(AUCR _ UserChatRelay {address}) -> address) cRelays
        addAddress :: ([ShortLinkContact], [ShortLinkContact]) -> ShortLinkContact -> ([ShortLinkContact], [ShortLinkContact])
@@ -436,6 +436,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
  XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
  XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
  XGrpRelayAcpt :: ShortLinkContact -> ChatMsgEvent 'Json
+  XGrpRelayTest :: ByteString -> Maybe ByteString -> ChatMsgEvent 'Json
  XGrpMemNew :: MemberInfo -> Maybe MsgScope -> ChatMsgEvent 'Json
  XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json
  XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
@@ -964,6 +965,7 @@ data CMEventTag (e :: MsgEncoding) where
  XGrpLinkAcpt_ :: CMEventTag 'Json
  XGrpRelayInv_ :: CMEventTag 'Json
  XGrpRelayAcpt_ :: CMEventTag 'Json
+  XGrpRelayTest_ :: CMEventTag 'Json
  XGrpMemNew_ :: CMEventTag 'Json
  XGrpMemIntro_ :: CMEventTag 'Json
  XGrpMemInv_ :: CMEventTag 'Json
@@ -1020,6 +1022,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
    XGrpLinkAcpt_ -> "x.grp.link.acpt"
    XGrpRelayInv_ -> "x.grp.relay.inv"
    XGrpRelayAcpt_ -> "x.grp.relay.acpt"
+    XGrpRelayTest_ -> "x.grp.relay.test"
    XGrpMemNew_ -> "x.grp.mem.new"
    XGrpMemIntro_ -> "x.grp.mem.intro"
    XGrpMemInv_ -> "x.grp.mem.inv"
@@ -1077,6 +1080,7 @@ instance StrEncoding ACMEventTag where
        "x.grp.link.acpt" -> XGrpLinkAcpt_
        "x.grp.relay.inv" -> XGrpRelayInv_
        "x.grp.relay.acpt" -> XGrpRelayAcpt_
+        "x.grp.relay.test" -> XGrpRelayTest_
        "x.grp.mem.new" -> XGrpMemNew_
        "x.grp.mem.intro" -> XGrpMemIntro_
        "x.grp.mem.inv" -> XGrpMemInv_
@@ -1130,6 +1134,7 @@ toCMEventTag msg = case msg of
  XGrpLinkAcpt {} -> XGrpLinkAcpt_
  XGrpRelayInv _ -> XGrpRelayInv_
  XGrpRelayAcpt _ -> XGrpRelayAcpt_
+  XGrpRelayTest {} -> XGrpRelayTest_
  XGrpMemNew {} -> XGrpMemNew_
  XGrpMemIntro _ _ -> XGrpMemIntro_
  XGrpMemInv _ _ -> XGrpMemInv_
@@ -1282,6 +1287,10 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
      XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
      XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
      XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink"
+      XGrpRelayTest_ -> do
+        B64UrlByteString challenge <- p "challenge"
+        sig_ <- fmap (\(B64UrlByteString s) -> s) <$> opt "signature"
+        pure $ XGrpRelayTest challenge sig_
      XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" <*> opt "scope"
      XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions"
      XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro"
@@ -1349,6 +1358,9 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
      XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
      XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
      XGrpRelayAcpt relayLink -> o ["relayLink" .= relayLink]
+      XGrpRelayTest challenge sig_ -> o $
+        ("signature" .=? (B64UrlByteString <$> sig_))
+        ["challenge" .= B64UrlByteString challenge]
      XGrpMemNew memInfo scope -> o $ ("scope" .=? scope) ["memberInfo" .= memInfo]
      XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo]
      XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro]
@@ -1443,3 +1455,13 @@ data RelayShortLinkData = RelayShortLinkData

 $(JQ.deriveJSON defaultJSON ''RelayShortLinkData)

+data RelayProfile = RelayProfile {name :: ContactName}
+  deriving (Eq, Show)
+
+$(JQ.deriveJSON defaultJSON ''RelayProfile)
+
+data RelayAddressLinkData = RelayAddressLinkData {relayProfile :: RelayProfile}
+  deriving (Show)
+
+$(JQ.deriveJSON defaultJSON ''RelayAddressLinkData)
+
@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

@@ -31,6 +32,7 @@ module Simplex.Chat.Store.Direct
    createIncognitoProfile,
    createConnReqConnection,
    createRelayMemberConnectionAsync,
+    createRelayTestConnection,
    updateConnLinkData,
    setPreparedGroupStartedConnection,
    getProfileById,
@@ -112,7 +114,7 @@ import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ACreatedCon
 import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
 import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Crypto.Ratchet (PQSupport)
+import Simplex.Messaging.Crypto.Ratchet (PQSupport, pattern PQSupportOff)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Protocol (SubscriptionMode (..))
 #if defined(dbPostgres)
@@ -241,6 +243,26 @@ createRelayMemberConnectionAsync db user@User {userId} gInfo GroupMember {groupM
  where
    customUserProfileId_ = localProfileId <$> incognitoMembershipProfile gInfo

+createRelayTestConnection :: DB.Connection -> VersionRangeChat -> User -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
+createRelayTestConnection db vr user@User {userId} agentConnId connStatus chatV subMode = do
+  currentTs <- liftIO getCurrentTime
+  liftIO $
+    DB.execute
+      db
+      [sql|
+        INSERT INTO connections (
+          user_id, agent_conn_id, conn_level, conn_status, conn_type,
+          conn_chat_version, to_subscribe, pq_support, pq_encryption,
+          relay_test, created_at, updated_at
+        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+      |]
+      ( (userId, agentConnId, 0 :: Int, connStatus, ConnContact)
+          :. (chatV, BI (subMode == SMOnlyCreate), PQSupportOff, PQSupportOff)
+          :. (BI True, currentTs, currentTs)
+      )
+  connId <- liftIO $ insertedRowId db
+  getConnectionById db vr user connId
+
 updateConnLinkData :: DB.Connection -> User -> Connection -> ConnReqContact -> ConnReqUriHash -> Maybe GroupLinkId -> VersionChat -> PQSupport -> IO ()
 updateConnLinkData db User {userId} Connection {connId} cReq cReqHash groupLinkId_ chatV pqSup = do
  currentTs <- getCurrentTime
@@ -1335,11 +1335,11 @@ groupRelayQuery =

 toGroupRelay :: (Int64, GroupMemberId, DBEntityId, ShortLinkContact, Text, Text, BoolInt, Maybe BoolInt, BoolInt, BoolInt, RelayStatus, Maybe ShortLinkContact) -> GroupRelay
 toGroupRelay (groupRelayId, groupMemberId, chatRelayId, address, name, domains, BI preset, tested, BI enabled, BI deleted, relayStatus, relayLink) =
-  let userChatRelay = UserChatRelay {chatRelayId, address, name, domains = T.splitOn "," domains, preset, tested = unBI <$> tested, enabled, deleted}
+  let userChatRelay = UserChatRelay {chatRelayId, address, relayProfile = RelayProfile {name}, domains = T.splitOn "," domains, preset, tested = unBI <$> tested, enabled, deleted}
   in GroupRelay {groupRelayId, groupMemberId, userChatRelay, relayStatus, relayLink}

 createRelayForOwner :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
-createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {name} = do
+createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {name}} = do
  currentTs <- liftIO getCurrentTime
  let relayProfile = profileFromName name
  (localDisplayName, memProfileId) <- createNewMemberProfile_ db user relayProfile currentTs
@@ -72,6 +72,8 @@ ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT;
 ALTER TABLE messages ADD COLUMN msg_signatures BYTEA;

 ALTER TABLE chat_items ADD COLUMN msg_signed TEXT;
+
+ALTER TABLE connections ADD COLUMN relay_test SMALLINT NOT NULL DEFAULT 0;
 |]

 down_m20260222_chat_relays :: Text
@@ -120,4 +122,6 @@ ALTER TABLE messages DROP COLUMN msg_chat_binding;
 ALTER TABLE messages DROP COLUMN msg_signatures;

 ALTER TABLE chat_items DROP COLUMN msg_signed;
+
+ALTER TABLE connections DROP COLUMN relay_test;
 |]
@@ -634,7 +634,7 @@ getChatRelays db User {userId} =

 toChatRelay :: (DBEntityId, ShortLinkContact, Text, Text, BoolInt, Maybe BoolInt, BoolInt) -> UserChatRelay
 toChatRelay (chatRelayId, address, name, domains, BI preset, tested, BI enabled) =
-  UserChatRelay {chatRelayId, address, name, domains = T.splitOn "," domains, preset, tested = unBI <$> tested, enabled, deleted = False}
+  UserChatRelay {chatRelayId, address, relayProfile = RelayProfile {name}, domains = T.splitOn "," domains, preset, tested = unBI <$> tested, enabled, deleted = False}

 getChatRelayById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserChatRelay
 getChatRelayById db User {userId} relayId =
@@ -649,7 +649,7 @@ getChatRelayById db User {userId} relayId =
      (userId, relayId)

 insertChatRelay :: DB.Connection -> User -> UTCTime -> NewUserChatRelay -> IO UserChatRelay
-insertChatRelay db User {userId} ts relay@UserChatRelay {address, name, domains, preset, tested, enabled} = do
+insertChatRelay db User {userId} ts relay@UserChatRelay {address, relayProfile = RelayProfile {name}, domains, preset, tested, enabled} = do
  crId <-
    fromOnly . head
      <$> DB.query
@@ -664,7 +664,7 @@ insertChatRelay db User {userId} ts relay@UserChatRelay {address, name, domains,
  pure (relay :: NewUserChatRelay) {chatRelayId = DBEntityId crId}

 updateChatRelay :: DB.Connection -> UTCTime -> UserChatRelay -> IO ()
-updateChatRelay db ts UserChatRelay {chatRelayId, address, name, domains, preset, tested, enabled} =
+updateChatRelay db ts UserChatRelay {chatRelayId, address, relayProfile = RelayProfile {name}, domains, preset, tested, enabled} =
  DB.execute
    db
    [sql|
@@ -948,7 +948,7 @@ setUserServers' db user@User {userId} ts UpdatedUserOperatorServers {operator, s
        | otherwise -> Just relay <$ updateChatRelay db ts relay
    -- Un-delete soft-deleted relay, updating name and settings but keeping the address unchanged.
    undeleteRelay :: Int64 -> NewUserChatRelay -> IO ()
-    undeleteRelay existingId UserChatRelay {name = nm, domains, preset, tested, enabled} =
+    undeleteRelay existingId UserChatRelay {relayProfile = RelayProfile {name = nm}, domains, preset, tested, enabled} =
      DB.execute db
        [sql|
          UPDATE chat_relays
@@ -80,6 +80,8 @@ ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT;
 ALTER TABLE messages ADD COLUMN msg_signatures BLOB;

 ALTER TABLE chat_items ADD COLUMN msg_signed TEXT;
+
+ALTER TABLE connections ADD COLUMN relay_test INTEGER NOT NULL DEFAULT 0;
 |]

 down_m20260222_chat_relays :: Query
@@ -124,4 +126,6 @@ ALTER TABLE messages DROP COLUMN msg_chat_binding;
 ALTER TABLE messages DROP COLUMN msg_signatures;

 ALTER TABLE chat_items DROP COLUMN msg_signed;
+
+ALTER TABLE connections DROP COLUMN relay_test;
 |]
@@ -1764,6 +1764,15 @@ Query:
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)

+Query: 
+        INSERT INTO connections (
+          user_id, agent_conn_id, conn_level, conn_status, conn_type,
+          conn_chat_version, to_subscribe, pq_support, pq_encryption,
+          relay_test, created_at, updated_at
+        ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+      
+Plan:
+
 Query: 
        INSERT INTO connections (
          user_id, agent_conn_id, conn_level, conn_status, conn_type,
@@ -3293,6 +3302,13 @@ Query:
 Plan:
 SEARCH connections USING INDEX idx_connections_contact_id (contact_id=?)

+Query: 
+        SELECT agent_conn_id FROM connections
+        WHERE user_id = ? AND relay_test = 1 AND created_at < ?
+      
+Plan:
+SEARCH connections USING INDEX idx_connections_to_subscribe (user_id=?)
+
 Query: 
        SELECT c.agent_conn_id
        FROM connections c
@@ -340,6 +340,7 @@ CREATE TABLE connections(
  short_link_inv BLOB,
  via_short_link_contact BLOB,
  via_contact_uri BLOB,
+  relay_test INTEGER NOT NULL DEFAULT 0,
  FOREIGN KEY(snd_file_id, connection_id)
  REFERENCES snd_files(file_id, connection_id)
  ON DELETE CASCADE
@@ -899,3 +899,18 @@ setViaGroupLinkUri db groupId connId = do
 deleteConnectionRecord :: DB.Connection -> User -> Int64 -> IO ()
 deleteConnectionRecord db User {userId} cId = do
  DB.execute db "DELETE FROM connections WHERE user_id = ? AND connection_id = ?" (userId, cId)
+
+getStaleRelayTestConns :: DB.Connection -> User -> UTCTime -> IO [ConnId]
+getStaleRelayTestConns db User {userId} cutoffTs =
+  map fromOnly <$>
+    DB.query
+      db
+      [sql|
+        SELECT agent_conn_id FROM connections
+        WHERE user_id = ? AND relay_test = 1 AND created_at < ?
+      |]
+      (userId, cutoffTs)
+
+deleteConnectionByAgentConnId :: DB.Connection -> User -> ConnId -> IO ()
+deleteConnectionByAgentConnId db User {userId} acId =
+  DB.execute db "DELETE FROM connections WHERE user_id = ? AND agent_conn_id = ?" (userId, acId)
@@ -125,6 +125,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
  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
+  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)
  CRUserServersValidation {} -> []
@@ -1578,7 +1579,7 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers, chatRela
          ["  Chat relays"] <> map (plain . ("    " <>) . viewChatRelay) cRelays
      | otherwise = []
      where
-        viewChatRelay UserChatRelay {name, address, preset, tested, enabled} = name <> relayAddress <> relayInfo
+        viewChatRelay UserChatRelay {relayProfile = RelayProfile {name}, address, preset, tested, enabled} = name <> relayAddress <> relayInfo
          where
            relayAddress = ": " <> safeDecodeUtf8 (strEncode address)
            relayInfo = if null relayInfo_ then "" else parens $ T.intercalate ", " relayInfo_
@@ -1613,6 +1614,14 @@ viewServerTestResult (AProtoServerWithAuth p _) = \case
  where
    pName = protocolName p

+viewRelayTestResult :: Maybe RelayProfile -> Maybe RelayTestFailure -> [StyledString]
+viewRelayTestResult relayProfile_ = \case
+  Just RelayTestFailure {rtfStep, rtfError} ->
+    ["relay test failed at " <> plain (show rtfStep) <> ", error: " <> plain (show rtfError)]
+  Nothing -> case relayProfile_ of
+    Just RelayProfile {name} -> ["relay test passed, profile: " <> plain (T.unpack name)]
+    Nothing -> ["relay test passed"]
+
 viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString]
 viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca

@@ -2596,6 +2605,7 @@ viewChatError isCmd logLevel testView = \case
    CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]
    CEConnectionUserChangeProhibited -> ["incognito mode change prohibited for user"]
    CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"]
+    CERelayTestError e -> ["relay test error: " <> plain e]
    CEInternalError e -> ["internal chat error: " <> plain e]
    CEException e -> ["exception: " <> plain e]
  -- e -> ["chat error: " <> sShow e]