From cbeaf004dde88a27c29b3e2ed48adac9f2ba53b6 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 14:15:30 +0000 Subject: [PATCH 1/7] smp-server: process forwarded RSLV in processCommand --- src/Simplex/Messaging/Server.hs | 27 +++++++++++---------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 813b52fe1..3b209bd67 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1415,7 +1415,7 @@ client let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams') process batchSubs t acc@(rs, msgs) = (maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_))) - <$> processCommand clntServiceId batchSubs t + <$> processCommand (thVersion thParams') (forkCmd serverClientConcurrency) clntServiceId batchSubs t forever $ do batch <- atomically (readTBQueue rcvQ) processedAt <- liftIO getSystemTime @@ -1572,8 +1572,8 @@ client mkIncProxyStats ps psOwn own sel = do incStat $ sel ps when own $ incStat $ sel psOwn - processCommand :: Maybe ServiceId -> Either ErrorType (Map RecipientId Message, Map RecipientId (Either ErrorType ()), Map RecipientId (Either ErrorType ())) -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage) - processCommand clntServiceId batchSubs (q_, (corrId, entId, cmd)) = case cmd of + processCommand :: VersionSMP -> (CorrId -> EntityId -> BrokerMsg -> M s BrokerMsg -> M s (Maybe ResponseAndMessage)) -> Maybe ServiceId -> Either ErrorType (Map RecipientId Message, Map RecipientId (Either ErrorType ()), Map RecipientId (Either ErrorType ())) -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage) + processCommand clntVersion forkClntCmd clntServiceId batchSubs (q_, (corrId, entId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command) Cmd SSender command -> case command of SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k @@ -1582,7 +1582,7 @@ client Cmd SProxyService (RFWD encBlock) -> (response . (corrId, NoEntity,) =<<) <$> processForwardedCommand encBlock Cmd SResolver (RSLV d) -> rslvNamesEnv >>= \case Nothing -> pure $ response (corrId, NoEntity, ERR (NAME NO_RESOLVER)) - Just nenv -> forkCmd serverClientConcurrency corrId NoEntity rslvTooManyRequests (resolveNameMsg (thVersion thParams') nenv d) + Just nenv -> forkClntCmd corrId NoEntity rslvTooManyRequests (resolveNameMsg clntVersion nenv d) Cmd SSenderLink command -> case command of LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr @@ -2211,22 +2211,17 @@ client r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (fromMaybe (C.reverseNonce clientNonce) nonce_) r' paddedProxiedTLength let fr = FwdResponse {fwdCorrId, fwdResponse = r2} pure $ RRES nonce_ $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) + forkFwdCmd corrId' entId' timeoutErr cmdAction = forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResolved timeoutErr) (cmdAction >>= sendResolved) + where + sendResolved msg = do + rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg)) + atomically $ writeTBQueue sndQ ([(corrId, NoEntity, rres)], []) -- the inner response, or Nothing if forked (RSLV). r_ <- lift (rejectOrVerify clntThAuth t') >>= \case -- rejectOrVerify filters allowed commands, no need to repeat it here. Left r -> pure $ Just r - Right t''@(_, (corrId', entId', cmd')) -> case cmd' of - Cmd SResolver (RSLV d) -> lift $ rslvNamesEnv >>= \case - Nothing -> pure $ Just (corrId', entId', ERR (NAME NO_RESOLVER)) - Just nenv -> do - let sendResolved msg = do - rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg)) - atomically $ writeTBQueue sndQ ([(corrId, NoEntity, rres)], []) - forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResolved rslvTooManyRequests) $ - resolveNameMsg (thVersion clntTHParams) nenv d >>= sendResolved - -- INTERNAL because processCommand never returns Nothing for sender commands; - -- `fst` drops the empty message only returned for SUB. - _ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'') + -- `fst` drops the empty message only returned for SUB. + Right t'' -> fmap fst <$> lift (processCommand (thVersion clntTHParams) forkFwdCmd Nothing (Right (M.empty, M.empty, M.empty)) t'') stats <- asks serverStats incStat $ pMsgFwdsRecv stats traverse encodeResp r_ >>= \case From 086655b148028a81fc1df4e8a8969a0d980771fb Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 14:46:54 +0000 Subject: [PATCH 2/7] smp-server: rename sendResolved to sendResp --- src/Simplex/Messaging/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 3b209bd67..f03dc34b3 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -2211,9 +2211,9 @@ client r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (fromMaybe (C.reverseNonce clientNonce) nonce_) r' paddedProxiedTLength let fr = FwdResponse {fwdCorrId, fwdResponse = r2} pure $ RRES nonce_ $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) - forkFwdCmd corrId' entId' timeoutErr cmdAction = forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResolved timeoutErr) (cmdAction >>= sendResolved) + forkFwdCmd corrId' entId' timeoutErr cmdAction = forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResp timeoutErr) (cmdAction >>= sendResp) where - sendResolved msg = do + sendResp msg = do rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg)) atomically $ writeTBQueue sndQ ([(corrId, NoEntity, rres)], []) -- the inner response, or Nothing if forked (RSLV). From 6476f6195da71d8f6de43cc3d1e730592c8b5a3d Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 15:08:06 +0000 Subject: [PATCH 3/7] smp-server: match idioms in forwarded RSLV code --- src/Simplex/Messaging/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index f03dc34b3..0a035f622 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -2211,7 +2211,7 @@ client r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (fromMaybe (C.reverseNonce clientNonce) nonce_) r' paddedProxiedTLength let fr = FwdResponse {fwdCorrId, fwdResponse = r2} pure $ RRES nonce_ $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) - forkFwdCmd corrId' entId' timeoutErr cmdAction = forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResp timeoutErr) (cmdAction >>= sendResp) + forkFwdCmd corrId' entId' timeoutErr cmdAction = forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResp timeoutErr) $ cmdAction >>= sendResp where sendResp msg = do rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg)) @@ -2221,7 +2221,7 @@ client -- rejectOrVerify filters allowed commands, no need to repeat it here. Left r -> pure $ Just r -- `fst` drops the empty message only returned for SUB. - Right t'' -> fmap fst <$> lift (processCommand (thVersion clntTHParams) forkFwdCmd Nothing (Right (M.empty, M.empty, M.empty)) t'') + Right t'' -> fst <$$> lift (processCommand (thVersion clntTHParams) forkFwdCmd Nothing (Right (M.empty, M.empty, M.empty)) t'') stats <- asks serverStats incStat $ pMsgFwdsRecv stats traverse encodeResp r_ >>= \case From b14103134f807aa256cc299d67a494fc692a50ca Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 15:08:06 +0000 Subject: [PATCH 4/7] tests: forwarded RSLV without resolver and on slot wait --- tests/RSLVTests.hs | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 0d096bccb..7124268e3 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -27,6 +27,7 @@ import NamesResolverServer (memCfg, memCfg2, memProxyCfg, withNames) import qualified NamesResolverServer as NRS import SMPClient import Simplex.Messaging.Client +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String (strDecode) import SMPNamesTests (availableBody, registeredBody, reservedBody, resolved, testNameRecord, testPricing) @@ -55,6 +56,7 @@ import Simplex.Messaging.SimplexName (SimplexDomain) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec hiding (fit, it) +import UnliftIO.Async (mapConcurrently) import Util (HasTestEnv, it) domain :: Text -> SimplexDomain @@ -93,6 +95,8 @@ rslvTests = do describe "RSLV forwarded (PFWD)" $ do it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError (NAME RESOLVER))" testRslvForwarded it "PFWD-wrapped RSLV success returns RNAME (record JSON frames over the proxy)" testRslvForwardedSuccess + it "PFWD-wrapped RSLV without names config -> NAME NO_RESOLVER" testRslvForwardedDisabled + it "PFWD-wrapped RSLV waiting for a slot fails at the relay wait timeout" testRslvForwardedSlotWaitTimeout describe "RSLV success path (RNAME response)" $ do it "returns RNAME with NameRecord" testRslvSuccess describe "RSLV availability (RNAME response)" $ do @@ -150,7 +154,10 @@ testRslvVersion = _ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r forwardedResolveAlice :: HasTestEnv => IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) -forwardedResolveAlice = do +forwardedResolveAlice = proxiedRelaySession >>= uncurry resolveAliceVia + +proxiedRelaySession :: HasTestEnv => IO (SMPClient, ProxiedRelay) +proxiedRelaySession = do g <- C.newRandom ts <- getCurrentTime let proxyServ = SMPServer testHost testPort testKeyHash @@ -159,7 +166,33 @@ forwardedResolveAlice = do pcE <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) cfg' [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pcE sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing) - runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) + pure (pc, sess) + +resolveAliceVia :: SMPClient -> ProxiedRelay -> IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) +resolveAliceVia pc sess = runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) + +testRslvForwardedDisabled :: HasTestEnv => IO () +testRslvForwardedDisabled = + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) memCfg2 testPort2 $ \_ -> + forwardedResolveAlice `shouldReturn` Left (PCEProtocolError (SMP.NAME SMP.NO_RESOLVER)) + +testRslvForwardedSlotWaitTimeout :: HasTestEnv => IO () +testRslvForwardedSlotWaitTimeout = + NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port _ -> + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) (relayCfg port) testPort2 $ \_ -> do + (pc, sess) <- proxiedRelaySession + rs <- mapConcurrently (const $ resolveAliceVia pc sess) [1, 2 :: Int] + rs `shouldMatchList` map rslvErr ["timeout", "too many requests"] + where + rslvErr :: Text -> Either SMPClientError (Either ProxyClientError SMP.NameResponse) + rslvErr = Left . PCEProtocolError . SMP.NAME . SMP.RESOLVER + relayCfg port = updateCfg (withNames port memCfg2) $ \c -> + let aCfg = smpAgentCfg c + cCfg = smpCfg aCfg + nt = NetworkTimeout {backgroundTimeout = 300000, interactiveTimeout = 300000} + in c {serverResolverConcurrency = 1, smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}} testRslvForwarded :: HasTestEnv => IO () testRslvForwarded = From b4028f15fdbefc23f031a05bce11a72d9bba0281 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 15:15:47 +0000 Subject: [PATCH 5/7] tests: reuse forwardedResolveAlice in slot wait test --- tests/RSLVTests.hs | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 7124268e3..9673ee626 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -56,7 +56,7 @@ import Simplex.Messaging.SimplexName (SimplexDomain) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec hiding (fit, it) -import UnliftIO.Async (mapConcurrently) +import UnliftIO.Async (replicateConcurrently) import Util (HasTestEnv, it) domain :: Text -> SimplexDomain @@ -154,10 +154,7 @@ testRslvVersion = _ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r forwardedResolveAlice :: HasTestEnv => IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) -forwardedResolveAlice = proxiedRelaySession >>= uncurry resolveAliceVia - -proxiedRelaySession :: HasTestEnv => IO (SMPClient, ProxiedRelay) -proxiedRelaySession = do +forwardedResolveAlice = do g <- C.newRandom ts <- getCurrentTime let proxyServ = SMPServer testHost testPort testKeyHash @@ -166,10 +163,7 @@ proxiedRelaySession = do pcE <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) cfg' [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pcE sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing) - pure (pc, sess) - -resolveAliceVia :: SMPClient -> ProxiedRelay -> IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) -resolveAliceVia pc sess = runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) + runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) testRslvForwardedDisabled :: HasTestEnv => IO () testRslvForwardedDisabled = @@ -182,8 +176,7 @@ testRslvForwardedSlotWaitTimeout = NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port _ -> withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> withSmpServerConfigOn (transport @TLS) (relayCfg port) testPort2 $ \_ -> do - (pc, sess) <- proxiedRelaySession - rs <- mapConcurrently (const $ resolveAliceVia pc sess) [1, 2 :: Int] + rs <- replicateConcurrently 2 forwardedResolveAlice rs `shouldMatchList` map rslvErr ["timeout", "too many requests"] where rslvErr :: Text -> Either SMPClientError (Either ProxyClientError SMP.NameResponse) From 593dcfcd4d6fe4630b7860d3025638322c7e25da Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 15:22:44 +0000 Subject: [PATCH 6/7] tests: check relay slot wait in forwarded RSLV test --- tests/RSLVTests.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 9673ee626..0e5baa9b4 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -178,6 +178,10 @@ testRslvForwardedSlotWaitTimeout = withSmpServerConfigOn (transport @TLS) (relayCfg port) testPort2 $ \_ -> do rs <- replicateConcurrently 2 forwardedResolveAlice rs `shouldMatchList` map rslvErr ["timeout", "too many requests"] + threadDelay 1500000 + SlotWaitMetrics {waits, waitTimeouts, waitMaxMs} <- readSlotWaitMetrics + (waits, waitTimeouts) `shouldBe` (1, 1) + waitMaxMs `shouldSatisfy` (\t -> t >= 300 && t < 1000) where rslvErr :: Text -> Either SMPClientError (Either ProxyClientError SMP.NameResponse) rslvErr = Left . PCEProtocolError . SMP.NAME . SMP.RESOLVER @@ -185,7 +189,7 @@ testRslvForwardedSlotWaitTimeout = let aCfg = smpAgentCfg c cCfg = smpCfg aCfg nt = NetworkTimeout {backgroundTimeout = 300000, interactiveTimeout = 300000} - in c {serverResolverConcurrency = 1, smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}} + in c {serverResolverConcurrency = 1, prometheusInterval = Just 1, smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}} testRslvForwarded :: HasTestEnv => IO () testRslvForwarded = From f6f856eddd95cc1a2022bca128b5ba81cdc68980 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 16 Oct 2026 15:26:49 +0000 Subject: [PATCH 7/7] tests: inline expected errors in forwarded RSLV test --- tests/RSLVTests.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 0e5baa9b4..87836a52d 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -177,19 +177,21 @@ testRslvForwardedSlotWaitTimeout = withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> withSmpServerConfigOn (transport @TLS) (relayCfg port) testPort2 $ \_ -> do rs <- replicateConcurrently 2 forwardedResolveAlice - rs `shouldMatchList` map rslvErr ["timeout", "too many requests"] + rs `shouldMatchList` [Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER "timeout"))), Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER "too many requests")))] threadDelay 1500000 SlotWaitMetrics {waits, waitTimeouts, waitMaxMs} <- readSlotWaitMetrics (waits, waitTimeouts) `shouldBe` (1, 1) waitMaxMs `shouldSatisfy` (\t -> t >= 300 && t < 1000) where - rslvErr :: Text -> Either SMPClientError (Either ProxyClientError SMP.NameResponse) - rslvErr = Left . PCEProtocolError . SMP.NAME . SMP.RESOLVER relayCfg port = updateCfg (withNames port memCfg2) $ \c -> let aCfg = smpAgentCfg c cCfg = smpCfg aCfg nt = NetworkTimeout {backgroundTimeout = 300000, interactiveTimeout = 300000} - in c {serverResolverConcurrency = 1, prometheusInterval = Just 1, smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}} + in c + { serverResolverConcurrency = 1, + prometheusInterval = Just 1, + smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}} + } testRslvForwarded :: HasTestEnv => IO () testRslvForwarded =