From 14d909fc8f4ea49484797d9933241c83d51dee68 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 3 Jun 2026 13:48:27 +0000 Subject: [PATCH 01/15] agent: ConnectTarget type for connection link or SimpleX name Adds `ConnectTarget = CTLink AConnectionLink | CTName SimplexNameInfo` in Agent/Protocol.hs next to AConnectionLink. The StrEncoding parser gates the CTName branch on a `@`/`#`/`simplex:/name` discriminator so that bare tokens (which SimplexNameInfo accepts for Markdown's sake) cannot ambiguously match at this layer. JSON is a plain string via strToJEncoding, mirroring AConnectionLink. No consumers yet. --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent/Protocol.hs | 20 +++++++++ tests/CoreTests/ConnectTargetTests.hs | 59 +++++++++++++++++++++++++ tests/Test.hs | 2 + 4 files changed, 82 insertions(+) create mode 100644 tests/CoreTests/ConnectTargetTests.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 08c8b9625..6ef8abdb8 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -500,6 +500,7 @@ test-suite simplexmq-test AgentTests.ShortLinkTests CLITests CoreTests.BatchingTests + CoreTests.ConnectTargetTests CoreTests.CryptoFileTests CoreTests.CryptoTests CoreTests.EncodingTests diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 0860adf2a..573f64ed2 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -122,6 +122,7 @@ module Simplex.Messaging.Agent.Protocol OwnerId, ConnectionLink (..), AConnectionLink (..), + ConnectTarget (..), SimplexNameInfo (..), SimplexNameDomain (..), SimplexTLD (..), @@ -195,6 +196,7 @@ import qualified Data.Aeson.TH as J import qualified Data.Aeson.Types as JT import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Attoparsec.Combinator (lookAhead) import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -1596,6 +1598,24 @@ instance ToJSON AConnectionLink where instance FromJSON AConnectionLink where parseJSON = strParseJSON "AConnectionLink" +data ConnectTarget = CTLink AConnectionLink | CTName SimplexNameInfo + deriving (Eq, Show) + +instance StrEncoding ConnectTarget where + strEncode = \case + CTLink l -> strEncode l + CTName n -> strEncode n + strP = CTName <$> (lookAhead nameStart *> strP) <|> CTLink <$> strP + where + nameStart = "@" <|> "#" <|> "simplex:/name" + +instance ToJSON ConnectTarget where + toEncoding = strToJEncoding + toJSON = strToJSON + +instance FromJSON ConnectTarget where + parseJSON = strParseJSON "ConnectTarget" + instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k diff --git a/tests/CoreTests/ConnectTargetTests.hs b/tests/CoreTests/ConnectTargetTests.hs new file mode 100644 index 000000000..86506584c --- /dev/null +++ b/tests/CoreTests/ConnectTargetTests.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module CoreTests.ConnectTargetTests where + +import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) +import qualified Data.Aeson as J +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectTarget (..), ConnectionLink (..), SConnectionMode (..)) +import Simplex.Messaging.Encoding.String (strDecode, strEncode) +import Test.Hspec hiding (fit, it) +import Util (it) + +connectTargetTests :: Spec +connectTargetTests = describe "ConnectTarget" $ do + describe "CTName (SimpleX name) — canonical wire form prefixes simplex:/name" $ do + it "@alice.simplex encodes as simplex:/name@alice.simplex" $ + "@alice.simplex" `encodesAs` "simplex:/name@alice.simplex" + it "#privacy (bare TLD-less channel) encodes as simplex:/name#privacy.simplex" $ + "#privacy" `encodesAs` "simplex:/name#privacy.simplex" + it "#privacy.simplex encodes as simplex:/name#privacy.simplex" $ + "#privacy.simplex" `encodesAs` "simplex:/name#privacy.simplex" + it "#support.acme.simplex preserves subdomain" $ + "#support.acme.simplex" `encodesAs` "simplex:/name#support.acme.simplex" + it "simplex:/name@alice.simplex round-trips" $ + "simplex:/name@alice.simplex" `encodesAs` "simplex:/name@alice.simplex" + it "simplex:/name#privacy.simplex round-trips" $ + "simplex:/name#privacy.simplex" `encodesAs` "simplex:/name#privacy.simplex" + + describe "CTLink (connection link) round-trips" $ do + it "parses simplex:/contact#… as CTLink and round-trips" $ do + let s = strEncode (ACL SCMContact (CLFull contactConnRequest)) + s `decodesSuccessfully` () + s `encodesAs` s + it "parses simplex:/invitation#… as CTLink" $ do + let s = strEncode (ACL SCMInvitation (CLFull invConnRequest)) + s `decodesSuccessfully` () + + describe "rejects ambiguous bare input at this layer" $ do + it "rejects bare 'alice' — no @, no #, no simplex:/name prefix" $ + strDecode @ConnectTarget "alice" `shouldSatisfy` isLeft + it "rejects empty input" $ + strDecode @ConnectTarget "" `shouldSatisfy` isLeft + it "rejects whitespace input" $ + strDecode @ConnectTarget " " `shouldSatisfy` isLeft + + describe "JSON shape mirrors AConnectionLink (plain string, not tagged sum)" $ do + it "encodes @alice.simplex as a JSON string" $ + case strDecode @ConnectTarget "@alice.simplex" of + Right ct -> J.toJSON ct `shouldBe` J.String "simplex:/name@alice.simplex" + Left e -> expectationFailure $ "strDecode failed: " <> e + it "parses JSON string back to ConnectTarget" $ + J.eitherDecode @ConnectTarget "\"@alice.simplex\"" + `shouldSatisfy` either (const False) (const True) + where + encodesAs input canonical = + (strEncode <$> strDecode @ConnectTarget input) `shouldBe` Right canonical + decodesSuccessfully s () = + strDecode @ConnectTarget s `shouldSatisfy` either (const False) (const True) + isLeft = either (const True) (const False) diff --git a/tests/Test.hs b/tests/Test.hs index 84718a9fc..b0cf34724 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -8,6 +8,7 @@ import Control.Concurrent (threadDelay) import qualified Control.Exception as E import Control.Logger.Simple import CoreTests.BatchingTests +import CoreTests.ConnectTargetTests import CoreTests.CryptoFileTests import CoreTests.CryptoTests import CoreTests.EncodingTests @@ -83,6 +84,7 @@ main = do $ do describe "Core tests" $ do describe "Batching tests" batchingTests + describe "ConnectTarget tests" connectTargetTests describe "Encoding tests" encodingTests describe "Version range" versionRangeTests describe "Encryption tests" cryptoTests From 3f58f096bdfb73fa049422ae369703c812167b10 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 3 Jun 2026 14:12:20 +0000 Subject: [PATCH 02/15] agent: tidy ConnectTarget tests Three cosmetic cleanups flagged in code review: - Drop the vestigial () placeholder on decodesSuccessfully; use a prefix call instead of operator style. - Use Data.Either.isLeft instead of a local one-liner. - Add a symmetric CTLink JSON assertion to pin both branches of the wire shape, not just CTName. --- tests/CoreTests/ConnectTargetTests.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/tests/CoreTests/ConnectTargetTests.hs b/tests/CoreTests/ConnectTargetTests.hs index 86506584c..e78e70d86 100644 --- a/tests/CoreTests/ConnectTargetTests.hs +++ b/tests/CoreTests/ConnectTargetTests.hs @@ -5,6 +5,8 @@ module CoreTests.ConnectTargetTests where import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) import qualified Data.Aeson as J +import Data.Either (isLeft) +import Data.Text.Encoding (decodeUtf8) import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectTarget (..), ConnectionLink (..), SConnectionMode (..)) import Simplex.Messaging.Encoding.String (strDecode, strEncode) import Test.Hspec hiding (fit, it) @@ -29,11 +31,11 @@ connectTargetTests = describe "ConnectTarget" $ do describe "CTLink (connection link) round-trips" $ do it "parses simplex:/contact#… as CTLink and round-trips" $ do let s = strEncode (ACL SCMContact (CLFull contactConnRequest)) - s `decodesSuccessfully` () + decodesSuccessfully s s `encodesAs` s it "parses simplex:/invitation#… as CTLink" $ do let s = strEncode (ACL SCMInvitation (CLFull invConnRequest)) - s `decodesSuccessfully` () + decodesSuccessfully s describe "rejects ambiguous bare input at this layer" $ do it "rejects bare 'alice' — no @, no #, no simplex:/name prefix" $ @@ -48,12 +50,16 @@ connectTargetTests = describe "ConnectTarget" $ do case strDecode @ConnectTarget "@alice.simplex" of Right ct -> J.toJSON ct `shouldBe` J.String "simplex:/name@alice.simplex" Left e -> expectationFailure $ "strDecode failed: " <> e + it "encodes a CTLink as the canonical link JSON string" $ do + let s = strEncode (ACL SCMContact (CLFull contactConnRequest)) + case strDecode @ConnectTarget s of + Right ct -> J.toJSON ct `shouldBe` J.String (decodeUtf8 s) + Left e -> expectationFailure $ "strDecode failed: " <> e it "parses JSON string back to ConnectTarget" $ J.eitherDecode @ConnectTarget "\"@alice.simplex\"" `shouldSatisfy` either (const False) (const True) where encodesAs input canonical = (strEncode <$> strDecode @ConnectTarget input) `shouldBe` Right canonical - decodesSuccessfully s () = + decodesSuccessfully s = strDecode @ConnectTarget s `shouldSatisfy` either (const False) (const True) - isLeft = either (const True) (const False) From c0d8ac9481c47e26bd09abf1ba4436517fed9555 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 3 Jun 2026 16:22:12 +0000 Subject: [PATCH 03/15] agent: FromField/ToField for SimplexNameInfo MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Stored as TEXT via decodeLatin1 . strEncode and decoded via fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 — the established pattern for typed TEXT columns in this codebase (see RcvSwitchStatus, SndSwitchStatus, RatchetSyncState at Agent/Protocol.hs:614-647). Lets simplex-chat carry the type directly in DB tuples without a per-call decode helper. --- src/Simplex/Messaging/SimplexName.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index 62973727a..abfb28efd 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -27,10 +27,11 @@ import Data.Char (isDigit) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) -import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) data SimplexNameInfo = SimplexNameInfo { nameType :: SimplexNameType, @@ -123,6 +124,10 @@ shortNameInfoStr = \case NTPublicGroup -> "#" NTContact -> "@" +instance ToField SimplexNameInfo where toField = toField . decodeLatin1 . strEncode + +instance FromField SimplexNameInfo where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) From 83c118fa2c30c2c77b0303affb0f50942229b444 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 3 Jun 2026 18:59:21 +0000 Subject: [PATCH 04/15] agent: drop unused FromField SimplexNameInfo MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The instance landed in the previous commit alongside ToField but has zero consumers in either repo — chat-side row decoders use the soft-degradation `decodeSimplexName` helper at the tuple level, never this instance. `fromTextField_` raises ConversionFailed on parse failure, which doesn't compose with the chat policy. Keep ToField (used by parameter binding in name lookups). Leave a comment explaining why FromField is absent so a future contributor doesn't reintroduce it without thinking about the decode policy. --- src/Simplex/Messaging/SimplexName.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index abfb28efd..8f8fd9ac4 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -28,10 +28,10 @@ import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) +import Simplex.Messaging.Agent.Store.DB (ToField (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) -import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) data SimplexNameInfo = SimplexNameInfo { nameType :: SimplexNameType, @@ -124,10 +124,13 @@ shortNameInfoStr = \case NTPublicGroup -> "#" NTContact -> "@" +-- | Stored as TEXT. The matching `FromField` instance is intentionally not +-- defined: existing consumers want soft-decode semantics (parse failure +-- degrades to `Nothing` rather than failing the row), which doesn't +-- compose with `fromTextField_`. Add a `FromField` instance here only +-- when a consumer wants the row-fail behaviour and document the divide. instance ToField SimplexNameInfo where toField = toField . decodeLatin1 . strEncode -instance FromField SimplexNameInfo where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) From 90de60eeb46f8856af87f11b934b49546363a2fa Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 4 Jun 2026 13:28:31 +0000 Subject: [PATCH 05/15] namespace: add resolveSimplexName agent API (RSLV) Client.hs: proxyResolveName wraps proxySMPCommand for RSLV/NAME. Agent/Client.hs: resolveName routes via sendOrProxySMPCommand; direct path throws TENoServerAuth since SResolver has no direct client role. Agent.hs: resolveSimplexName takes resolver SMPServer + SimplexNameDomain, looks up the TLD contract (mirrors hardcodedTldRegistries server-side), and forwards the RSLV. TLDWeb is intentionally unmapped. --- src/Simplex/Messaging/Agent.hs | 28 +++++++++++++++++++++++++++ src/Simplex/Messaging/Agent/Client.hs | 14 ++++++++++++++ src/Simplex/Messaging/Client.hs | 12 ++++++++++++ 3 files changed, 54 insertions(+) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bd77b892a..a297a3ed0 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -65,6 +65,7 @@ module Simplex.Messaging.Agent setConnShortLink, deleteConnShortLink, getConnShortLink, + resolveSimplexName, getConnLinkPrivKey, deleteLocalInvShortLink, changeConnectionUser, @@ -216,6 +217,8 @@ import Simplex.Messaging.Protocol ErrorType (AUTH), MsgBody, MsgFlags (..), + NameOwner, + NameRecord, NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), @@ -233,6 +236,7 @@ import Simplex.Messaging.Protocol SubscriptionMode (..), UserProtocol, VersionSMPC, + mkNameOwner, senderCanSecure, ) import qualified Simplex.Messaging.Protocol as SMP @@ -440,6 +444,13 @@ getConnShortLink :: AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink getConnShortLink c = withAgentEnv c .:. getConnShortLink' c {-# INLINE getConnShortLink #-} +-- | Resolve a SimpleX name via the configured resolver SMP server (PFWD RSLV). +-- The TLD->contract whitelist lives in the agent so chat clients only need to +-- pass the resolver address and the parsed domain. +resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexNameDomain -> AE NameRecord +resolveSimplexName c = withAgentEnv c .:: resolveSimplexName' c +{-# INLINE resolveSimplexName #-} + getConnLinkPrivKey :: AgentClient -> ConnId -> AE (Maybe C.PrivateKeyEd25519) getConnLinkPrivKey c = withAgentEnv c . getConnLinkPrivKey' c {-# INLINE getConnLinkPrivKey #-} @@ -1182,6 +1193,23 @@ getConnShortLink' c nm userId = \case deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId +-- | TLD -> SNRC contract whitelist. Must match the server-side +-- `hardcodedTldRegistries` in `Server/Main.hs`: the resolver verifies the +-- client-supplied contract against its own TLD config and replies AUTH on +-- mismatch. TLDWeb is intentionally unmapped (no SimpleX contract). +tldNameContract :: SimplexTLD -> Maybe NameOwner +tldNameContract = \case + TLDSimplex -> mkOwnerStub '\x11' + TLDTesting -> mkOwnerStub '\x22' + TLDWeb -> Nothing + where + mkOwnerStub c = eitherToMaybe $ mkNameOwner (B.replicate 20 c) + +resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexNameDomain -> AM NameRecord +resolveSimplexName' c nm userId resolverSrv domain = case tldNameContract (nameTLD domain) of + Nothing -> throwE $ INTERNAL "resolveSimplexName: no resolver contract for TLD" + Just contract -> resolveName c nm userId resolverSrv contract (fullDomainName domain) + changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do SomeConn _ conn <- withStore c (`getConn` connId) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d33794006..5bc5b88ae 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -68,6 +68,7 @@ module Simplex.Messaging.Agent.Client deleteQueueLink, secureGetQueueLink, getQueueLink, + resolveName, enableQueueNotifications, EnableQueueNtfReq (..), enableQueuesNtfs, @@ -267,6 +268,8 @@ import Simplex.Messaging.Protocol NetworkError (..), MsgFlags (..), MsgId, + NameOwner, + NameRecord, NtfServer, NtfServerWithAuth, ProtoServer, @@ -1990,6 +1993,17 @@ getQueueLink c nm userId server lnkId = getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId getDirectly smp = getSMPQueueLink smp nm lnkId +-- | RSLV is proxy-only at the protocol level (SResolver has no direct client +-- role), so the direct fallback used by sendOrProxySMPCommand cannot succeed. +-- Surface a transport error if the network config (SPMNever, or no proxy +-- available for the destination) routes us to the direct path. +resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> NameOwner -> Text -> AM NameRecord +resolveName c nm userId server contract name = + snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly + where + resolveViaProxy smp proxySess = proxyResolveName smp nm proxySess contract name + resolveDirectly _ = throwE $ PCETransportError TENoServerAuth + enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c NRMBackground rq "NKEY " $ \smp -> diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 67b31de18..50f47d735 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -73,6 +73,7 @@ module Simplex.Messaging.Client deleteSMPQueues, connectSMPProxiedRelay, proxySMPMessage, + proxyResolveName, forwardSMPTransmission, getSMPQueueInfo, sendProtocolCommand, @@ -1046,6 +1047,17 @@ sendSMPMessage c nm spKey sId flags msg = proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg) +-- | Resolve a public-namespace name via PFWD. RSLV is forwarded-only on the +-- server, so this is the only client-side path. Mirrors `proxySMPMessage`'s +-- shape; routes through `proxySMPCommand` and pattern-matches the expected +-- NAME response. +proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> NameOwner -> Text -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord) +proxyResolveName c nm proxiedRelay contract name = + proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV RslvRequest {name, contract}) >>= \case + Right (NAME nr) -> pure $ Right nr + Right r -> throwE $ unexpectedResponse r + Left e -> pure $ Left e + -- | Acknowledge message delivery (server deletes the message). -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery From ecd89cf1c5b868c5a7c7f2f53f90b29d22d2c499 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 09:41:44 +0000 Subject: [PATCH 06/15] namespace: accept RSLV direct (non-forwarded) in addition to PFWD RSLV was previously rejected by the server unless forwarded via PFWD, making the agent's direct fallback unreachable. Relax the server-side guard so RSLV is accepted both forwarded (preferred - hides client IP from the resolver) and direct (faster, exposes client IP). Mode choice is delegated to the client and the operator network config. - Server: drop the forwarded-only check on SResolver in verifyQueueTransmission. - Protocol: give SResolver a client role (SRMessaging) so SMPClient can connect in the Resolver role. checkRole accepts this because RSLV clients have no service binding (falls through to True). - Client: add directResolveName mirroring proxyResolveName via sendProtocolCommand with no auth and no entity (RSLV is noAuthCmd). - Agent: wire the direct path through sendOrProxySMPCommand so the PFWD-or-direct selection works the same as other commands. --- src/Simplex/Messaging/Agent/Client.hs | 10 +++++----- src/Simplex/Messaging/Client.hs | 18 ++++++++++++++---- src/Simplex/Messaging/Protocol.hs | 2 +- src/Simplex/Messaging/Server.hs | 8 ++++---- 4 files changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 5bc5b88ae..232705c54 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1993,16 +1993,16 @@ getQueueLink c nm userId server lnkId = getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId getDirectly smp = getSMPQueueLink smp nm lnkId --- | RSLV is proxy-only at the protocol level (SResolver has no direct client --- role), so the direct fallback used by sendOrProxySMPCommand cannot succeed. --- Surface a transport error if the network config (SPMNever, or no proxy --- available for the destination) routes us to the direct path. +-- | Resolve a public-namespace name. Prefers PFWD (hides client IP from the +-- resolver) and falls back to a direct send when the proxy is unavailable +-- (faster but exposes the client IP). Mode selection is delegated to +-- `sendOrProxySMPCommand`, which honours the network config (SPMNever etc.). resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> NameOwner -> Text -> AM NameRecord resolveName c nm userId server contract name = snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly where resolveViaProxy smp proxySess = proxyResolveName smp nm proxySess contract name - resolveDirectly _ = throwE $ PCETransportError TENoServerAuth + resolveDirectly smp = directResolveName smp nm contract name enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 50f47d735..9fb525553 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -74,6 +74,7 @@ module Simplex.Messaging.Client connectSMPProxiedRelay, proxySMPMessage, proxyResolveName, + directResolveName, forwardSMPTransmission, getSMPQueueInfo, sendProtocolCommand, @@ -1047,10 +1048,9 @@ sendSMPMessage c nm spKey sId flags msg = proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg) --- | Resolve a public-namespace name via PFWD. RSLV is forwarded-only on the --- server, so this is the only client-side path. Mirrors `proxySMPMessage`'s --- shape; routes through `proxySMPCommand` and pattern-matches the expected --- NAME response. +-- | Resolve a public-namespace name via PFWD. Preferred path - hides the +-- client IP from the resolver. Mirrors `proxySMPMessage`'s shape; routes +-- through `proxySMPCommand` and pattern-matches the expected NAME response. proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> NameOwner -> Text -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord) proxyResolveName c nm proxiedRelay contract name = proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV RslvRequest {name, contract}) >>= \case @@ -1058,6 +1058,16 @@ proxyResolveName c nm proxiedRelay contract name = Right r -> throwE $ unexpectedResponse r Left e -> pure $ Left e +-- | Direct (non-PFWD) name resolution. Exposes the client IP to the resolver; +-- callers that want anonymity should use `proxyResolveName` via the standard +-- proxy fallback in the agent. RSLV requires no entity ID or authorization +-- (see `noAuthCmd` in Protocol.hs). +directResolveName :: SMPClient -> NetworkRequestMode -> NameOwner -> Text -> ExceptT SMPClientError IO NameRecord +directResolveName c nm contract name = + sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV RslvRequest {name, contract})) >>= \case + NAME nr -> pure nr + r -> throwE $ unexpectedResponse r + -- | Acknowledge message delivery (server deletes the message). -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index ebe3506ba..90122a269 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -488,7 +488,7 @@ partyClientRole = \case SSenderLink -> Just SRMessaging SProxiedClient -> Just SRMessaging SProxyService -> Just SRProxy - SResolver -> Nothing + SResolver -> Just SRMessaging {-# INLINE partyClientRole #-} partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 4c3447176..fc308fae9 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1250,7 +1250,7 @@ verifyLoadedQueue forwarded service thAuth t@(tAuth, authorized, (corrId, _, _)) Left e -> VRFailed e verifyQueueTransmission :: forall s. Bool -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s -verifyQueueTransmission forwarded service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ +verifyQueueTransmission _forwarded service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ | not checkRole = VRFailed $ CMD PROHIBITED | not verifyServiceSig = VRFailed SERVICE | otherwise = vc p cmd @@ -1270,9 +1270,9 @@ verifyQueueTransmission forwarded service thAuth (tAuth, authorized, (corrId, en vc SNotifierService NSUBS {} = verifyServiceCmd vc SProxiedClient _ = VRVerified Nothing vc SProxyService (RFWD _) = VRVerified Nothing - vc SResolver (RSLV _) - | forwarded = VRVerified Nothing - | otherwise = VRFailed $ CMD PROHIBITED + -- RSLV is accepted both forwarded (via PFWD, preferred - hides client IP from resolver) + -- and direct (client->resolver, faster, exposes client IP). Mode is chosen by the client. + vc SResolver (RSLV _) = VRVerified Nothing checkRole = case (service, partyClientRole p) of (Just THClientService {serviceRole}, Just role) -> serviceRole == role _ -> True From 5ee014ddccd11e612fe873a7150ccf78b81a0ad2 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 09:59:15 +0000 Subject: [PATCH 07/15] namespace: reshape NameRecord JSON to align with Python resolver Convergence on the Python resolver shape (PR #1795 `snrc-resolve.py`) so a names router can be backed either by the direct-ETH-RPC resolver or by the Python REST resolver without changing the wire format clients see. Wire-level changes: - Add `nickname`, `website`, `location`, `simplex.contact`, `simplex.channel`, `ETH`, `BTC`, `XMR`, `DOT`, `resolver` (SNRC contract address that produced the record); all but `name`, `owner`, `resolver` are optional. - Drop `displayName` (now `name`), `channelLinks`, `contactLinks`, `adminAddress`, `adminEmail`, `expiry`, `isTest`. - The wire NameRecord no longer carries `expiry`; clients trust the server's filter. Expiry checking moves into `decodeGetRecord`, which now takes a `nowSec :: Int64` argument (the placeholder remains, but the field-layout-aware decoder will apply the filter once it lands). - Testnet status is derived from the queried TLD (`TLDTesting` vs `TLDSimplex`) rather than an in-record flag. Other: - ToJSON/FromJSON are hand-rolled because Aeson TH doesn't accommodate dot-keys (`simplex.contact`) or uppercase coin keys (`ETH`/`BTC`...). - `NameLink` newtype is removed (no longer used internally); per-field byte caps are applied directly in the FromJSON parser. - Update the canonical-encoding spec in protocol/simplex-messaging.md. --- protocol/simplex-messaging.md | 27 +++-- src/Simplex/Messaging/Protocol.hs | 110 +++++++++--------- src/Simplex/Messaging/Server/Names.hs | 23 ++-- .../Messaging/Server/Names/Eth/SNRC.hs | 19 ++- tests/SMPNamesTests.hs | 110 ++++++++++-------- 5 files changed, 152 insertions(+), 137 deletions(-) diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index c73cdaa4b..6623f7159 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -1493,14 +1493,23 @@ name = %s"NAME" SP json-bytes ; json-bytes consumes the remainder of the trans | Field | JSON type | Constraints | |---|---|---| -| `displayName` | string | ≤ 255 bytes UTF-8 | +| `name` | string | ≤ 255 bytes UTF-8 | +| `nickname` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | +| `website` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `location` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `simplex.contact` | string or null | ≤ 1024 bytes UTF-8; same null / absent rules | +| `simplex.channel` | string or null | ≤ 1024 bytes UTF-8; same null / absent rules | +| `ETH` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `BTC` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `XMR` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `DOT` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | | `owner` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes) | -| `channelLinks` | array of strings | each ≤ 1024 bytes UTF-8; combined count of `channelLinks + contactLinks` ≤ 8 | -| `contactLinks` | array of strings | each ≤ 1024 bytes UTF-8; combined count cap shared with `channelLinks` | -| `adminAddress` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | -| `adminEmail` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | -| `expiry` | integer | Int64 Unix seconds, MUST be ≥ 0; `0` means "never expires" | -| `isTest` | boolean | true on testnet deployments | +| `resolver` | string | `"0x"` followed by 40 lowercase hex characters; the SNRC contract address that produced the record | + +The server MUST filter expired records before constructing the response +(returning `ERR AUTH` to the client), so the wire format carries no expiry +field. Testnet-vs-mainnet status is derived from the queried TLD rather than +an in-record flag. Receivers MUST tolerate extra unknown fields (forward-compatibility for future field additions). Adding a required field is a breaking change requiring an @@ -1511,8 +1520,8 @@ producing the same `NameRecord` MUST emit byte-identical JSON: emit object keys in the order listed above, integers without decimal points, no insignificant whitespace. -**Wire-size budget.** A maximal `nameRecord` (8 × 1024-byte links plus -maximal admin / display strings) JSON-encodes to roughly 9 KB, well under the +**Wire-size budget.** A maximal `nameRecord` (two 1024-byte SimpleX links +plus the other capped strings) JSON-encodes to roughly 4 KB, well under the SMP proxied transmission budget of 16224 bytes. ## Transport connection with the SMP router diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 90122a269..42d1174b9 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -168,9 +168,6 @@ module Simplex.Messaging.Protocol NameOwner, mkNameOwner, unNameOwner, - NameLink, - mkNameLink, - unNameLink, MsgFlags (..), initialSMPClientVersion, currentSMPClientVersion, @@ -774,80 +771,79 @@ instance J.FromJSON RslvRequest where contract <- o J..: "contract" pure RslvRequest {name, contract} --- | A name-record link (channel or contact). Bare constructor not exported; --- use `mkNameLink` to enforce the ≤1024-byte UTF-8 invariant. -newtype NameLink = NameLink Text - deriving (Eq, Show) - -mkNameLink :: Text -> Either String NameLink -mkNameLink t - | B.length (encodeUtf8 t) <= 1024 = Right (NameLink t) - | otherwise = Left "NameLink too long" - -unNameLink :: NameLink -> Text -unNameLink (NameLink t) = t -{-# INLINE unNameLink #-} - -instance J.ToJSON NameLink where - toJSON (NameLink t) = J.toJSON t - -instance J.FromJSON NameLink where - parseJSON = J.withText "NameLink" (either fail pure . mkNameLink) - -- | Resolved name record returned by the names role. -- Wire format is JSON — change requires an SMP version bump. +-- JSON keys match the Python resolver (PR #1795 `snrc-resolve.py`) so the +-- same server can be backed by either the direct-ETH-RPC resolver or the +-- Python REST resolver without changing the wire format clients see. data NameRecord = NameRecord - { nrDisplayName :: Text, + { nrName :: Text, + nrNickname :: Maybe Text, + nrWebsite :: Maybe Text, + nrLocation :: Maybe Text, + nrSimplexContact :: Maybe Text, + nrSimplexChannel :: Maybe Text, + nrEth :: Maybe Text, + nrBtc :: Maybe Text, + nrXmr :: Maybe Text, + nrDot :: Maybe Text, nrOwner :: NameOwner, - nrChannelLinks :: [NameLink], - nrContactLinks :: [NameLink], - nrAdminAddress :: Maybe Text, - nrAdminEmail :: Maybe Text, - nrExpiry :: Int64, -- Unix seconds, ≥ 0 - nrIsTest :: Bool + nrResolver :: NameOwner -- SNRC contract address that produced the record } deriving (Eq, Show) +-- Hand-rolled JSON instances: dot-keys ("simplex.contact", "simplex.channel") +-- and uppercase coin keys ("ETH", "BTC", "XMR", "DOT") fall outside Aeson TH's +-- field-label conventions. instance J.ToJSON NameRecord where - toJSON NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} = + toJSON NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} = J.object - [ "displayName" J..= nrDisplayName, + [ "name" J..= nrName, + "nickname" J..= nrNickname, + "website" J..= nrWebsite, + "location" J..= nrLocation, + "simplex.contact" J..= nrSimplexContact, + "simplex.channel" J..= nrSimplexChannel, + "ETH" J..= nrEth, + "BTC" J..= nrBtc, + "XMR" J..= nrXmr, + "DOT" J..= nrDot, "owner" J..= nrOwner, - "channelLinks" J..= nrChannelLinks, - "contactLinks" J..= nrContactLinks, - "adminAddress" J..= nrAdminAddress, - "adminEmail" J..= nrAdminEmail, - "expiry" J..= nrExpiry, - "isTest" J..= nrIsTest + "resolver" J..= nrResolver ] -- explicit toEncoding to preserve the spec-documented key order; the default -- routes through Value/KeyMap and re-emits keys alphabetically, breaking the -- "two routers MUST emit byte-identical JSON" requirement. - toEncoding NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} = + toEncoding NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} = J.pairs $ - "displayName" J..= nrDisplayName + "name" J..= nrName + <> "nickname" J..= nrNickname + <> "website" J..= nrWebsite + <> "location" J..= nrLocation + <> "simplex.contact" J..= nrSimplexContact + <> "simplex.channel" J..= nrSimplexChannel + <> "ETH" J..= nrEth + <> "BTC" J..= nrBtc + <> "XMR" J..= nrXmr + <> "DOT" J..= nrDot <> "owner" J..= nrOwner - <> "channelLinks" J..= nrChannelLinks - <> "contactLinks" J..= nrContactLinks - <> "adminAddress" J..= nrAdminAddress - <> "adminEmail" J..= nrAdminEmail - <> "expiry" J..= nrExpiry - <> "isTest" J..= nrIsTest + <> "resolver" J..= nrResolver instance J.FromJSON NameRecord where parseJSON = J.withObject "NameRecord" $ \o -> do - nrDisplayName <- o J..: "displayName" >>= capUtf8 "displayName" 255 + nrName <- o J..: "name" >>= capUtf8 "name" 255 + nrNickname <- o J..:? "nickname" >>= traverse (capUtf8 "nickname" 255) + nrWebsite <- o J..:? "website" >>= traverse (capUtf8 "website" 255) + nrLocation <- o J..:? "location" >>= traverse (capUtf8 "location" 255) + nrSimplexContact <- o J..:? "simplex.contact" >>= traverse (capUtf8 "simplex.contact" 1024) + nrSimplexChannel <- o J..:? "simplex.channel" >>= traverse (capUtf8 "simplex.channel" 1024) + nrEth <- o J..:? "ETH" >>= traverse (capUtf8 "ETH" 255) + nrBtc <- o J..:? "BTC" >>= traverse (capUtf8 "BTC" 255) + nrXmr <- o J..:? "XMR" >>= traverse (capUtf8 "XMR" 255) + nrDot <- o J..:? "DOT" >>= traverse (capUtf8 "DOT" 255) nrOwner <- o J..: "owner" - nrChannelLinks <- o J..: "channelLinks" - nrContactLinks <- o J..: "contactLinks" - when (length nrChannelLinks + length nrContactLinks > 8) $ - fail "combined channelLinks + contactLinks > 8" - nrAdminAddress <- o J..:? "adminAddress" >>= traverse (capUtf8 "adminAddress" 255) - nrAdminEmail <- o J..:? "adminEmail" >>= traverse (capUtf8 "adminEmail" 255) - nrExpiry <- o J..: "expiry" - when (nrExpiry < 0) $ fail "expiry must be non-negative" - nrIsTest <- o J..: "isTest" - pure NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} + nrResolver <- o J..: "resolver" + pure NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} where capUtf8 fld lim t | B.length (encodeUtf8 t) <= lim = pure t diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index c1aeef489..9a94cf634 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -41,7 +41,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock.POSIX (getPOSIXTime) import Simplex.Messaging.Encoding.String (strDecode) import Simplex.Messaging.Util (eitherToMaybe) -import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), RslvRequest (..), unNameOwner) +import Simplex.Messaging.Protocol (NameOwner, NameRecord, RslvRequest (..), unNameOwner) import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) import Simplex.Messaging.Server.Names.Eth.SNRC (decodeAddress, decodeGetRecord, encodeGetRecord, isZeroOwner, namehash) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..), fullDomainName) @@ -166,12 +166,13 @@ resolveName env contract d = do pure (Left EthHttpErr) fetch :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) -fetch env@NamesEnv {ethCall} contract d = +fetch env@NamesEnv {ethCall} contract d = do + nowSec <- floor <$> getPOSIXTime ethCall (unNameOwner contract) (encodeGetRecord (namehash (encodeUtf8 (fullDomainName d)))) >>= \case Left e -> pure (Left (mapEthRpcError e)) - Right ret -> case decodeGetRecord ret of + Right ret -> case decodeGetRecord nowSec ret of Right Nothing -> notFoundWithPlaceholderWarn ret - Right (Just rec) -> checkExpiry rec + Right (Just rec) -> pure (Right rec) Left _ -> pure (Left EthDecodeErr) where -- decodeGetRecord is currently a placeholder: it returns Right Nothing @@ -179,21 +180,13 @@ fetch env@NamesEnv {ethCall} contract d = -- with real data but no ABI decoder yet". Inspect the owner slot -- directly to distinguish, and surface the latter once per process so -- an operator who enables [NAMES] against a working SNRC contract sees - -- the resolver is functionally stubbed. + -- the resolver is functionally stubbed. Expired records are filtered + -- inside the decoder (using the `nowSec` argument) so the wire + -- NameRecord never carries an expiry field. notFoundWithPlaceholderWarn ret = do forM_ (eitherToMaybe (decodeAddress 32 ret)) $ \owner -> unless (isZeroOwner owner) (warnPlaceholderOnce env) pure (Left NotFound) - -- Defense in depth: the SNRC contract should already return the - -- zero-owner sentinel for expired records, but a buggy / pre-upgrade - -- contract might not. nrExpiry == 0 means "never expires" (reserved - -- names); any positive expiry in the past is treated as NotFound. - checkExpiry rec = do - nowSec <- floor <$> getPOSIXTime - pure $ - if nrExpiry rec /= 0 && nrExpiry rec < nowSec - then Left NotFound - else Right rec warnPlaceholderOnce :: NamesEnv -> IO () warnPlaceholderOnce NamesEnv {placeholderWarned} = do diff --git a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs index 2e645fa60..b1ddbea30 100644 --- a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs +++ b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs @@ -170,17 +170,24 @@ decodeStringArray depth headEnd off cntCap byteCap buf -- | Decode the ABI-encoded return value of getRecord(bytes32) into a NameRecord. -- Zero-owner (0x000...000) is reported as Right Nothing so the caller maps it --- to NotFound (ENS-style sentinel). +-- to NotFound (ENS-style sentinel). Records whose on-chain expiry is in the +-- past are also reported as Right Nothing — clients trust the server's filter +-- and the wire NameRecord carries no expiry field. +-- +-- `nowSec` is the current Unix time the caller wants the expiry compared +-- against. Pass `0` to disable the expiry check. -- -- PLACEHOLDER: returns Right Nothing for any non-zero owner until the Part 1 -- SNRC contract ABI is finalised. All ABI primitives above are production-ready; --- only the field-layout-aware composition is pending. -decodeGetRecord :: ByteString -> Either AbiError (Maybe NameRecord) -decodeGetRecord buf +-- only the field-layout-aware composition (and the expiry slot read) is +-- pending. +decodeGetRecord :: Int64 -> ByteString -> Either AbiError (Maybe NameRecord) +decodeGetRecord _nowSec buf | B.length buf < 32 * 8 = Left AbiTruncated -- Both arms return Nothing today: the zero-owner branch is the real ENS-style - -- NotFound sentinel; the non-zero branch is the SNRC-ABI placeholder. They - -- separate once the field-layout decoder lands. + -- NotFound sentinel; the non-zero branch is the SNRC-ABI placeholder (which + -- will also apply the `_nowSec` expiry filter once the field layout lands). + -- They separate once the field-layout decoder ships. | otherwise = Nothing <$ decodeAddress 32 buf isZeroOwner :: NameOwner -> Bool diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 412b6fa2b..919db2100 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -13,18 +13,14 @@ import Data.Either (isLeft, isRight) import Data.Foldable (for_) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (sort) -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LB import Simplex.Messaging.Protocol - ( NameLink, - NameOwner, + ( NameOwner, NameRecord (..), RslvRequest (..), - mkNameLink, mkNameOwner, - unNameLink, unNameOwner, ) import Simplex.Messaging.Server.Names @@ -72,15 +68,12 @@ namehashEth = "\x93\xcd\xeb\x70\x8b\x75\x45\xdc\x66\x8e\xb9\x28\x01\x76\x16\x9d\ twentyOnes :: ByteString twentyOnes = B.replicate 20 '\x01' --- | Test-only constructors that crash on the smart-ctor's Left. Used for +-- | Test-only constructor that crashes on the smart-ctor's Left. Used for -- fixtures where we know the input satisfies the invariant; production code --- always goes through `mkNameOwner` / `mkNameLink`. +-- always goes through `mkNameOwner`. unsafeOwner :: ByteString -> NameOwner unsafeOwner = either error id . mkNameOwner -unsafeLink :: Text -> NameLink -unsafeLink = either error id . mkNameLink - addr1, addr2, addr3 :: NameOwner addr1 = unsafeOwner twentyOnes addr2 = unsafeOwner (B.replicate 20 '\x02') @@ -100,20 +93,24 @@ testNamesConfig regs = sampleRecord :: NameRecord sampleRecord = NameRecord - { nrDisplayName = "Alice", + { nrName = "alice.simplex", + nrNickname = Just "Alice", + nrWebsite = Just "https://alice.example", + nrLocation = Just "Earth", + nrSimplexContact = Just "simplex:/contact/abc#xyz", + nrSimplexChannel = Nothing, + nrEth = Just "0x0000000000000000000000000000000000000001", + nrBtc = Nothing, + nrXmr = Nothing, + nrDot = Nothing, nrOwner = unsafeOwner twentyOnes, - nrChannelLinks = [], - nrContactLinks = [unsafeLink "simplex:/contact/abc#xyz"], - nrAdminAddress = Just "simplex:/admin/...", - nrAdminEmail = Just "admin@example.org", - nrExpiry = 1735689600, - nrIsTest = False + nrResolver = unsafeOwner (B.replicate 20 '\x02') } smpNamesTests :: Spec smpNamesTests = do describe "NameRecord encoding (Protocol)" nameRecordEncodingSpec - describe "Smart constructors (NameOwner, NameLink)" smartCtorsSpec + describe "Smart constructors (NameOwner)" smartCtorsSpec describe "Keccak-256 and namehash" namehashSpec describe "ABI primitive bounds" abiBoundsSpec describe "decodeGetRecord (zero-owner sentinel)" zeroOwnerSpec @@ -125,26 +122,43 @@ nameRecordEncodingSpec = do it "round-trips JSON encode / decode" $ J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord)) `shouldBe` Right sampleRecord - it "emits keys in spec-documented order (displayName, owner, channelLinks, contactLinks, adminAddress, adminEmail, expiry, isTest)" $ do + it "emits keys in spec-documented order (Python resolver shape)" $ do -- Default toEncoding routes through Value/KeyMap and re-emits keys -- alphabetically; spec requires byte-identical canonical encoding. let bytes = LB.toStrict (J.encode sampleRecord) offset k = B.length (fst (B.breakSubstring k bytes)) - offsets = map offset ["displayName", "owner", "channelLinks", "contactLinks", "adminAddress", "adminEmail", "expiry", "isTest"] + offsets = + map + offset + [ "name", + "nickname", + "website", + "location", + "simplex.contact", + "simplex.channel", + "ETH", + "BTC", + "XMR", + "DOT", + "owner", + "resolver" + ] offsets `shouldBe` sort offsets - it "rejects negative expiry" $ do - let badBytes = LB.toStrict (J.encode sampleRecord {nrExpiry = -1}) - (J.eitherDecodeStrict badBytes :: Either String NameRecord) `shouldSatisfy` isLeft + it "tolerates absent optional keys (forward-compat with sparse Python output)" $ do + let minimal = + "{\"name\":\"a.simplex\"," + <> "\"owner\":\"0x0101010101010101010101010101010101010101\"," + <> "\"resolver\":\"0x0202020202020202020202020202020202020202\"}" + (J.eitherDecodeStrict minimal :: Either String NameRecord) `shouldSatisfy` isRight - it "enforces combined channel+contact list cap of 8" $ do - let nineLinks = map (\i -> unsafeLink ("simplex:/contact/" <> T.pack (show (i :: Int)))) [0 .. 8] - overflow = sampleRecord {nrChannelLinks = nineLinks, nrContactLinks = []} - bytes = LB.toStrict (J.encode overflow) + it "rejects nrName > 255 bytes UTF-8" $ do + let oversize = sampleRecord {nrName = T.replicate 256 "x"} + bytes = LB.toStrict (J.encode oversize) (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft - it "rejects nrDisplayName > 255 bytes UTF-8" $ do - let oversize = sampleRecord {nrDisplayName = T.replicate 256 "x"} + it "rejects simplex.contact > 1024 bytes UTF-8" $ do + let oversize = sampleRecord {nrSimplexContact = Just (T.replicate 1025 "x")} bytes = LB.toStrict (J.encode oversize) (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft @@ -154,14 +168,18 @@ nameRecordEncodingSpec = do (J.eitherDecodeStrict (json "0X") :: Either String NameOwner) `shouldSatisfy` isRight it "encodes within the proxied transmission budget" $ do - let huge = unsafeLink (T.replicate 1024 "x") - wide = + let wide = sampleRecord - { nrChannelLinks = replicate 4 huge, - nrContactLinks = replicate 4 huge, - nrDisplayName = T.replicate 255 "n", - nrAdminAddress = Just (T.replicate 255 "a"), - nrAdminEmail = Just (T.replicate 255 "e") + { nrName = T.replicate 255 "n", + nrNickname = Just (T.replicate 255 "k"), + nrWebsite = Just (T.replicate 255 "w"), + nrLocation = Just (T.replicate 255 "l"), + nrSimplexContact = Just (T.replicate 1024 "x"), + nrSimplexChannel = Just (T.replicate 1024 "y"), + nrEth = Just (T.replicate 255 "e"), + nrBtc = Just (T.replicate 255 "b"), + nrXmr = Just (T.replicate 255 "m"), + nrDot = Just (T.replicate 255 "d") } LB.length (J.encode wide) < 16224 `shouldBe` True @@ -172,18 +190,10 @@ smartCtorsSpec = do mkNameOwner (B.replicate 19 '\x01') `shouldSatisfy` isLeft mkNameOwner (B.replicate 21 '\x01') `shouldSatisfy` isLeft - it "mkNameLink rejects >1024 UTF-8 bytes" $ do - mkNameLink (T.replicate 1024 "x") `shouldSatisfy` isRight - mkNameLink (T.replicate 1025 "x") `shouldSatisfy` isLeft - -- multibyte UTF-8 counted in bytes, not chars: 600 × 3 = 1800 bytes - mkNameLink (T.replicate 600 "\x4e2d") `shouldSatisfy` isLeft - - it "unNameLink / unNameOwner round-trip the smart ctors" $ do - case (mkNameOwner twentyOnes, mkNameLink "abc") of - (Right o, Right l) -> do - unNameOwner o `shouldBe` twentyOnes - unNameLink l `shouldBe` "abc" - _ -> expectationFailure "smart ctors failed" + it "unNameOwner round-trips mkNameOwner" $ + case mkNameOwner twentyOnes of + Right o -> unNameOwner o `shouldBe` twentyOnes + Left e -> expectationFailure ("mkNameOwner failed: " <> e) namehashSpec :: Spec namehashSpec = do @@ -265,11 +275,11 @@ zeroOwnerSpec = do it "decodeGetRecord returns Nothing for zero-owner buffer" $ do -- 8 slots × 32 bytes; owner at slot 1 (offset 32) is all-zero by construction let buf = B.replicate (32 * 8) '\NUL' - decodeGetRecord buf `shouldBe` Right Nothing + decodeGetRecord 0 buf `shouldBe` Right Nothing it "decodeGetRecord fails on truncated buffer" $ do let tiny = B.replicate 31 '\NUL' - decodeGetRecord tiny `shouldBe` Left AbiTruncated + decodeGetRecord 0 tiny `shouldBe` Left AbiTruncated tldWhitelistSpec :: Spec tldWhitelistSpec = do From 8044555a3f477695058f56f6a3aa732f05ffdfaf Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 10:24:42 +0000 Subject: [PATCH 08/15] namespace: lowercase bare-name domain (fix #PRIVACY vs #privacy mismatch) --- src/Simplex/Messaging/SimplexName.hs | 2 +- tests/CoreTests/ConnectTargetTests.hs | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index 8f8fd9ac4..f02ced0bd 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -88,7 +88,7 @@ instance StrEncoding SimplexNameInfo where infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName) infoP NTContact = SimplexNameInfo NTContact <$> strP bareName = parseBare . safeDecodeUtf8 <$?> boundedNonSpace - parseBare s = (\name -> SimplexNameDomain TLDSimplex name []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s + parseBare s = (\name -> SimplexNameDomain TLDSimplex (T.toLower name) []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s instance StrEncoding SimplexNameDomain where strEncode = encodeUtf8 . fullDomainName diff --git a/tests/CoreTests/ConnectTargetTests.hs b/tests/CoreTests/ConnectTargetTests.hs index e78e70d86..a068c6abf 100644 --- a/tests/CoreTests/ConnectTargetTests.hs +++ b/tests/CoreTests/ConnectTargetTests.hs @@ -23,6 +23,8 @@ connectTargetTests = describe "ConnectTarget" $ do "#privacy.simplex" `encodesAs` "simplex:/name#privacy.simplex" it "#support.acme.simplex preserves subdomain" $ "#support.acme.simplex" `encodesAs` "simplex:/name#support.acme.simplex" + it "#PRIVACY (bare uppercase) lowercases to match #privacy" $ + strDecode @ConnectTarget "#PRIVACY" `shouldBe` strDecode @ConnectTarget "#privacy" it "simplex:/name@alice.simplex round-trips" $ "simplex:/name@alice.simplex" `encodesAs` "simplex:/name@alice.simplex" it "simplex:/name#privacy.simplex round-trips" $ From 9f790078ae87338add74eb9c6de99215380f2b13 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 10:36:49 +0000 Subject: [PATCH 09/15] namespace: drop unused forwarded param from verify chain --- src/Simplex/Messaging/Server.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index fc308fae9..ed9d93f60 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1157,8 +1157,8 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, updateBatchStats stats cmd -- even if nothing is verified let queueId (_, _, (_, qId, _)) = qId qs <- getQueueRecs ms p $ map queueId ts' - zipWithM (\t -> verified stats t . verifyLoadedQueue False service thAuth t) ts' qs - _ -> mapM (\t -> verified stats t =<< verifyTransmission False ms service thAuth t) ts' + zipWithM (\t -> verified stats t . verifyLoadedQueue service thAuth t) ts' qs + _ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts' mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds pure $ errs ++ errs' [] -> pure errs @@ -1238,19 +1238,19 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail -- - the queue or party key do not exist. -- In all cases, the time of the verification should depend only on the provided authorization type, -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. -verifyTransmission :: forall s. MsgStoreClass s => Bool -> s -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> IO (VerificationResult s) -verifyTransmission forwarded ms service thAuth t@(_, _, (_, queueId, Cmd p _)) = case queueParty p of - Just Dict -> verifyLoadedQueue forwarded service thAuth t <$> getQueueRec ms p queueId - Nothing -> pure $ verifyQueueTransmission forwarded service thAuth t Nothing - -verifyLoadedQueue :: Bool -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s -verifyLoadedQueue forwarded service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case - Right q -> verifyQueueTransmission forwarded service thAuth t (Just q) +verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> IO (VerificationResult s) +verifyTransmission ms service thAuth t@(_, _, (_, queueId, Cmd p _)) = case queueParty p of + Just Dict -> verifyLoadedQueue service thAuth t <$> getQueueRec ms p queueId + Nothing -> pure $ verifyQueueTransmission service thAuth t Nothing + +verifyLoadedQueue :: Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s +verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case + Right q -> verifyQueueTransmission service thAuth t (Just q) Left AUTH -> dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH Left e -> VRFailed e -verifyQueueTransmission :: forall s. Bool -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s -verifyQueueTransmission _forwarded service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ +verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s +verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ | not checkRole = VRFailed $ CMD PROHIBITED | not verifyServiceSig = VRFailed SERVICE | otherwise = vc p cmd @@ -2149,7 +2149,7 @@ client rejectOrVerify clntThAuth = \case Left (corrId', entId', e) -> pure $ Left (corrId', entId', ERR e) Right t'@(_, _, t''@(corrId', entId', cmd')) - | allowed -> liftIO $ verified <$> verifyTransmission True ms Nothing clntThAuth t' + | allowed -> liftIO $ verified <$> verifyTransmission ms Nothing clntThAuth t' | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) where allowed = case cmd' of From 0882fef2af0a4c681958a567c28aec616f259b15 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 11:39:56 +0000 Subject: [PATCH 10/15] namespace: ServerTests for direct + forwarded RSLV with mock resolver Adds tests/RSLVTests.hs covering the RSLV pipeline against a running SMP server with a stub ethCall injected via newNamesEnvWith. The production decodeGetRecord is a placeholder (returns Right Nothing for any non- malformed buffer), so the success path is marked pendingWith until the SNRC ABI codec ships; everything else - direct vs PFWD acceptance, contract mismatch, unknown TLD, backend NotFound, transport error mapping, and rslvDisabled - exercises the wiring end-to-end. Adds a minimal test seam: newEnvWithNames / runSMPServerBlockingWithNames that accept a pre-built NamesEnv and skip the real pingEndpoint probe. The production newEnv / runSMPServerBlocking delegate through with namesOverride = Nothing, so behaviour is unchanged outside tests. 7 active tests pass, 1 pending. The existing 42 SMPNamesTests still pass. --- simplexmq.cabal | 1 + src/Simplex/Messaging/Server.hs | 10 +- src/Simplex/Messaging/Server/Env/STM.hs | 40 ++-- tests/RSLVTests.hs | 271 ++++++++++++++++++++++++ tests/SMPClient.hs | 13 +- tests/Test.hs | 2 + 6 files changed, 320 insertions(+), 17 deletions(-) create mode 100644 tests/RSLVTests.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 6ef8abdb8..654b77f7d 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -513,6 +513,7 @@ test-suite simplexmq-test CoreTests.VersionRangeTests FileDescriptionTests RemoteControl + RSLVTests ServerTests SMPAgentClient SMPClient diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index ed9d93f60..9dfc89764 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -32,6 +32,7 @@ module Simplex.Messaging.Server ( runSMPServer, runSMPServerBlocking, + runSMPServerBlockingWithNames, controlPortAuth, importMessages, exportMessages, @@ -108,7 +109,7 @@ import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages) -import Simplex.Messaging.Server.Names (ResolveError (..), closeNamesEnv, resolveName, verifyRslv) +import Simplex.Messaging.Server.Names (NamesEnv, ResolveError (..), closeNamesEnv, resolveName, verifyRslv) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -162,6 +163,13 @@ runSMPServer cfg attachHTTP_ = do runSMPServerBlocking :: MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> IO () runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpServer started cfg attachHTTP_) +-- | Test seam: run the server with a pre-built `namesEnv` (typically a stub +-- backed by `newNamesEnvWith`). Production code MUST use `runSMPServerBlocking`, +-- which builds `namesEnv` from `namesConfig` and probes the real RPC endpoint. +runSMPServerBlockingWithNames :: MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> Maybe NamesEnv -> IO () +runSMPServerBlockingWithNames started cfg attachHTTP_ namesOverride = + newEnvWithNames cfg namesOverride >>= runReaderT (smpServer started cfg attachHTTP_) + type M s a = ReaderT (Env s) IO a type AttachHTTP = Socket -> TLS.Context -> IO () diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index a9e9d91ea..8ce51c106 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -76,6 +76,7 @@ module Simplex.Messaging.Server.Env.STM noPostgresExit, dbStoreCfg, storeLogFile', + newEnvWithNames, ) where @@ -563,7 +564,14 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig s -> IO (Env s) -newEnv config@ServerConfig {allowSMPProxy, smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} = do +newEnv cfg = newEnvWithNames cfg Nothing + +-- | Test seam: build the server env, but if `namesOverride` is provided, +-- use it as `namesEnv` and skip the production `newNamesEnv` / `pingEndpoint` +-- path. This is the only injection point for stub `ethCall` implementations +-- in functional-API tests. +newEnvWithNames :: ServerConfig s -> Maybe NamesEnv -> IO (Env s) +newEnvWithNames config@ServerConfig {allowSMPProxy, smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} namesOverride = do serverActive <- newTVarIO True server <- newServer msgStore_ <- case serverStoreCfg of @@ -608,20 +616,22 @@ newEnv config@ServerConfig {allowSMPProxy, smpCredentials, httpCredentials, serv sockets <- newTVarIO [] clientSeq <- newTVarIO 0 proxyAgent <- newSMPProxyAgent smpAgentCfg random - namesEnv <- case namesConfig of - Nothing -> pure Nothing - Just nc -> do - logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (ethereumEndpoint nc) - when allowSMPProxy $ - logWarn "[NAMES] enable: on on a proxy-role host: slow RSLV calls can serialise other forwarded commands on the same proxy-relay session. For high-volume deployments, run [NAMES] on a separate host." - env <- newNamesEnv nc - -- Probe the endpoint at startup. Don't exitFailure: a flapping - -- network or an Ethereum host coming up minutes after smp-server - -- should not block the server. Log so operators can spot it. - pingEndpoint env >>= \case - Right _ -> logInfo "[NAMES] endpoint probe ok" - Left e -> logWarn $ "[NAMES] endpoint probe failed (server will still start, RSLV will return ERR AUTH until reachable): " <> tshow e - pure (Just env) + namesEnv <- case namesOverride of + Just env -> pure (Just env) + Nothing -> case namesConfig of + Nothing -> pure Nothing + Just nc -> do + logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (ethereumEndpoint nc) + when allowSMPProxy $ + logWarn "[NAMES] enable: on on a proxy-role host: slow RSLV calls can serialise other forwarded commands on the same proxy-relay session. For high-volume deployments, run [NAMES] on a separate host." + env <- newNamesEnv nc + -- Probe the endpoint at startup. Don't exitFailure: a flapping + -- network or an Ethereum host coming up minutes after smp-server + -- should not block the server. Log so operators can spot it. + pingEndpoint env >>= \case + Right _ -> logInfo "[NAMES] endpoint probe ok" + Left e -> logWarn $ "[NAMES] endpoint probe failed (server will still start, RSLV will return ERR AUTH until reachable): " <> tshow e + pure (Just env) pure Env { serverActive, diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs new file mode 100644 index 000000000..60753f1fd --- /dev/null +++ b/tests/RSLVTests.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +-- | Functional-API tests for the public-namespace resolver (RSLV). +-- +-- Mocks the resolver at the `ethCall` layer using `newNamesEnvWith`. The +-- production `decodeGetRecord` is currently a placeholder that returns +-- `Right Nothing` for any non-malformed buffer (see Server/Names/Eth/SNRC.hs); +-- consequently the success-path test ("returns NAME with NameRecord") is +-- marked `pendingWith` until the SNRC ABI codec ships. Until then we test: +-- * direct RSLV (post-`ecd89cf1`) is accepted (not `CMD PROHIBITED`) +-- * `ERR AUTH` for contract / TLD config mismatches (verifyRslv layer) +-- * `ERR AUTH` for backend `NotFound` (placeholder decoder always hits this) +-- * `ERR AUTH` for backend transport errors +-- * `ERR AUTH` when the server has no `namesEnv` (rslvDisabled) +-- * the same paths via PFWD round-trip (proxy + resolver wiring works) +module RSLVTests (rslvTests) where + +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Time.Clock (getCurrentTime) +import SMPClient +import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol + ( BrokerMsg (..), + Cmd (..), + Command (..), + CorrId (..), + ErrorType (..), + NameOwner, + RslvRequest (..), + SParty (..), + Transmission, + TransmissionForAuth (..), + encodeTransmissionForAuth, + mkNameOwner, + pattern SMPServer, + tGetClient, + tPut, + ) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Server.Names + ( NamesConfig (..), + NamesEnv, + TldRegistries (..), + newNamesEnvWith, + ) +import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError (..)) +import Simplex.Messaging.Transport +import Simplex.Messaging.Version (mkVersionRange) +import Test.Hspec hiding (fit, it) +import Util (it) + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +unsafeOwner :: B.ByteString -> NameOwner +unsafeOwner = either error id . mkNameOwner + +-- contract address configured in the server's TLD registry +serverContract :: NameOwner +serverContract = unsafeOwner (B.replicate 20 '\x11') + +-- a different contract address (client points at the wrong one) +otherContract :: NameOwner +otherContract = unsafeOwner (B.replicate 20 '\x22') + +-- 8 slots × 32 bytes, all zero — `decodeGetRecord` treats slot 1 (owner) as +-- the zero sentinel and returns `Right Nothing` → resolver maps to NotFound. +zeroOwnerAbi :: B.ByteString +zeroOwnerAbi = B.replicate (32 * 8) '\NUL' + +stubNamesConfig :: TldRegistries -> NamesConfig +stubNamesConfig regs = + NamesConfig + { ethereumEndpoint = "http://stub", + tldRegistries = regs, + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + +-- | Default stub: returns the all-zero ABI buffer. With the placeholder +-- decoder this collapses every lookup to `ResolveError.NotFound` → AUTH. +stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) +stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) + +-- | Stub that always raises a transport-layer error (e.g. operator pointed +-- at the wrong endpoint). Server should map to `ERR AUTH` via +-- `rslvEthErrs` selector. We use `BodyTooLarge` because `HttpFailure` wraps +-- an `HttpException` value which is not easily constructed in tests; both +-- map to `EthHttpErr` via `mapEthRpcError`. +stubEthCallHttpErr :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) +stubEthCallHttpErr _to _data = pure (Left BodyTooLarge) + +-- | Names env: TLDSimplex is configured with `serverContract`; TLDTesting and +-- TLDWeb (via tldAll) are unset, so they should fail at `verifyRslv`. +mkSimplexOnlyNamesEnv :: (B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString)) -> IO NamesEnv +mkSimplexOnlyNamesEnv eth = + newNamesEnvWith + (stubNamesConfig regs) + eth + Nothing + where + regs = TldRegistries {tldSimplex = Just serverContract, tldTesting = Nothing, tldAll = Nothing} + +memCfg :: AServerConfig +memCfg = cfgMS (ASType SQSMemory SMSMemory) + +memProxyCfg :: AServerConfig +memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) + +-- | Second-server variant of `memCfg` that uses the `.2` store paths so it +-- can coexist with a first server using `memCfg` on the same machine +-- (StoreLog locks `testStoreLogFile`). `updateCfg` doesn't help here +-- because `serverStoreCfg` is GADT-typed; instead we override the field +-- directly inside the existential. +memCfg2 :: AServerConfig +memCfg2 = case memCfg of + ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)} + where + -- For SMSMemory the storeCfg is `SSCMemory (Maybe StorePaths)`; for any + -- other store the original is kept unchanged. + newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s + newStoreCfg = \case + SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2}) + other -> other + +-- | Run a single SMP server with stub `NamesEnv` on `testPort`. +withResolverServer :: NamesEnv -> IO a -> IO a +withResolverServer nenv = + withSmpServerConfigOnWithNames (transport @TLS) memCfg testPort nenv . const + +-- | Two-server setup for PFWD RSLV. Proxy on `testPort` (no NamesEnv — +-- proxy doesn't resolve locally); resolver on `testPort2` (stub NamesEnv). +withProxyAndResolver :: NamesEnv -> IO a -> IO a +withProxyAndResolver nenv runTest = + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOnWithNames (transport @TLS) memCfg2 testPort2 nenv (const runTest) + +-- --------------------------------------------------------------------------- +-- Direct-RSLV send/recv on a raw THandle +-- --------------------------------------------------------------------------- + +-- RSLV is `noAuthCmd` (Protocol.hs:1974) — sent unsigned. Helper sends one +-- transmission and reads the single-element batched response. +sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> RslvRequest -> IO (Transmission (Either ErrorType BrokerMsg)) +sendRslv h@THandle {params} corrId req = do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV req)) + [Right ()] <- tPut h (Right (Nothing, tToSend) :| []) + r :| _ <- tGetClient h + pure r + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +rslvTests :: Spec +rslvTests = do + describe "RSLV direct (non-forwarded)" $ do + it "server accepts RSLV without PFWD (not CMD PROHIBITED)" testRslvDirectAccepted + it "AUTH when contract address does not match TLD config" testRslvWrongContract + it "AUTH when TLD has no contract configured" testRslvUnknownTld + it "AUTH when backend reports zero owner (NotFound via placeholder decoder)" testRslvBackendNotFound + it "AUTH when backend transport fails (EthHttpErr)" testRslvBackendHttpErr + it "AUTH when server has no names config (namesEnv = Nothing)" testRslvDisabled + describe "RSLV forwarded (PFWD)" $ do + it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError AUTH)" testRslvForwarded + describe "RSLV success path (NAME response)" $ do + it "returns NAME with NameRecord" $ + pendingWith + "decodeGetRecord placeholder returns Right Nothing for all non-malformed inputs; \ + \re-enable when SNRC ABI codec ships (Server/Names/Eth/SNRC.hs:177-178)" + +-- --- direct path ----------------------------------------------------------- + +testRslvDirectAccepted :: IO () +testRslvDirectAccepted = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + (corrId, _entId, resp) <- sendRslv h "rs01" RslvRequest {name = "alice.simplex", contract = serverContract} + -- Placeholder decoder collapses zero-owner buffer to NotFound -> AUTH. + -- The point of this test is that the server accepted RSLV at all + -- (CMD PROHIBITED would mean the no-PFWD path was rejected). + corrId `shouldBe` CorrId "rs01" + resp `shouldBe` Right (ERR AUTH) + +testRslvWrongContract :: IO () +testRslvWrongContract = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + -- contract mismatch is caught by `verifyRslv` before any ethCall. + (_, _, resp) <- sendRslv h "rs02" RslvRequest {name = "alice.simplex", contract = otherContract} + resp `shouldBe` Right (ERR AUTH) + +testRslvUnknownTld :: IO () +testRslvUnknownTld = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + -- TLDTesting has no whitelist entry; verifyRslv -> Nothing -> AUTH. + (_, _, resp) <- sendRslv h "rs03" RslvRequest {name = "bob.testing", contract = serverContract} + resp `shouldBe` Right (ERR AUTH) + +testRslvBackendNotFound :: IO () +testRslvBackendNotFound = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + (_, _, resp) <- sendRslv h "rs04" RslvRequest {name = "ghost.simplex", contract = serverContract} + resp `shouldBe` Right (ERR AUTH) + +testRslvBackendHttpErr :: IO () +testRslvBackendHttpErr = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallHttpErr + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + (_, _, resp) <- sendRslv h "rs05" RslvRequest {name = "alice.simplex", contract = serverContract} + -- EthHttpErr maps to ERR AUTH (rslvEthErrs selector). + resp `shouldBe` Right (ERR AUTH) + +testRslvDisabled :: IO () +testRslvDisabled = do + -- Default cfgMS sets `namesConfig = Nothing` and we do NOT inject an + -- override -> server's `namesEnv = Nothing` -> RSLV returns AUTH via + -- the `rslvDisabled` selector path. + withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $ + testSMPClient @TLS $ \h -> do + (_, _, resp) <- sendRslv h "rs06" RslvRequest {name = "alice.simplex", contract = serverContract} + resp `shouldBe` Right (ERR AUTH) + +-- --- PFWD path ------------------------------------------------------------- + +testRslvForwarded :: IO () +testRslvForwarded = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + withProxyAndResolver nenv $ do + g <- C.newRandom + ts <- getCurrentTime + let proxyServ = SMPServer testHost testPort testKeyHash + relayServ = SMPServer testHost2 testPort2 testKeyHash + cfg' = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} + pcE <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) cfg' [] Nothing ts (\_ -> pure ()) + pc <- either (fail . show) pure pcE + -- proxyCfgMS has no `newQueueBasicAuth`; PRXY with Nothing succeeds. + sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing) + -- The destination relay replies ERR AUTH; proxy decodes and reports as + -- `PCEProtocolError AUTH`; `proxyResolveName` lets that throwE propagate. + r <- runExceptT (proxyResolveName pc NRMInteractive sess serverContract "alice.simplex") + case r of + Left (PCEProtocolError SMP.AUTH) -> pure () + _ -> expectationFailure $ "expected Left (PCEProtocolError AUTH), got: " <> show r + +runExceptT' :: Show e => ExceptT e IO a -> IO a +runExceptT' a = runExceptT a >>= either (fail . show) pure diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2ee9b509f..3f6386921 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -30,7 +30,8 @@ import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClie import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol -import Simplex.Messaging.Server (runSMPServerBlocking) +import Simplex.Messaging.Server (runSMPServerBlocking, runSMPServerBlockingWithNames) +import Simplex.Messaging.Server.Names (NamesEnv) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) @@ -363,6 +364,16 @@ withSmpServerConfigOn t (ASrvCfg _ _ cfg') port' = (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing) (threadDelay 10000) +-- | Variant of `withSmpServerConfigOn` for RSLV functional tests: passes a +-- pre-built `NamesEnv` (typically with a stub `ethCall`) so the server does +-- not contact the real Ethereum RPC. Skips the production `pingEndpoint` +-- probe. +withSmpServerConfigOnWithNames :: HasCallStack => ASrvTransport -> AServerConfig -> ServiceName -> NamesEnv -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerConfigOnWithNames t (ASrvCfg _ _ cfg') port' nenv = + serverBracket + (\started -> runSMPServerBlockingWithNames started cfg' {transports = [(port', t, False)]} Nothing (Just nenv)) + (threadDelay 10000) + withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) diff --git a/tests/Test.hs b/tests/Test.hs index b0cf34724..22cc8c03c 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -22,6 +22,7 @@ import CoreTests.VersionRangeTests import FileDescriptionTests (fileDescriptionTests) import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException +import RSLVTests (rslvTests) import RemoteControl (remoteControlTests) import SMPNamesTests (smpNamesTests) import SMPProxyTests (smpProxyTests) @@ -101,6 +102,7 @@ main = do describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests describe "Names resolver tests" smpNamesTests + describe "RSLV functional API tests" rslvTests describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) around_ (postgressBracket testServerDBConnectInfo) $ From c0c65fdf8950f0f3b202c5e31959ade91a2439d6 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 12:09:23 +0000 Subject: [PATCH 11/15] namespace: agent end-to-end tests for resolveSimplexName --- simplexmq.cabal | 1 + tests/AgentTests.hs | 2 + tests/AgentTests/ResolveNameTests.hs | 237 +++++++++++++++++++++++++++ 3 files changed, 240 insertions(+) create mode 100644 tests/AgentTests/ResolveNameTests.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 654b77f7d..314d6bfae 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -496,6 +496,7 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests + AgentTests.ResolveNameTests AgentTests.ServerChoice AgentTests.ShortLinkTests CLITests diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 368e7c0e2..34d610cd5 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -12,6 +12,7 @@ import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) +import AgentTests.ResolveNameTests (resolveNameTests) import AgentTests.ServerChoice (serverChoiceTests) import AgentTests.ShortLinkTests (shortLinkTests) import Simplex.Messaging.Server.Env.STM (AStoreType (..)) @@ -37,6 +38,7 @@ agentCoreTests = do describe "Connection request" connectionRequestTests describe "Double ratchet tests" doubleRatchetTests describe "Short link tests" shortLinkTests + resolveNameTests agentTests :: (ASrvTransport, AStoreType) -> Spec agentTests ps = do diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs new file mode 100644 index 000000000..78607046e --- /dev/null +++ b/tests/AgentTests/ResolveNameTests.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +-- | End-to-end tests for `Simplex.Messaging.Agent.resolveSimplexName`. +-- +-- Exercises the agent layer (real `AgentClient`) against an SMP server with +-- a stub `NamesEnv` — same pattern as `RSLVTests` but going through +-- `sendOrProxySMPCommand` so we cover the agent-side direct/proxy selection +-- and the agent's error mapping (`SMP host AUTH`, `PROXY {.. proxyErr ..}`, +-- `INTERNAL ..`). +-- +-- The success path is intentionally `pendingWith`: until the SNRC ABI codec +-- ships, `decodeGetRecord` collapses every non-malformed buffer to +-- `Right Nothing` (NotFound), which the resolver maps to `ERR AUTH`. Re-enable +-- the success test when `Server/Names/Eth/SNRC.hs:177-178` returns real records. +module AgentTests.ResolveNameTests (resolveNameTests) where + +import AgentTests.FunctionalAPITests (withAgent) +import Control.Monad.Except (runExceptT) +import qualified Data.ByteString.Char8 as B +import Data.List (isInfixOf) +import SMPAgentClient +import SMPClient +import Simplex.Messaging.Agent (resolveSimplexName) +import Simplex.Messaging.Agent.Client (AgentClient) +import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..)) +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) +import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive) +import Simplex.Messaging.Protocol + ( NameOwner, + mkNameOwner, + pattern SMPServer, + ) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, TldRegistries (..), newNamesEnvWith) +import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError) +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) +import Simplex.Messaging.Transport +import Test.Hspec hiding (fit, it) +import Util (it) + +-- --------------------------------------------------------------------------- +-- Fixtures (parallel to RSLVTests) +-- --------------------------------------------------------------------------- + +unsafeOwner :: B.ByteString -> NameOwner +unsafeOwner = either error id . mkNameOwner + +-- Must match the TLDSimplex stub in `tldNameContract` (Agent.hs:1202): the +-- agent forwards this contract to the server, which checks it against +-- TldRegistries.tldSimplex. +serverContract :: NameOwner +serverContract = unsafeOwner (B.replicate 20 '\x11') + +-- 8 slots * 32 bytes, all zero — placeholder `decodeGetRecord` returns +-- `Right Nothing` for the zero-owner sentinel, so the resolver maps to +-- `ResolveError.NotFound` -> `ERR AUTH`. +zeroOwnerAbi :: B.ByteString +zeroOwnerAbi = B.replicate (32 * 8) '\NUL' + +stubNamesConfig :: TldRegistries -> NamesConfig +stubNamesConfig regs = + NamesConfig + { ethereumEndpoint = "http://stub", + tldRegistries = regs, + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + +stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) +stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) + +-- | TLDSimplex registered with `serverContract`; TLDTesting / TLDWeb absent +-- so the resolver's `verifyRslv` rejects them with AUTH. +mkSimplexOnlyNamesEnv :: IO NamesEnv +mkSimplexOnlyNamesEnv = + newNamesEnvWith + (stubNamesConfig regs) + stubEthCallNotFound + Nothing + where + regs = TldRegistries {tldSimplex = Just serverContract, tldTesting = Nothing, tldAll = Nothing} + +memCfg :: AServerConfig +memCfg = cfgMS (ASType SQSMemory SMSMemory) + +memProxyCfg :: AServerConfig +memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) + +-- Second-server `memCfg` variant on `testStoreLogFile2` so the two servers +-- can coexist on the same machine (StoreLog locks `testStoreLogFile`); see +-- RSLVTests `memCfg2` for the same workaround. +memCfg2 :: AServerConfig +memCfg2 = case memCfg of + ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)} + where + newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s + newStoreCfg = \case + SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2}) + other -> other + +-- | Single resolver server on `testPort`, paired with an agent configured +-- for direct sends (SPMNever). The agent's only configured server is the +-- resolver itself. +withDirectResolver :: NamesEnv -> (AgentClient -> IO a) -> IO a +withDirectResolver nenv k = + withSmpServerConfigOnWithNames (transport @TLS) memCfg testPort nenv $ \_ -> + withAgent 1 agentCfg directServers testDB k + where + directServers = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = userServers [testSMPServer]} + +-- | Two-server setup for the proxy path. Proxy on `testPort` (no NamesEnv — +-- proxy doesn't resolve locally), resolver on `testPort2` (stub NamesEnv). +-- Agent's user-server list contains both, with SPMAlways so it always picks +-- a proxy. `getNextServer` excludes the destination from candidates, so the +-- agent picks the first server (proxy) when sending to the second (resolver). +withProxyAndResolver :: NamesEnv -> (AgentClient -> IO a) -> IO a +withProxyAndResolver nenv k = + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOnWithNames (transport @TLS) memCfg2 testPort2 nenv $ \_ -> + withAgent 1 agentCfg proxyServers testDB k + where + proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = userServers [testSMPServer, testSMPServer2]} + +-- The resolver address corresponds to whichever server has the stub NamesEnv: +-- single-server -> testPort; two-server -> testPort2. +directResolverSrv :: SMP.SMPServer +directResolverSrv = SMPServer testHost testPort testKeyHash + +proxiedResolverSrv :: SMP.SMPServer +proxiedResolverSrv = SMPServer testHost2 testPort2 testKeyHash + +-- --------------------------------------------------------------------------- +-- Spec +-- --------------------------------------------------------------------------- + +resolveNameTests :: Spec +resolveNameTests = do + describe "Agent resolveSimplexName" $ do + describe "direct path (SPMNever)" $ + it "AUTH propagates as SMP host AUTH (placeholder decoder -> NotFound)" testDirectAuth + describe "proxy path (SPMAlways)" $ + it "AUTH from resolver propagates via proxy as SMP AUTH" testProxyAuth + describe "TLD without server-side contract" $ + it "AUTH (verifyRslv rejects unmapped TLD before any ethCall)" testUnknownTldOnServer + describe "TLD without agent-side contract" $ + it "INTERNAL (TLDWeb has no tldNameContract entry)" testNoAgentContract + describe "success path" $ + it "returns NameRecord" $ + pendingWith + "decodeGetRecord placeholder returns Right Nothing for all non-malformed inputs; \ + \re-enable when SNRC ABI codec ships (Server/Names/Eth/SNRC.hs:177-178)" + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +-- | Direct path: agent with SPMNever sends RSLV without PFWD; resolver +-- replies ERR AUTH (placeholder decoder -> NotFound); agent maps the SMP +-- protocol error to `SMP host AUTH` (Client.hs:1255 -> protocolError_). +testDirectAuth :: HasCallStack => IO () +testDirectAuth = do + nenv <- mkSimplexOnlyNamesEnv + withDirectResolver nenv $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv simplexDomain + case r of + Left (SMP _ SMP.AUTH) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ AUTH), got: " <> show r + where + simplexDomain = SimplexNameDomain TLDSimplex "alice" [] + +-- | Proxy path: agent with SPMAlways wraps RSLV in PFWD; proxy forwards to +-- the resolver, which replies ERR AUTH (placeholder decoder -> NotFound). +-- The proxy's `proxySMPCommand` wraps a destination-relay protocol error in +-- `throwE $ PCEProtocolError AUTH` (Client.hs:1231), which `liftClient SMP` +-- in `sendOrProxySMPCommand` (Client.hs:1179) surfaces as `SMP proxyHost AUTH`. +-- The agent-level `PROXY` constructor is reserved for proxy-side failures +-- (e.g. PROXY NO_SESSION); relay-level protocol errors are reported +-- transparently as SMP errors — this is the "transparent for AUTH/QUOTA" +-- contract documented at Client.hs:1178. +-- +-- Note the host is the proxy server's host (testPort/5001), not the resolver +-- — this is the proxy server the agent is connected to for forwarding. +testProxyAuth :: HasCallStack => IO () +testProxyAuth = do + nenv <- mkSimplexOnlyNamesEnv + withProxyAndResolver nenv $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 proxiedResolverSrv simplexDomain + case r of + Left (SMP host SMP.AUTH) | testPort `isInfixOf` host -> pure () + _ -> expectationFailure $ "expected Left (SMP testPort <> "> AUTH), got: " <> show r + where + simplexDomain = SimplexNameDomain TLDSimplex "alice" [] + +-- | TLD has an agent-side contract (TLDTesting -> 0x22..) but the server's +-- `TldRegistries.tldTesting` is `Nothing`. The server's `verifyRslv` returns +-- Nothing before any ethCall and replies ERR AUTH; agent surfaces it as +-- `SMP host AUTH` exactly like a successful-route NotFound. +testUnknownTldOnServer :: HasCallStack => IO () +testUnknownTldOnServer = do + nenv <- mkSimplexOnlyNamesEnv + withDirectResolver nenv $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv testingDomain + case r of + Left (SMP _ SMP.AUTH) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ AUTH), got: " <> show r + where + testingDomain = SimplexNameDomain TLDTesting "bob" [] + +-- | Pure agent-side test: `tldNameContract TLDWeb = Nothing` (Agent.hs:1204), +-- so `resolveSimplexName'` throws INTERNAL before any server contact. The +-- agent still needs initialisation, but no server bracket: the throw +-- happens before any network IO. +testNoAgentContract :: HasCallStack => IO () +testNoAgentContract = + withAgent 1 agentCfg agentServers testDB $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv webDomain + case r of + Left (INTERNAL msg) | "no resolver contract for TLD" `isInfixOf` msg -> pure () + _ -> expectationFailure $ "expected Left (INTERNAL \"... no resolver contract for TLD\"), got: " <> show r + where + webDomain = SimplexNameDomain TLDWeb "example.com" [] + -- Non-empty userServers is required for agent init; never contacted. + agentServers = initAgentServers {smp = userServers [testSMPServer]} From 5c2dc5476ac1b350451b62e206e87b9047c068d6 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 13:06:28 +0000 Subject: [PATCH 12/15] namespace: share TLD->contract mapping; drop TldRegistries record The TLD->NameOwner placeholder mapping was duplicated literal-for-literal between Agent.hs (tldNameContract) and Server/Main.hs (hardcodedTldRegistries). Lock-step bumps risked silent divergence. Extract into Simplex.Messaging.SimplexName.Contracts.tldContract; both agent and server read from there. Server-side per-operator TLD config (TldRegistries record, lookupTldAddress, NamesConfig.tldRegistries) is removed entirely - it was already inert post-b66d9730 (which dropped the INI keys). --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 17 +--- src/Simplex/Messaging/Server/Main.hs | 21 +---- src/Simplex/Messaging/Server/Names.hs | 55 ++++-------- .../Messaging/SimplexName/Contracts.hs | 30 +++++++ tests/AgentTests/ResolveNameTests.hs | 60 +++++-------- tests/RSLVTests.hs | 25 +++--- tests/SMPNamesTests.hs | 84 ++++++++----------- 8 files changed, 113 insertions(+), 180 deletions(-) create mode 100644 src/Simplex/Messaging/SimplexName/Contracts.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 314d6bfae..fa85dc0cd 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -142,6 +142,7 @@ library Simplex.Messaging.Server.QueueStore.QueueInfo Simplex.Messaging.ServiceScheme Simplex.Messaging.SimplexName + Simplex.Messaging.SimplexName.Contracts Simplex.Messaging.Session Simplex.Messaging.SystemTime Simplex.Messaging.TMap diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index a297a3ed0..73be8269e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -217,7 +217,6 @@ import Simplex.Messaging.Protocol ErrorType (AUTH), MsgBody, MsgFlags (..), - NameOwner, NameRecord, NtfServer, ProtoServerWithAuth (..), @@ -236,11 +235,11 @@ import Simplex.Messaging.Protocol SubscriptionMode (..), UserProtocol, VersionSMPC, - mkNameOwner, senderCanSecure, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) +import Simplex.Messaging.SimplexName.Contracts (tldContract) import Simplex.Messaging.SystemTime import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPVersion, THClientService' (..), THandleAuth (..), THandleParams (..)) @@ -1193,20 +1192,8 @@ getConnShortLink' c nm userId = \case deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId --- | TLD -> SNRC contract whitelist. Must match the server-side --- `hardcodedTldRegistries` in `Server/Main.hs`: the resolver verifies the --- client-supplied contract against its own TLD config and replies AUTH on --- mismatch. TLDWeb is intentionally unmapped (no SimpleX contract). -tldNameContract :: SimplexTLD -> Maybe NameOwner -tldNameContract = \case - TLDSimplex -> mkOwnerStub '\x11' - TLDTesting -> mkOwnerStub '\x22' - TLDWeb -> Nothing - where - mkOwnerStub c = eitherToMaybe $ mkNameOwner (B.replicate 20 c) - resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexNameDomain -> AM NameRecord -resolveSimplexName' c nm userId resolverSrv domain = case tldNameContract (nameTLD domain) of +resolveSimplexName' c nm userId resolverSrv domain = case tldContract (nameTLD domain) of Nothing -> throwE $ INTERNAL "resolveSimplexName: no resolver contract for TLD" Just contract -> resolveName c nm userId resolverSrv contract (fullDomainName domain) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 47345ef01..442350e48 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -70,7 +70,7 @@ import qualified Data.IP as IP import Data.Bits (shiftR, (.&.)) import Data.Word (Word32) import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) -import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), mkNameOwner, pattern SMPServer) +import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM @@ -80,7 +80,7 @@ import Simplex.Messaging.Server.Main.Init import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..)) import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore) import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore) -import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..), TldRegistries (..)) +import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange) @@ -811,7 +811,6 @@ readNamesConfig ini in Just NamesConfig { ethereumEndpoint = either (error . ("[NAMES] ethereum_endpoint: " <>)) id (validateUrl endpoint rpcAuth_), - tldRegistries = hardcodedTldRegistries, rpcAuth = rpcAuth_, rpcTimeoutMs = boundedIniInt 3000 100 60000 "rpc_timeout_ms", rpcMaxResponseBytes = boundedIniInt 262144 1024 16777216 "rpc_max_response_bytes", @@ -839,22 +838,6 @@ readNamesConfig ini | otherwise -> error $ "[NAMES] " <> T.unpack key <> " must be in [" <> show floor_ <> ".." <> show ceiling_ <> "] (got " <> show n <> ")" --- | Hardcoded SNRC contract whitelist. Placeholder addresses until the --- launch contracts are deployed; replaced in code rather than INI so --- operators can't accidentally point a names router at the wrong contract --- during the bootstrap phase. The TldRegistries shape + lookup precedence --- (TLD-specific then `tldAll` catch-all) is unchanged from the previous --- INI-driven form. -hardcodedTldRegistries :: TldRegistries -hardcodedTldRegistries = - TldRegistries - { tldSimplex = Just (placeholderAddr '\x11'), - tldTesting = Just (placeholderAddr '\x22'), - tldAll = Nothing - } - where - placeholderAddr c = either error id $ mkNameOwner (B.replicate 20 c) - -- | Validate the ethereum_endpoint URL: -- * scheme must be http: or https: -- * authority (host) must be present and non-empty diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index 9a94cf634..8c26fdd2d 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -13,7 +13,6 @@ -- Keccak-256 namehash and SNRC ABI decoder live in Names.Eth.SNRC. module Simplex.Messaging.Server.Names ( NamesConfig (..), - TldRegistries (..), RpcAuth (..), NamesEnv (..), EthCall, @@ -21,20 +20,18 @@ module Simplex.Messaging.Server.Names newNamesEnv, newNamesEnvWith, closeNamesEnv, - lookupTldAddress, pingEndpoint, resolveName, verifyRslv, ) where -import Control.Applicative ((<|>)) import Control.Monad (forM_, guard, unless, when) import qualified Control.Exception as E import Control.Logger.Simple (logError) import Data.ByteString.Char8 (ByteString) import Data.IORef (IORef, atomicModifyIORef', newIORef) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -45,24 +42,11 @@ import Simplex.Messaging.Protocol (NameOwner, NameRecord, RslvRequest (..), unNa import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) import Simplex.Messaging.Server.Names.Eth.SNRC (decodeAddress, decodeGetRecord, encodeGetRecord, isZeroOwner, namehash) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..), fullDomainName) +import Simplex.Messaging.SimplexName.Contracts (tldContract) import System.Timeout (timeout) --- | TLD-keyed SNRC contract whitelist. Each RSLV carries the contract --- address the client wants queried; the server only accepts it if it --- matches the address configured for that TLD (or `tldAll` as catch-all). --- This lets one names router host multiple TLDs (each backed by its own --- SNRC contract) and reject clients pointing at a contract the operator --- doesn't run. -data TldRegistries = TldRegistries - { tldSimplex :: Maybe NameOwner, - tldTesting :: Maybe NameOwner, - tldAll :: Maybe NameOwner - } - deriving (Show) - data NamesConfig = NamesConfig { ethereumEndpoint :: Text, - tldRegistries :: TldRegistries, rpcAuth :: Maybe RpcAuth, rpcTimeoutMs :: Int, rpcMaxResponseBytes :: Int, @@ -105,38 +89,30 @@ newNamesEnvWith config ethCall rpcEnv = do closeNamesEnv :: NamesEnv -> IO () closeNamesEnv NamesEnv {rpcEnv} = mapM_ closeEthRpcEnv rpcEnv --- | Look up the expected SNRC contract address for a TLD. TLD-specific --- entry takes precedence; `tldAll` is the catch-all. `TLDWeb` has no --- TLD-specific entry — it always resolves through `tldAll` if set. -lookupTldAddress :: TldRegistries -> SimplexTLD -> Maybe NameOwner -lookupTldAddress TldRegistries {tldSimplex, tldTesting, tldAll} = \case - TLDSimplex -> tldSimplex <|> tldAll - TLDTesting -> tldTesting <|> tldAll - TLDWeb -> tldAll - -- | Parse the client-supplied domain, look up the TLD's expected contract, -- and verify the client-supplied contract matches. Returns the verified -- (address, parsed-domain) pair, or `Nothing` if any check fails — the -- handler maps this to `ERR AUTH` and increments `rslvBadName`. verifyRslv :: NamesEnv -> RslvRequest -> Maybe (NameOwner, SimplexNameDomain) -verifyRslv NamesEnv {config} RslvRequest {name, contract} = case strDecode (encodeUtf8 name) of +verifyRslv _ RslvRequest {name, contract} = case strDecode (encodeUtf8 name) of Left _ -> Nothing Right d -> do - expected <- lookupTldAddress (tldRegistries config) (nameTLD d) + expected <- tldContract (nameTLD d) guard (expected == contract) pure (expected, d) -- | Reach the configured endpoint with a harmless probe call to confirm --- network reachability. Uses any configured contract address (the parser --- guarantees at least one is set). A JSON-RPC error (e.g. unknown contract --- on a healthy node) is treated as "endpoint reachable". HTTP transport --- failures, oversized responses, and non-JSON bodies (operator pointing at --- the wrong service) all surface as Left so startup fails loudly rather --- than every RSLV silently incrementing rslvEthErrs. +-- network reachability. Uses any configured contract address (the static +-- TLD->contract mapping guarantees at least one is set; TLDWeb has none by +-- design). A JSON-RPC error (e.g. unknown contract on a healthy node) is +-- treated as "endpoint reachable". HTTP transport failures, oversized +-- responses, and non-JSON bodies (operator pointing at the wrong service) +-- all surface as Left so startup fails loudly rather than every RSLV +-- silently incrementing rslvEthErrs. pingEndpoint :: NamesEnv -> IO (Either EthRpcError ()) -pingEndpoint NamesEnv {ethCall, config} = case anyAddress (tldRegistries config) of - Nothing -> pure (Right ()) - Just addr -> do +pingEndpoint NamesEnv {ethCall, config} = case mapMaybe tldContract [TLDSimplex, TLDTesting] of + [] -> pure (Right ()) + addr : _ -> do -- Bound the probe by the same rpcTimeoutMs that resolveName uses, so a -- slow-loris endpoint can't park startup until http-client's default -- 30 s response timeout fires. @@ -147,9 +123,6 @@ pingEndpoint NamesEnv {ethCall, config} = case anyAddress (tldRegistries config) Just (Left JsonRpcErr {}) -> Right () -- node answered, just doesn't know this contract Just (Left e) -> Left e Just (Right _) -> Right () - where - anyAddress TldRegistries {tldSimplex, tldTesting, tldAll} = - tldSimplex <|> tldTesting <|> tldAll -- | Resolve a verified (contract, domain) pair with an rpcTimeoutMs -- ceiling. Synchronous exceptions are caught and logged; async exceptions diff --git a/src/Simplex/Messaging/SimplexName/Contracts.hs b/src/Simplex/Messaging/SimplexName/Contracts.hs new file mode 100644 index 000000000..94075abce --- /dev/null +++ b/src/Simplex/Messaging/SimplexName/Contracts.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Single source of truth for TLD -> SNRC contract address. +-- Both the agent (which sends the contract in RslvRequest so the server +-- can refuse mismatched calls) and the server (which checks the +-- client-supplied contract against this mapping in verifyRslv) read +-- from here. Lock-step bumps land in one place. +module Simplex.Messaging.SimplexName.Contracts + ( tldContract, + ) +where + +import qualified Data.ByteString.Char8 as B +import Simplex.Messaging.Protocol (NameOwner, mkNameOwner) +import Simplex.Messaging.SimplexName (SimplexTLD (..)) + +-- | Map a TLD to its SNRC contract address. `Nothing` means the TLD has +-- no SimpleX-native registry (e.g., `TLDWeb` is reserved for external +-- web domains and never resolved on-chain via this stack). +-- +-- Both bytes are placeholders pending the live SNRC deployment; update +-- here and the change is observed atomically by agent and server. +tldContract :: SimplexTLD -> Maybe NameOwner +tldContract = \case + TLDSimplex -> Just (placeholder '\x11') + TLDTesting -> Just (placeholder '\x22') + TLDWeb -> Nothing + where + placeholder c = either error id (mkNameOwner (B.replicate 20 c)) diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs index 78607046e..bc0285720 100644 --- a/tests/AgentTests/ResolveNameTests.hs +++ b/tests/AgentTests/ResolveNameTests.hs @@ -35,15 +35,11 @@ import Simplex.Messaging.Agent.Client (AgentClient) import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive) -import Simplex.Messaging.Protocol - ( NameOwner, - mkNameOwner, - pattern SMPServer, - ) +import Simplex.Messaging.Protocol (pattern SMPServer) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) -import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, TldRegistries (..), newNamesEnvWith) +import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnvWith) import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) import Simplex.Messaging.Transport @@ -54,26 +50,16 @@ import Util (it) -- Fixtures (parallel to RSLVTests) -- --------------------------------------------------------------------------- -unsafeOwner :: B.ByteString -> NameOwner -unsafeOwner = either error id . mkNameOwner - --- Must match the TLDSimplex stub in `tldNameContract` (Agent.hs:1202): the --- agent forwards this contract to the server, which checks it against --- TldRegistries.tldSimplex. -serverContract :: NameOwner -serverContract = unsafeOwner (B.replicate 20 '\x11') - -- 8 slots * 32 bytes, all zero — placeholder `decodeGetRecord` returns -- `Right Nothing` for the zero-owner sentinel, so the resolver maps to -- `ResolveError.NotFound` -> `ERR AUTH`. zeroOwnerAbi :: B.ByteString zeroOwnerAbi = B.replicate (32 * 8) '\NUL' -stubNamesConfig :: TldRegistries -> NamesConfig -stubNamesConfig regs = +stubNamesConfig :: NamesConfig +stubNamesConfig = NamesConfig { ethereumEndpoint = "http://stub", - tldRegistries = regs, rpcAuth = Nothing, rpcTimeoutMs = 1000, rpcMaxResponseBytes = 65536, @@ -83,16 +69,11 @@ stubNamesConfig regs = stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) --- | TLDSimplex registered with `serverContract`; TLDTesting / TLDWeb absent --- so the resolver's `verifyRslv` rejects them with AUTH. +-- | Names env using the static `tldContract` mapping: TLDSimplex and +-- TLDTesting map to placeholder contracts; TLDWeb is unmapped and rejected +-- by the resolver's `verifyRslv`. mkSimplexOnlyNamesEnv :: IO NamesEnv -mkSimplexOnlyNamesEnv = - newNamesEnvWith - (stubNamesConfig regs) - stubEthCallNotFound - Nothing - where - regs = TldRegistries {tldSimplex = Just serverContract, tldTesting = Nothing, tldAll = Nothing} +mkSimplexOnlyNamesEnv = newNamesEnvWith stubNamesConfig stubEthCallNotFound Nothing memCfg :: AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) @@ -154,10 +135,10 @@ resolveNameTests = do it "AUTH propagates as SMP host AUTH (placeholder decoder -> NotFound)" testDirectAuth describe "proxy path (SPMAlways)" $ it "AUTH from resolver propagates via proxy as SMP AUTH" testProxyAuth - describe "TLD without server-side contract" $ - it "AUTH (verifyRslv rejects unmapped TLD before any ethCall)" testUnknownTldOnServer - describe "TLD without agent-side contract" $ - it "INTERNAL (TLDWeb has no tldNameContract entry)" testNoAgentContract + describe "TLDTesting path" $ + it "AUTH (placeholder decoder -> NotFound) for TLDTesting too" testUnknownTldOnServer + describe "TLD without contract entry" $ + it "INTERNAL (TLDWeb has no tldContract entry)" testNoAgentContract describe "success path" $ it "returns NameRecord" $ pendingWith @@ -205,10 +186,11 @@ testProxyAuth = do where simplexDomain = SimplexNameDomain TLDSimplex "alice" [] --- | TLD has an agent-side contract (TLDTesting -> 0x22..) but the server's --- `TldRegistries.tldTesting` is `Nothing`. The server's `verifyRslv` returns --- Nothing before any ethCall and replies ERR AUTH; agent surfaces it as --- `SMP host AUTH` exactly like a successful-route NotFound. +-- | TLDTesting maps (on both agent and server, via the static +-- `tldContract`) to its own placeholder contract. With the placeholder +-- decoder the resolver collapses any non-zero buffer to NotFound, so the +-- agent surfaces `SMP host AUTH`. Sanity-check that the non-default TLD +-- routes through the same code path as TLDSimplex. testUnknownTldOnServer :: HasCallStack => IO () testUnknownTldOnServer = do nenv <- mkSimplexOnlyNamesEnv @@ -220,10 +202,10 @@ testUnknownTldOnServer = do where testingDomain = SimplexNameDomain TLDTesting "bob" [] --- | Pure agent-side test: `tldNameContract TLDWeb = Nothing` (Agent.hs:1204), --- so `resolveSimplexName'` throws INTERNAL before any server contact. The --- agent still needs initialisation, but no server bracket: the throw --- happens before any network IO. +-- | Pure agent-side test: `tldContract TLDWeb = Nothing` +-- (SimplexName.Contracts), so `resolveSimplexName'` throws INTERNAL before +-- any server contact. The agent still needs initialisation, but no server +-- bracket: the throw happens before any network IO. testNoAgentContract :: HasCallStack => IO () testNoAgentContract = withAgent 1 agentCfg agentServers testDB $ \c -> do diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 60753f1fd..2a4525f0b 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -54,7 +54,6 @@ import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.Names ( NamesConfig (..), NamesEnv, - TldRegistries (..), newNamesEnvWith, ) import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError (..)) @@ -83,11 +82,10 @@ otherContract = unsafeOwner (B.replicate 20 '\x22') zeroOwnerAbi :: B.ByteString zeroOwnerAbi = B.replicate (32 * 8) '\NUL' -stubNamesConfig :: TldRegistries -> NamesConfig -stubNamesConfig regs = +stubNamesConfig :: NamesConfig +stubNamesConfig = NamesConfig { ethereumEndpoint = "http://stub", - tldRegistries = regs, rpcAuth = Nothing, rpcTimeoutMs = 1000, rpcMaxResponseBytes = 65536, @@ -107,16 +105,12 @@ stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) stubEthCallHttpErr :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) stubEthCallHttpErr _to _data = pure (Left BodyTooLarge) --- | Names env: TLDSimplex is configured with `serverContract`; TLDTesting and --- TLDWeb (via tldAll) are unset, so they should fail at `verifyRslv`. +-- | Names env using the static TLD->contract mapping in +-- `SimplexName.Contracts.tldContract`: TLDSimplex maps to `serverContract`, +-- TLDTesting to a different placeholder, and TLDWeb is unmapped (rejected +-- by `verifyRslv`). mkSimplexOnlyNamesEnv :: (B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString)) -> IO NamesEnv -mkSimplexOnlyNamesEnv eth = - newNamesEnvWith - (stubNamesConfig regs) - eth - Nothing - where - regs = TldRegistries {tldSimplex = Just serverContract, tldTesting = Nothing, tldAll = Nothing} +mkSimplexOnlyNamesEnv eth = newNamesEnvWith stubNamesConfig eth Nothing memCfg :: AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) @@ -214,8 +208,9 @@ testRslvUnknownTld = do nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound withResolverServer nenv $ testSMPClient @TLS $ \h -> do - -- TLDTesting has no whitelist entry; verifyRslv -> Nothing -> AUTH. - (_, _, resp) <- sendRslv h "rs03" RslvRequest {name = "bob.testing", contract = serverContract} + -- TLDWeb has no entry in the static `tldContract` mapping; + -- verifyRslv -> Nothing -> AUTH. + (_, _, resp) <- sendRslv h "rs03" RslvRequest {name = "example.web", contract = serverContract} resp `shouldBe` Right (ERR AUTH) testRslvBackendNotFound :: IO () diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 919db2100..c9c362677 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -26,12 +26,11 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Names ( NamesConfig (..), ResolveError (..), - TldRegistries (..), - lookupTldAddress, newNamesEnvWith, resolveName, verifyRslv, ) +import Simplex.Messaging.SimplexName.Contracts (tldContract) import Simplex.Messaging.Server.Names.Eth.SNRC ( AbiError (..), decodeAddress, @@ -74,16 +73,20 @@ twentyOnes = B.replicate 20 '\x01' unsafeOwner :: ByteString -> NameOwner unsafeOwner = either error id . mkNameOwner -addr1, addr2, addr3 :: NameOwner +addr1, addr2 :: NameOwner addr1 = unsafeOwner twentyOnes addr2 = unsafeOwner (B.replicate 20 '\x02') -addr3 = unsafeOwner (B.replicate 20 '\x03') -testNamesConfig :: TldRegistries -> NamesConfig -testNamesConfig regs = +-- Match the static `tldContract` mapping in SimplexName.Contracts so RSLV +-- verifyRslv accepts these as the expected contract per TLD. +simplexContract, testingContract :: NameOwner +simplexContract = unsafeOwner (B.replicate 20 '\x11') +testingContract = unsafeOwner (B.replicate 20 '\x22') + +testNamesConfig :: NamesConfig +testNamesConfig = NamesConfig { ethereumEndpoint = "http://stub", - tldRegistries = regs, rpcAuth = Nothing, rpcTimeoutMs = 1000, rpcMaxResponseBytes = 65536, @@ -283,83 +286,62 @@ zeroOwnerSpec = do tldWhitelistSpec :: Spec tldWhitelistSpec = do - describe "lookupTldAddress" $ do - it "TLD-specific entry takes precedence over _all" $ do - let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Just addr3} - lookupTldAddress regs TLDSimplex `shouldBe` Just addr1 - lookupTldAddress regs TLDTesting `shouldBe` Just addr2 - - it "TLD without specific entry falls back to _all" $ do - let regs = TldRegistries {tldSimplex = Nothing, tldTesting = Nothing, tldAll = Just addr3} - lookupTldAddress regs TLDSimplex `shouldBe` Just addr3 - lookupTldAddress regs TLDTesting `shouldBe` Just addr3 - - it "TLDWeb resolves only through _all" $ do - let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Just addr3} - lookupTldAddress regs TLDWeb `shouldBe` Just addr3 - - it "TLDWeb without _all returns Nothing even if other TLDs are set" $ do - let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Nothing} - lookupTldAddress regs TLDWeb `shouldBe` Nothing + describe "tldContract" $ do + it "maps TLDSimplex and TLDTesting to distinct contracts; TLDWeb is unmapped" $ do + tldContract TLDSimplex `shouldBe` Just simplexContract + tldContract TLDTesting `shouldBe` Just testingContract + tldContract TLDWeb `shouldBe` Nothing describe "verifyRslv" $ do - let mkEnv regs = newNamesEnvWith (testNamesConfig regs) (\_ _ -> pure (Right "")) Nothing + let mkEnv = newNamesEnvWith testNamesConfig (\_ _ -> pure (Right "")) Nothing it "accepts a valid name with matching TLD-specific contract" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} - let req = RslvRequest {name = "privacy.simplex", contract = addr1} + env <- mkEnv + let req = RslvRequest {name = "privacy.simplex", contract = simplexContract} case verifyRslv env req of Just (a, d) -> do - a `shouldBe` addr1 + a `shouldBe` simplexContract nameTLD d `shouldBe` TLDSimplex domain d `shouldBe` "privacy" Nothing -> expectationFailure "expected Just" it "normalizes case across all labels (Alice.SIMPLEX ≡ alice.simplex for namehash)" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} - let lower = RslvRequest {name = "alice.simplex", contract = addr1} - mixed = RslvRequest {name = "Alice.SIMPLEX", contract = addr1} + env <- mkEnv + let lower = RslvRequest {name = "alice.simplex", contract = simplexContract} + mixed = RslvRequest {name = "Alice.SIMPLEX", contract = simplexContract} case (verifyRslv env lower, verifyRslv env mixed) of (Just (_, dL), Just (_, dM)) -> dL `shouldBe` dM _ -> expectationFailure "both should parse" it "rejects mismatched contract address" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + env <- mkEnv let req = RslvRequest {name = "privacy.simplex", contract = addr2} verifyRslv env req `shouldBe` Nothing - it "rejects TLD with no whitelist entry" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} - let req = RslvRequest {name = "test.testing", contract = addr1} + it "rejects TLD with no whitelist entry (TLDWeb is unmapped)" $ do + env <- mkEnv + let req = RslvRequest {name = "example.web", contract = simplexContract} verifyRslv env req `shouldBe` Nothing - it "accepts via _all fallback" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Nothing, tldTesting = Nothing, tldAll = Just addr3} - let req = RslvRequest {name = "test.testing", contract = addr3} - case verifyRslv env req of - Just (a, _) -> a `shouldBe` addr3 - Nothing -> expectationFailure "expected Just" - it "rejects bare (no-TLD) name (SimplexNameDomain.strP requires TLD)" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} - let req = RslvRequest {name = "privacy", contract = addr1} + env <- mkEnv + let req = RslvRequest {name = "privacy", contract = simplexContract} verifyRslv env req `shouldBe` Nothing it "rejects non-ASCII labels (Cyrillic а homograph would hash to different namehash than ASCII a)" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + env <- mkEnv -- Cyrillic а (U+0430), Greek α (U+03B1), full-width A (U+FF21) for_ ["\1072lice.simplex", "\945pple.simplex", "\65313pple.simplex"] $ \name -> - verifyRslv env RslvRequest {name, contract = addr1} `shouldBe` Nothing + verifyRslv env RslvRequest {name, contract = simplexContract} `shouldBe` Nothing it "rejects oversized inputs (>253 bytes) — bounded parser allocation" $ do - env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + env <- mkEnv let oversize = T.replicate 254 "a" <> ".simplex" - verifyRslv env RslvRequest {name = oversize, contract = addr1} `shouldBe` Nothing + verifyRslv env RslvRequest {name = oversize, contract = simplexContract} `shouldBe` Nothing resolverSpec :: Spec resolverSpec = do - let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} - mkEnv ethCall = newNamesEnvWith (testNamesConfig regs) ethCall Nothing + let mkEnv ethCall = newNamesEnvWith testNamesConfig ethCall Nothing aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} zeroOwnerResponse = Right (B.replicate (32 * 8) '\NUL') From e892344264223ea17a18783b5ba42843cdff7547 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 13:52:59 +0000 Subject: [PATCH 13/15] namespace: implement SNRC getRecord ABI decoder Replaces the placeholder Right Nothing return with a real ABI decoder for the assumed Solidity signature: function getRecord(bytes32 node) external view returns ( string x10 fields, address owner, uint256 expiry ) Layout: 12 head slots (10 string tail offsets, owner address, uint256 expiry) followed by length-prefixed string data in declaration order. Server-side expiry filter (nowSec passed by Names.hs:fetch) keeps the wire NameRecord free of an expiry field. The on-chain value 0 means "never expires" (reserved names); the caller can pass nowSec = 0 to disable the filter in tests. nrResolver is populated from the contract address the server's eth_call was sent to, since the ABI return doesn't carry it. Zero owner remains the NotFound sentinel. Drops the placeholder-warn IORef plumbing that surfaced the stub in logs; the decoder is no longer a stub. Tests that used (32 * 8) sentinel buffers move to (32 * 12) to match the new head size. Adds an encodeRecordAbi helper in SMPNamesTests for end-to-end testing; both RSLVTests and the agent ResolveNameTests reuse it for the success-path tests. If the SNRC contract ships with a different return layout, this decoder will need rework; the placeholder gave a documented MVP unblock until that point. --- src/Simplex/Messaging/Server/Names.hs | 42 +----- .../Messaging/Server/Names/Eth/SNRC.hs | 92 ++++++++++-- tests/AgentTests/ResolveNameTests.hs | 71 +++++++-- tests/RSLVTests.hs | 74 ++++++--- tests/SMPNamesTests.hs | 142 ++++++++++++++++-- 5 files changed, 328 insertions(+), 93 deletions(-) diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index 8c26fdd2d..0f81f9c02 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -26,21 +26,19 @@ module Simplex.Messaging.Server.Names ) where -import Control.Monad (forM_, guard, unless, when) +import Control.Monad (guard) import qualified Control.Exception as E import Control.Logger.Simple (logError) import Data.ByteString.Char8 (ByteString) -import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock.POSIX (getPOSIXTime) import Simplex.Messaging.Encoding.String (strDecode) -import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Protocol (NameOwner, NameRecord, RslvRequest (..), unNameOwner) import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) -import Simplex.Messaging.Server.Names.Eth.SNRC (decodeAddress, decodeGetRecord, encodeGetRecord, isZeroOwner, namehash) +import Simplex.Messaging.Server.Names.Eth.SNRC (decodeGetRecord, encodeGetRecord, namehash) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..), fullDomainName) import Simplex.Messaging.SimplexName.Contracts (tldContract) import System.Timeout (timeout) @@ -69,10 +67,7 @@ type EthCall = ByteString -> ByteString -> IO (Either EthRpcError ByteString) data NamesEnv = NamesEnv { config :: NamesConfig, ethCall :: EthCall, - rpcEnv :: Maybe EthRpcEnv, -- Nothing for test stubs - -- One-shot guard so the placeholder-decoder warning logs once per process, - -- not once per RSLV. - placeholderWarned :: IORef Bool + rpcEnv :: Maybe EthRpcEnv -- Nothing for test stubs } newNamesEnv :: NamesConfig -> IO NamesEnv @@ -82,9 +77,7 @@ newNamesEnv cfg = do -- | Allocate resolver with an injected ethCall (test seam). newNamesEnvWith :: NamesConfig -> EthCall -> Maybe EthRpcEnv -> IO NamesEnv -newNamesEnvWith config ethCall rpcEnv = do - placeholderWarned <- newIORef False - pure NamesEnv {config, ethCall, rpcEnv, placeholderWarned} +newNamesEnvWith config ethCall rpcEnv = pure NamesEnv {config, ethCall, rpcEnv} closeNamesEnv :: NamesEnv -> IO () closeNamesEnv NamesEnv {rpcEnv} = mapM_ closeEthRpcEnv rpcEnv @@ -139,35 +132,14 @@ resolveName env contract d = do pure (Left EthHttpErr) fetch :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) -fetch env@NamesEnv {ethCall} contract d = do +fetch NamesEnv {ethCall} contract d = do nowSec <- floor <$> getPOSIXTime ethCall (unNameOwner contract) (encodeGetRecord (namehash (encodeUtf8 (fullDomainName d)))) >>= \case Left e -> pure (Left (mapEthRpcError e)) - Right ret -> case decodeGetRecord nowSec ret of - Right Nothing -> notFoundWithPlaceholderWarn ret + Right ret -> case decodeGetRecord contract nowSec ret of + Right Nothing -> pure (Left NotFound) Right (Just rec) -> pure (Right rec) Left _ -> pure (Left EthDecodeErr) - where - -- decodeGetRecord is currently a placeholder: it returns Right Nothing - -- for BOTH "zero-owner sentinel" (real NotFound) and "non-zero owner - -- with real data but no ABI decoder yet". Inspect the owner slot - -- directly to distinguish, and surface the latter once per process so - -- an operator who enables [NAMES] against a working SNRC contract sees - -- the resolver is functionally stubbed. Expired records are filtered - -- inside the decoder (using the `nowSec` argument) so the wire - -- NameRecord never carries an expiry field. - notFoundWithPlaceholderWarn ret = do - forM_ (eitherToMaybe (decodeAddress 32 ret)) $ \owner -> - unless (isZeroOwner owner) (warnPlaceholderOnce env) - pure (Left NotFound) - -warnPlaceholderOnce :: NamesEnv -> IO () -warnPlaceholderOnce NamesEnv {placeholderWarned} = do - first <- atomicModifyIORef' placeholderWarned (\w -> (True, not w)) - when first $ - logError - "[NAMES] decodeGetRecord placeholder hit — SNRC ABI codec not finalised; \ - \every non-zero-owner record returns NotFound until the decoder ships" -- | Collapse the JSON-RPC transport-layer error space into the resolver's -- public error space. diff --git a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs index b1ddbea30..480332b0b 100644 --- a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs +++ b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs @@ -46,8 +46,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8') -import Simplex.Messaging.Protocol (NameOwner, NameRecord, mkNameOwner, unNameOwner) +import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), mkNameOwner, unNameOwner) -- | ABI-decode failure modes (caller collapses to ResolveError EthDecodeErr). data AbiError @@ -169,26 +170,89 @@ decodeStringArray depth headEnd off cntCap byteCap buf collectN (i + 1) n base hd (s : acc) -- | Decode the ABI-encoded return value of getRecord(bytes32) into a NameRecord. +-- +-- Assumed Solidity signature: +-- +-- function getRecord(bytes32 node) external view returns ( +-- string name, string nickname, string website, string location, +-- string simplexContact, string simplexChannel, +-- string ETH, string BTC, string XMR, string DOT, +-- address owner, uint256 expiry +-- ) +-- +-- Tuple layout: 12 head slots (32 bytes each) followed by length-prefixed +-- string data in declaration order. Slots 0-9 are string tail offsets +-- (from the start of the buffer, which equals the start of the tuple for +-- a top-level eth_call return), slot 10 is the owner address, slot 11 is +-- the uint256 expiry. +-- -- Zero-owner (0x000...000) is reported as Right Nothing so the caller maps it -- to NotFound (ENS-style sentinel). Records whose on-chain expiry is in the -- past are also reported as Right Nothing — clients trust the server's filter -- and the wire NameRecord carries no expiry field. -- -- `nowSec` is the current Unix time the caller wants the expiry compared --- against. Pass `0` to disable the expiry check. +-- against. Pass `0` to disable the expiry check (test scenarios); on-chain +-- `expiry = 0` means "never expires" (reserved names) and is always accepted. -- --- PLACEHOLDER: returns Right Nothing for any non-zero owner until the Part 1 --- SNRC contract ABI is finalised. All ABI primitives above are production-ready; --- only the field-layout-aware composition (and the expiry slot read) is --- pending. -decodeGetRecord :: Int64 -> ByteString -> Either AbiError (Maybe NameRecord) -decodeGetRecord _nowSec buf - | B.length buf < 32 * 8 = Left AbiTruncated - -- Both arms return Nothing today: the zero-owner branch is the real ENS-style - -- NotFound sentinel; the non-zero branch is the SNRC-ABI placeholder (which - -- will also apply the `_nowSec` expiry filter once the field layout lands). - -- They separate once the field-layout decoder ships. - | otherwise = Nothing <$ decodeAddress 32 buf +-- `resolver` is the SNRC contract address that produced the record (i.e. the +-- address the server's eth_call was sent to), populated into `nrResolver` +-- since the ABI return doesn't carry it. +decodeGetRecord :: NameOwner -> Int64 -> ByteString -> Either AbiError (Maybe NameRecord) +decodeGetRecord resolver nowSec buf + | B.length buf < headEnd = Left AbiTruncated + | otherwise = do + nameOff <- decodeWord256Int64 (slot 0) buf + nicknameOff <- decodeWord256Int64 (slot 1) buf + websiteOff <- decodeWord256Int64 (slot 2) buf + locationOff <- decodeWord256Int64 (slot 3) buf + simplexContactOff <- decodeWord256Int64 (slot 4) buf + simplexChannelOff <- decodeWord256Int64 (slot 5) buf + ethOff <- decodeWord256Int64 (slot 6) buf + btcOff <- decodeWord256Int64 (slot 7) buf + xmrOff <- decodeWord256Int64 (slot 8) buf + dotOff <- decodeWord256Int64 (slot 9) buf + owner <- decodeAddress (slot 10) buf + expiry <- decodeWord256Int64 (slot 11) buf + if isZeroOwner owner || isExpired nowSec expiry + then pure Nothing + else do + nrName <- decodeStr 255 nameOff + nrNickname <- decodeOptStr 255 nicknameOff + nrWebsite <- decodeOptStr 255 websiteOff + nrLocation <- decodeOptStr 255 locationOff + nrSimplexContact <- decodeOptStr 1024 simplexContactOff + nrSimplexChannel <- decodeOptStr 1024 simplexChannelOff + nrEth <- decodeOptStr 255 ethOff + nrBtc <- decodeOptStr 255 btcOff + nrXmr <- decodeOptStr 255 xmrOff + nrDot <- decodeOptStr 255 dotOff + pure $ + Just + NameRecord + { nrName, + nrNickname, + nrWebsite, + nrLocation, + nrSimplexContact, + nrSimplexChannel, + nrEth, + nrBtc, + nrXmr, + nrDot, + nrOwner = owner, + nrResolver = resolver + } + where + headSlots = 12 :: Int + slotSize = 32 :: Int + headEnd = headSlots * slotSize + slot n = n * slotSize + -- on-chain expiry == 0 means "never expires"; nowSec == 0 disables the check. + isExpired now expiry = now /= 0 && expiry /= 0 && expiry < now + decodeStr cap off = decodeUtf8Text headEnd (fromIntegral off) cap buf + decodeOptStr cap off = nullToNothing <$> decodeStr cap off + nullToNothing t = if T.null t then Nothing else Just t isZeroOwner :: NameOwner -> Bool isZeroOwner = (== B.replicate 20 '\NUL') . unNameOwner diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs index bc0285720..5d092063b 100644 --- a/tests/AgentTests/ResolveNameTests.hs +++ b/tests/AgentTests/ResolveNameTests.hs @@ -17,11 +17,6 @@ -- `sendOrProxySMPCommand` so we cover the agent-side direct/proxy selection -- and the agent's error mapping (`SMP host AUTH`, `PROXY {.. proxyErr ..}`, -- `INTERNAL ..`). --- --- The success path is intentionally `pendingWith`: until the SNRC ABI codec --- ships, `decodeGetRecord` collapses every non-malformed buffer to --- `Right Nothing` (NotFound), which the resolver maps to `ERR AUTH`. Re-enable --- the success test when `Server/Names/Eth/SNRC.hs:177-178` returns real records. module AgentTests.ResolveNameTests (resolveNameTests) where import AgentTests.FunctionalAPITests (withAgent) @@ -30,12 +25,13 @@ import qualified Data.ByteString.Char8 as B import Data.List (isInfixOf) import SMPAgentClient import SMPClient +import SMPNamesTests (encodeRecordAbi) import Simplex.Messaging.Agent (resolveSimplexName) import Simplex.Messaging.Agent.Client (AgentClient) import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive) -import Simplex.Messaging.Protocol (pattern SMPServer) +import Simplex.Messaging.Protocol (NameRecord (..), mkNameOwner, pattern SMPServer) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) @@ -50,11 +46,11 @@ import Util (it) -- Fixtures (parallel to RSLVTests) -- --------------------------------------------------------------------------- --- 8 slots * 32 bytes, all zero — placeholder `decodeGetRecord` returns --- `Right Nothing` for the zero-owner sentinel, so the resolver maps to --- `ResolveError.NotFound` -> `ERR AUTH`. +-- 12 slots * 32 bytes, all zero. `decodeGetRecord` reads the owner from +-- slot 10 and treats the zero address as the NotFound sentinel, so the +-- resolver maps to `ResolveError.NotFound` -> server `ERR AUTH`. zeroOwnerAbi :: B.ByteString -zeroOwnerAbi = B.replicate (32 * 8) '\NUL' +zeroOwnerAbi = B.replicate (32 * 12) '\NUL' stubNamesConfig :: NamesConfig stubNamesConfig = @@ -69,12 +65,42 @@ stubNamesConfig = stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) +-- | A complete NameRecord used by the success-path test. The decoder fills +-- `nrResolver` from the contract address the server's ethCall was sent to +-- (i.e. the simplex TLD contract); the test asserts against that value. +aliceRecord :: NameRecord +aliceRecord = + NameRecord + { nrName = "alice.simplex", + nrNickname = Just "Alice", + nrWebsite = Just "https://alice.example", + nrLocation = Just "Earth", + nrSimplexContact = Just "simplex:/contact/abc#xyz", + nrSimplexChannel = Nothing, + nrEth = Just "0x0000000000000000000000000000000000000001", + nrBtc = Nothing, + nrXmr = Nothing, + nrDot = Nothing, + nrOwner = either error id (mkNameOwner (B.replicate 20 '\x33')), + -- Overwritten by the decoder; the placeholder here is never observed. + nrResolver = either error id (mkNameOwner (B.replicate 20 '\xFF')) + } + +-- | Stub returning a valid ABI buffer for the success path (expiry = 0 -> +-- never expires). +stubEthCallSuccess :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) +stubEthCallSuccess _to _data = pure (Right (encodeRecordAbi aliceRecord 0)) + -- | Names env using the static `tldContract` mapping: TLDSimplex and -- TLDTesting map to placeholder contracts; TLDWeb is unmapped and rejected -- by the resolver's `verifyRslv`. mkSimplexOnlyNamesEnv :: IO NamesEnv mkSimplexOnlyNamesEnv = newNamesEnvWith stubNamesConfig stubEthCallNotFound Nothing +-- | Same as `mkSimplexOnlyNamesEnv` but the stub returns a real record. +mkSuccessNamesEnv :: IO NamesEnv +mkSuccessNamesEnv = newNamesEnvWith stubNamesConfig stubEthCallSuccess Nothing + memCfg :: AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) @@ -132,18 +158,15 @@ resolveNameTests :: Spec resolveNameTests = do describe "Agent resolveSimplexName" $ do describe "direct path (SPMNever)" $ - it "AUTH propagates as SMP host AUTH (placeholder decoder -> NotFound)" testDirectAuth + it "AUTH propagates as SMP host AUTH (zero-owner stub -> NotFound)" testDirectAuth describe "proxy path (SPMAlways)" $ it "AUTH from resolver propagates via proxy as SMP AUTH" testProxyAuth describe "TLDTesting path" $ - it "AUTH (placeholder decoder -> NotFound) for TLDTesting too" testUnknownTldOnServer + it "AUTH (zero-owner stub -> NotFound) for TLDTesting too" testUnknownTldOnServer describe "TLD without contract entry" $ it "INTERNAL (TLDWeb has no tldContract entry)" testNoAgentContract describe "success path" $ - it "returns NameRecord" $ - pendingWith - "decodeGetRecord placeholder returns Right Nothing for all non-malformed inputs; \ - \re-enable when SNRC ABI codec ships (Server/Names/Eth/SNRC.hs:177-178)" + it "returns NameRecord" testDirectSuccess -- --------------------------------------------------------------------------- -- Tests @@ -217,3 +240,19 @@ testNoAgentContract = webDomain = SimplexNameDomain TLDWeb "example.com" [] -- Non-empty userServers is required for agent init; never contacted. agentServers = initAgentServers {smp = userServers [testSMPServer]} + +-- | Success path: stub returns a valid ABI buffer, the agent receives a +-- decoded NameRecord. The decoder populates `nrResolver` with the contract +-- the server's ethCall was sent to (i.e. `tldContract TLDSimplex`), so the +-- expected record's resolver is `'\x11'`-bytes (see Contracts.hs). +testDirectSuccess :: HasCallStack => IO () +testDirectSuccess = do + nenv <- mkSuccessNamesEnv + withDirectResolver nenv $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv simplexDomain + case r of + Right nr -> nr `shouldBe` aliceRecord {nrResolver = simplexContract} + _ -> expectationFailure $ "expected Right NameRecord, got: " <> show r + where + simplexDomain = SimplexNameDomain TLDSimplex "alice" [] + simplexContract = either error id (mkNameOwner (B.replicate 20 '\x11')) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 2a4525f0b..0578a9cbd 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -11,16 +11,13 @@ -- | Functional-API tests for the public-namespace resolver (RSLV). -- --- Mocks the resolver at the `ethCall` layer using `newNamesEnvWith`. The --- production `decodeGetRecord` is currently a placeholder that returns --- `Right Nothing` for any non-malformed buffer (see Server/Names/Eth/SNRC.hs); --- consequently the success-path test ("returns NAME with NameRecord") is --- marked `pendingWith` until the SNRC ABI codec ships. Until then we test: +-- Mocks the resolver at the `ethCall` layer using `newNamesEnvWith`. Tests: -- * direct RSLV (post-`ecd89cf1`) is accepted (not `CMD PROHIBITED`) -- * `ERR AUTH` for contract / TLD config mismatches (verifyRslv layer) --- * `ERR AUTH` for backend `NotFound` (placeholder decoder always hits this) +-- * `ERR AUTH` for backend `NotFound` (zero-owner sentinel) -- * `ERR AUTH` for backend transport errors -- * `ERR AUTH` when the server has no `namesEnv` (rslvDisabled) +-- * `NAME` returned when the ABI buffer decodes to a real record -- * the same paths via PFWD round-trip (proxy + resolver wiring works) module RSLVTests (rslvTests) where @@ -31,6 +28,7 @@ import Data.Time.Clock (getCurrentTime) import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C +import SMPNamesTests (encodeRecordAbi) import Simplex.Messaging.Protocol ( BrokerMsg (..), Cmd (..), @@ -38,6 +36,7 @@ import Simplex.Messaging.Protocol CorrId (..), ErrorType (..), NameOwner, + NameRecord (..), RslvRequest (..), SParty (..), Transmission, @@ -77,10 +76,10 @@ serverContract = unsafeOwner (B.replicate 20 '\x11') otherContract :: NameOwner otherContract = unsafeOwner (B.replicate 20 '\x22') --- 8 slots × 32 bytes, all zero — `decodeGetRecord` treats slot 1 (owner) as --- the zero sentinel and returns `Right Nothing` → resolver maps to NotFound. +-- 12 slots * 32 bytes, all zero — `decodeGetRecord` treats slot 10 (owner) as +-- the zero sentinel and returns `Right Nothing` -> resolver maps to NotFound. zeroOwnerAbi :: B.ByteString -zeroOwnerAbi = B.replicate (32 * 8) '\NUL' +zeroOwnerAbi = B.replicate (32 * 12) '\NUL' stubNamesConfig :: NamesConfig stubNamesConfig = @@ -92,8 +91,9 @@ stubNamesConfig = rpcMaxConcurrency = 4 } --- | Default stub: returns the all-zero ABI buffer. With the placeholder --- decoder this collapses every lookup to `ResolveError.NotFound` → AUTH. +-- | Default stub: returns the all-zero ABI buffer. The decoder treats the +-- zero owner address as the NotFound sentinel -> resolver returns +-- `ResolveError.NotFound` -> server `ERR AUTH`. stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) @@ -105,6 +105,32 @@ stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) stubEthCallHttpErr :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) stubEthCallHttpErr _to _data = pure (Left BodyTooLarge) +-- | Stub that returns a valid ABI buffer for the success-path test. The +-- buffer encodes `aliceRecord` with no expiry (0 = never expires); the +-- decoder fills in `nrResolver` from the caller's contract argument, so the +-- test asserts on a record where `nrResolver = serverContract`. +aliceRecord :: NameRecord +aliceRecord = + NameRecord + { nrName = "alice.simplex", + nrNickname = Just "Alice", + nrWebsite = Just "https://alice.example", + nrLocation = Just "Earth", + nrSimplexContact = Just "simplex:/contact/abc#xyz", + nrSimplexChannel = Nothing, + nrEth = Just "0x0000000000000000000000000000000000000001", + nrBtc = Nothing, + nrXmr = Nothing, + nrDot = Nothing, + nrOwner = unsafeOwner (B.replicate 20 '\x33'), + -- Will be overwritten by the decoder using the contract address the + -- server's ethCall was sent to (i.e. `serverContract`). + nrResolver = unsafeOwner (B.replicate 20 '\xFF') + } + +stubEthCallSuccess :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) +stubEthCallSuccess _to _data = pure (Right (encodeRecordAbi aliceRecord 0)) + -- | Names env using the static TLD->contract mapping in -- `SimplexName.Contracts.tldContract`: TLDSimplex maps to `serverContract`, -- TLDTesting to a different placeholder, and TLDWeb is unmapped (rejected @@ -169,16 +195,13 @@ rslvTests = do it "server accepts RSLV without PFWD (not CMD PROHIBITED)" testRslvDirectAccepted it "AUTH when contract address does not match TLD config" testRslvWrongContract it "AUTH when TLD has no contract configured" testRslvUnknownTld - it "AUTH when backend reports zero owner (NotFound via placeholder decoder)" testRslvBackendNotFound + it "AUTH when backend reports zero owner (NotFound via decoder)" testRslvBackendNotFound it "AUTH when backend transport fails (EthHttpErr)" testRslvBackendHttpErr it "AUTH when server has no names config (namesEnv = Nothing)" testRslvDisabled describe "RSLV forwarded (PFWD)" $ do it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError AUTH)" testRslvForwarded describe "RSLV success path (NAME response)" $ do - it "returns NAME with NameRecord" $ - pendingWith - "decodeGetRecord placeholder returns Right Nothing for all non-malformed inputs; \ - \re-enable when SNRC ABI codec ships (Server/Names/Eth/SNRC.hs:177-178)" + it "returns NAME with NameRecord" testRslvSuccess -- --- direct path ----------------------------------------------------------- @@ -188,9 +211,9 @@ testRslvDirectAccepted = do withResolverServer nenv $ testSMPClient @TLS $ \h -> do (corrId, _entId, resp) <- sendRslv h "rs01" RslvRequest {name = "alice.simplex", contract = serverContract} - -- Placeholder decoder collapses zero-owner buffer to NotFound -> AUTH. - -- The point of this test is that the server accepted RSLV at all - -- (CMD PROHIBITED would mean the no-PFWD path was rejected). + -- Zero-owner stub buffer -> NotFound -> AUTH. The point of this test + -- is that the server accepted RSLV at all (CMD PROHIBITED would mean + -- the no-PFWD path was rejected). corrId `shouldBe` CorrId "rs01" resp `shouldBe` Right (ERR AUTH) @@ -262,5 +285,18 @@ testRslvForwarded = do Left (PCEProtocolError SMP.AUTH) -> pure () _ -> expectationFailure $ "expected Left (PCEProtocolError AUTH), got: " <> show r +-- --- success path ---------------------------------------------------------- + +testRslvSuccess :: IO () +testRslvSuccess = do + nenv <- mkSimplexOnlyNamesEnv stubEthCallSuccess + withResolverServer nenv $ + testSMPClient @TLS $ \h -> do + (corrId, _entId, resp) <- sendRslv h "rs07" RslvRequest {name = "alice.simplex", contract = serverContract} + corrId `shouldBe` CorrId "rs07" + case resp of + Right (NAME nr) -> nr `shouldBe` aliceRecord {nrResolver = serverContract} + _ -> expectationFailure $ "expected Right (NAME ..), got: " <> show resp + runExceptT' :: Show e => ExceptT e IO a -> IO a runExceptT' a = runExceptT a >>= either (fail . show) pure diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index c9c362677..4d48d237b 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -3,17 +3,22 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module SMPNamesTests (smpNamesTests) where +module SMPNamesTests (smpNamesTests, encodeRecordAbi) where import qualified Crypto.Hash as Crypton +import Data.Bits (shiftR, (.&.)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteArray as BA import Data.Either (isLeft, isRight) import Data.Foldable (for_) +import Data.Int (Int64) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (sort) +import Data.Maybe (fromMaybe) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word8) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LB import Simplex.Messaging.Protocol @@ -117,6 +122,7 @@ smpNamesTests = do describe "Keccak-256 and namehash" namehashSpec describe "ABI primitive bounds" abiBoundsSpec describe "decodeGetRecord (zero-owner sentinel)" zeroOwnerSpec + describe "decodeGetRecord (record + expiry)" decodeGetRecordSpec describe "TLD whitelist + RSLV verification" tldWhitelistSpec describe "Resolver" resolverSpec @@ -276,13 +282,131 @@ abiBoundsSpec = do zeroOwnerSpec :: Spec zeroOwnerSpec = do it "decodeGetRecord returns Nothing for zero-owner buffer" $ do - -- 8 slots × 32 bytes; owner at slot 1 (offset 32) is all-zero by construction - let buf = B.replicate (32 * 8) '\NUL' - decodeGetRecord 0 buf `shouldBe` Right Nothing - - it "decodeGetRecord fails on truncated buffer" $ do - let tiny = B.replicate 31 '\NUL' - decodeGetRecord 0 tiny `shouldBe` Left AbiTruncated + -- 12 slots * 32 bytes; owner at slot 10 is all-zero by construction + let buf = B.replicate (32 * 12) '\NUL' + decodeGetRecord addr1 0 buf `shouldBe` Right Nothing + + it "decodeGetRecord fails on truncated buffer (< 12 head slots)" $ do + let tiny = B.replicate (32 * 11) '\NUL' + decodeGetRecord addr1 0 tiny `shouldBe` Left AbiTruncated + +decodeGetRecordSpec :: Spec +decodeGetRecordSpec = do + it "decodes a full record with all optional fields populated" $ do + let buf = encodeRecordAbi sampleRecord 0 + case decodeGetRecord (nrResolver sampleRecord) 0 buf of + Right (Just r) -> r `shouldBe` sampleRecord + other -> expectationFailure $ "expected Just sampleRecord, got: " <> show other + + it "decodes a minimal record (empty optional strings -> Nothing)" $ do + -- Empty strings in the ABI should map to Nothing for optional fields. + let minimal = + sampleRecord + { nrNickname = Nothing, + nrWebsite = Nothing, + nrLocation = Nothing, + nrSimplexContact = Nothing, + nrSimplexChannel = Nothing, + nrEth = Nothing, + nrBtc = Nothing, + nrXmr = Nothing, + nrDot = Nothing + } + buf = encodeRecordAbi minimal 0 + decodeGetRecord (nrResolver minimal) 0 buf `shouldBe` Right (Just minimal) + + it "preserves resolver address passed in (not derived from buffer)" $ do + let buf = encodeRecordAbi sampleRecord 0 + case decodeGetRecord addr2 0 buf of + Right (Just r) -> nrResolver r `shouldBe` addr2 + other -> expectationFailure $ "expected Just .. with resolver=addr2, got: " <> show other + + it "returns Nothing for expired record (expiry < nowSec, both non-zero)" $ do + let buf = encodeRecordAbi sampleRecord 1000 + -- nowSec = 2000 > expiry = 1000 -> expired + decodeGetRecord testResolver 2000 buf `shouldBe` Right Nothing + + it "returns Just for non-expired record (expiry > nowSec)" $ do + let buf = encodeRecordAbi sampleRecord 5000 + case decodeGetRecord testResolver 2000 buf of + Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} + other -> expectationFailure $ "expected Just, got: " <> show other + + it "returns Just for expiry == 0 (never expires) even when nowSec is large" $ do + let buf = encodeRecordAbi sampleRecord 0 + case decodeGetRecord testResolver maxBound buf of + Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} + other -> expectationFailure $ "expected Just (expiry=0 is never-expires), got: " <> show other + + it "returns Just when nowSec == 0 (expiry check disabled) even if expiry is in the past" $ do + let buf = encodeRecordAbi sampleRecord 1 + case decodeGetRecord testResolver 0 buf of + Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} + other -> expectationFailure $ "expected Just (nowSec=0 disables check), got: " <> show other + where + testResolver = nrResolver sampleRecord + +-- | Build a valid ABI-encoded tuple of (string x10, address, uint256) for tests. +-- HEAD: 12 slots of 32 bytes each. Slots 0-9 are tail offsets for the 10 +-- string fields in declaration order (name, nickname, website, location, +-- simplex.contact, simplex.channel, ETH, BTC, XMR, DOT); slot 10 is the +-- owner address; slot 11 is the uint256 expiry. TAIL: each string is +-- length-prefixed (32-byte big-endian length) and padded to a 32-byte +-- boundary. Missing optional fields (Nothing) encode as empty strings. +encodeRecordAbi :: NameRecord -> Int64 -> ByteString +encodeRecordAbi r expiry = + let headSize = 12 * 32 + strs = + [ encodeUtf8 (nrName r), + encodeUtf8 (fromMaybe "" (nrNickname r)), + encodeUtf8 (fromMaybe "" (nrWebsite r)), + encodeUtf8 (fromMaybe "" (nrLocation r)), + encodeUtf8 (fromMaybe "" (nrSimplexContact r)), + encodeUtf8 (fromMaybe "" (nrSimplexChannel r)), + encodeUtf8 (fromMaybe "" (nrEth r)), + encodeUtf8 (fromMaybe "" (nrBtc r)), + encodeUtf8 (fromMaybe "" (nrXmr r)), + encodeUtf8 (fromMaybe "" (nrDot r)) + ] + -- offsets of each string-tail body from start of buffer + offsets = scanl (\o s -> o + encodedStringSize s) headSize strs + stringOffsets = take 10 offsets + headBytes = + B.concat (map (encodeWord256 . fromIntegral) stringOffsets) + <> encodeAddressSlot (nrOwner r) + <> encodeWord256 (fromIntegral expiry) + tailBytes = B.concat (map encodeStringTail strs) + in headBytes <> tailBytes + +-- | Length-prefix + 32-byte padding for a single ABI string body. +encodeStringTail :: ByteString -> ByteString +encodeStringTail s = + let len = B.length s + pad = (32 - (len `mod` 32)) `mod` 32 + in encodeWord256 (fromIntegral len) <> s <> B.replicate pad '\NUL' + +encodedStringSize :: ByteString -> Int +encodedStringSize s = + let len = B.length s + pad = (32 - (len `mod` 32)) `mod` 32 + in 32 + len + pad + +-- | 20-byte address padded to 32 bytes (12 zero bytes then 20 address bytes). +encodeAddressSlot :: NameOwner -> ByteString +encodeAddressSlot owner = B.replicate 12 '\NUL' <> unNameOwner owner + +-- | uint256 big-endian over a non-negative Int64; high 24 bytes are zero +-- (the production decoder rejects buffers with any non-zero high bytes, +-- which is exactly what we want for non-overflowing test values). +encodeWord256 :: Int64 -> ByteString +encodeWord256 n + | n < 0 = error "encodeWord256: negative value" + | otherwise = B.replicate 24 '\NUL' <> B.pack (map byteAt [56, 48, 40, 32, 24, 16, 8, 0]) + where + byteAt :: Int -> Char + byteAt shift = + let b = fromIntegral (n `shiftR` shift) .&. 0xFF :: Word8 + in toEnum (fromIntegral b) tldWhitelistSpec :: Spec tldWhitelistSpec = do @@ -343,7 +467,7 @@ resolverSpec :: Spec resolverSpec = do let mkEnv ethCall = newNamesEnvWith testNamesConfig ethCall Nothing aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} - zeroOwnerResponse = Right (B.replicate (32 * 8) '\NUL') + zeroOwnerResponse = Right (B.replicate (32 * 12) '\NUL') it "maps stub zero-owner response to NotFound" $ do env <- mkEnv (\_ _ -> pure zeroOwnerResponse) From c9c2d19074a809ba505f393b41aa20ac7b437aa7 Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 5 Jun 2026 15:31:05 +0000 Subject: [PATCH 14/15] namespace: extract NameRecord and NameOwner to dedicated modules The hand-rolled NameRecord ToJSON instance produced alphabetical keys (via Aeson's KeyMap canonicalisation), while the hand-rolled toEncoding preserved spec declaration order. The two paths were independent code and could drift on the field set as well, silently breaking the "byte-identical canonical encoding" requirement on the wire path. Top-level TH-splice in Protocol.hs is blocked by dense forward refs between the NameRecord declaration (~line 780) and BrokerMsg's NAME constructor (~line 880). Extract NameRecord and NameOwner into two new self-contained modules that support TH cleanly, alongside the existing Simplex.Messaging.SimplexName tree. NameRecord's ToJSON is now TH-derived with a custom fieldLabelModifier covering dot-keys (simplex.contact / simplex.channel) and uppercase coin keys (ETH/BTC/XMR/DOT). omitNothingFields is set to False to preserve the previous wire shape (absent optionals emitted as JSON `null`). FromJSON stays hand-rolled to enforce per-field UTF-8 byte-length caps that TH cannot express. Note: the canonical Value-encoding path (J.encode . J.toJSON) still re-emits keys alphabetically because Aeson's KeyMap is internally sorted; only the wire path (J.encode -> toEncoding) preserves the spec order, and only that path is part of the protocol contract. The new "toJSON and toEncoding agree on the field set" test pins the no-drift-on-field-set invariant for future edits. Protocol.hs re-exports both types so downstream callers are unchanged. --- simplexmq.cabal | 2 + src/Simplex/Messaging/Names/Owner.hs | 46 ++++++++ src/Simplex/Messaging/Names/Record.hs | 91 ++++++++++++++ src/Simplex/Messaging/Protocol.hs | 111 +----------------- .../Messaging/SimplexName/Contracts.hs | 2 +- tests/SMPNamesTests.hs | 22 +++- 6 files changed, 163 insertions(+), 111 deletions(-) create mode 100644 src/Simplex/Messaging/Names/Owner.hs create mode 100644 src/Simplex/Messaging/Names/Record.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index fa85dc0cd..01fa027ce 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -130,6 +130,8 @@ library Simplex.Messaging.Crypto.ShortLink Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String + Simplex.Messaging.Names.Owner + Simplex.Messaging.Names.Record Simplex.Messaging.Notifications.Client Simplex.Messaging.Notifications.Protocol Simplex.Messaging.Notifications.Transport diff --git a/src/Simplex/Messaging/Names/Owner.hs b/src/Simplex/Messaging/Names/Owner.hs new file mode 100644 index 000000000..5c5bfdd3f --- /dev/null +++ b/src/Simplex/Messaging/Names/Owner.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +module Simplex.Messaging.Names.Owner + ( NameOwner, + mkNameOwner, + unNameOwner, + ) +where + +import Control.Applicative ((<|>)) +import qualified Data.Aeson as J +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) + +-- | 20-byte Ethereum address (NameRecord owner). Bare constructor not exported; +-- use `mkNameOwner` to enforce the 20-byte invariant. +newtype NameOwner = NameOwner ByteString + deriving (Eq) + +-- Render the 20 raw bytes as "0x"-prefixed lowercase hex so log lines / +-- traceShow output match the on-the-wire JSON form instead of Latin-1 garbage. +instance Show NameOwner where + show (NameOwner bs) = "NameOwner 0x" <> B.unpack (BAE.convertToBase BAE.Base16 bs) + +mkNameOwner :: ByteString -> Either String NameOwner +mkNameOwner bs + | B.length bs == 20 = Right (NameOwner bs) + | otherwise = Left "NameOwner must be 20 bytes" + +unNameOwner :: NameOwner -> ByteString +unNameOwner (NameOwner bs) = bs +{-# INLINE unNameOwner #-} + +instance J.ToJSON NameOwner where + toJSON (NameOwner bs) = J.String $ "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) + +instance J.FromJSON NameOwner where + parseJSON = J.withText "NameOwner" $ \t -> do + -- Accept "0x" and "0X" prefixes (matches the Server-side hex decoder). + let hex = fromMaybe t (T.stripPrefix "0x" t <|> T.stripPrefix "0X" t) + either fail pure $ BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) >>= mkNameOwner diff --git a/src/Simplex/Messaging/Names/Record.hs b/src/Simplex/Messaging/Names/Record.hs new file mode 100644 index 000000000..68a40111b --- /dev/null +++ b/src/Simplex/Messaging/Names/Record.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Names.Record + ( NameRecord (..), + ) +where + +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Simplex.Messaging.Names.Owner (NameOwner) +import Simplex.Messaging.Parsers (defaultJSON) + +-- | Resolved name record returned by the names role. +-- Wire format is JSON — change requires an SMP version bump. +-- JSON keys match the Python resolver (PR #1795 `snrc-resolve.py`) so the +-- same server can be backed by either the direct-ETH-RPC resolver or the +-- Python REST resolver without changing the wire format clients see. +data NameRecord = NameRecord + { nrName :: Text, + nrNickname :: Maybe Text, + nrWebsite :: Maybe Text, + nrLocation :: Maybe Text, + nrSimplexContact :: Maybe Text, + nrSimplexChannel :: Maybe Text, + nrEth :: Maybe Text, + nrBtc :: Maybe Text, + nrXmr :: Maybe Text, + nrDot :: Maybe Text, + nrOwner :: NameOwner, + nrResolver :: NameOwner -- SNRC contract address that produced the record + } + deriving (Eq, Show) + +-- ToJSON / toEncoding are TH-derived from a single Options value so both Aeson +-- paths emit byte-identical output in declaration order. The default +-- fieldLabelModifier cannot express dot-keys ("simplex.contact", +-- "simplex.channel") or uppercase coin keys ("ETH", "BTC", "XMR", "DOT"). +-- omitNothingFields is set to False to preserve the previous hand-rolled +-- shape (absent optionals emitted as JSON `null`); FromJSON tolerates both +-- missing and null keys for forward-compat with sparse Python output. +-- Options inlined at the splice site because TH stage restriction forbids a +-- module-local helper. +$( JQ.deriveToJSON + defaultJSON + { J.omitNothingFields = False, + J.fieldLabelModifier = \case + "nrName" -> "name" + "nrNickname" -> "nickname" + "nrWebsite" -> "website" + "nrLocation" -> "location" + "nrSimplexContact" -> "simplex.contact" + "nrSimplexChannel" -> "simplex.channel" + "nrEth" -> "ETH" + "nrBtc" -> "BTC" + "nrXmr" -> "XMR" + "nrDot" -> "DOT" + "nrOwner" -> "owner" + "nrResolver" -> "resolver" + s -> s + } + ''NameRecord + ) + +-- FromJSON is hand-rolled to enforce per-field UTF-8 byte-length caps that the +-- TH derivation cannot express. +instance J.FromJSON NameRecord where + parseJSON = J.withObject "NameRecord" $ \o -> do + nrName <- o J..: "name" >>= capUtf8 "name" 255 + nrNickname <- o J..:? "nickname" >>= traverse (capUtf8 "nickname" 255) + nrWebsite <- o J..:? "website" >>= traverse (capUtf8 "website" 255) + nrLocation <- o J..:? "location" >>= traverse (capUtf8 "location" 255) + nrSimplexContact <- o J..:? "simplex.contact" >>= traverse (capUtf8 "simplex.contact" 1024) + nrSimplexChannel <- o J..:? "simplex.channel" >>= traverse (capUtf8 "simplex.channel" 1024) + nrEth <- o J..:? "ETH" >>= traverse (capUtf8 "ETH" 255) + nrBtc <- o J..:? "BTC" >>= traverse (capUtf8 "BTC" 255) + nrXmr <- o J..:? "XMR" >>= traverse (capUtf8 "XMR" 255) + nrDot <- o J..:? "DOT" >>= traverse (capUtf8 "DOT" 255) + nrOwner <- o J..: "owner" + nrResolver <- o J..: "resolver" + pure NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} + where + capUtf8 fld lim t + | B.length (encodeUtf8 t) <= lim = pure t + | otherwise = fail $ fld <> " exceeds " <> show lim <> " bytes UTF-8" diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 42d1174b9..83204ccf1 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -243,7 +243,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteArray.Encoding as BAE import qualified Data.ByteString.Lazy as LB import Data.Char (isPrint, isSpace) import Data.Constraint (Dict (..)) @@ -253,7 +252,7 @@ import Data.Kind import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Maybe (isJust, isNothing) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -270,6 +269,8 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (. import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Names.Owner (NameOwner, mkNameOwner, unNameOwner) +import Simplex.Messaging.Names.Record (NameRecord (..)) import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.QueueStore.QueueInfo @@ -733,34 +734,6 @@ instance Encoding FwdTransmission where newtype EncFwdTransmission = EncFwdTransmission ByteString deriving (Show) --- | 20-byte Ethereum address (NameRecord owner). Bare constructor not exported; --- use `mkNameOwner` to enforce the 20-byte invariant. -newtype NameOwner = NameOwner ByteString - deriving (Eq) - --- Render the 20 raw bytes as "0x"-prefixed lowercase hex so log lines / --- traceShow output match the on-the-wire JSON form instead of Latin-1 garbage. -instance Show NameOwner where - show (NameOwner bs) = "NameOwner 0x" <> B.unpack (BAE.convertToBase BAE.Base16 bs) - -mkNameOwner :: ByteString -> Either String NameOwner -mkNameOwner bs - | B.length bs == 20 = Right (NameOwner bs) - | otherwise = Left "NameOwner must be 20 bytes" - -unNameOwner :: NameOwner -> ByteString -unNameOwner (NameOwner bs) = bs -{-# INLINE unNameOwner #-} - -instance J.ToJSON NameOwner where - toJSON (NameOwner bs) = J.String $ "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) - -instance J.FromJSON NameOwner where - parseJSON = J.withText "NameOwner" $ \t -> do - -- Accept "0x" and "0X" prefixes (matches the Server-side hex decoder). - let hex = fromMaybe t (T.stripPrefix "0x" t <|> T.stripPrefix "0X" t) - either fail pure $ BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) >>= mkNameOwner - instance J.ToJSON RslvRequest where toJSON RslvRequest {name, contract} = J.object ["name" J..= name, "contract" J..= contract] toEncoding RslvRequest {name, contract} = J.pairs ("name" J..= name <> "contract" J..= contract) @@ -771,84 +744,6 @@ instance J.FromJSON RslvRequest where contract <- o J..: "contract" pure RslvRequest {name, contract} --- | Resolved name record returned by the names role. --- Wire format is JSON — change requires an SMP version bump. --- JSON keys match the Python resolver (PR #1795 `snrc-resolve.py`) so the --- same server can be backed by either the direct-ETH-RPC resolver or the --- Python REST resolver without changing the wire format clients see. -data NameRecord = NameRecord - { nrName :: Text, - nrNickname :: Maybe Text, - nrWebsite :: Maybe Text, - nrLocation :: Maybe Text, - nrSimplexContact :: Maybe Text, - nrSimplexChannel :: Maybe Text, - nrEth :: Maybe Text, - nrBtc :: Maybe Text, - nrXmr :: Maybe Text, - nrDot :: Maybe Text, - nrOwner :: NameOwner, - nrResolver :: NameOwner -- SNRC contract address that produced the record - } - deriving (Eq, Show) - --- Hand-rolled JSON instances: dot-keys ("simplex.contact", "simplex.channel") --- and uppercase coin keys ("ETH", "BTC", "XMR", "DOT") fall outside Aeson TH's --- field-label conventions. -instance J.ToJSON NameRecord where - toJSON NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} = - J.object - [ "name" J..= nrName, - "nickname" J..= nrNickname, - "website" J..= nrWebsite, - "location" J..= nrLocation, - "simplex.contact" J..= nrSimplexContact, - "simplex.channel" J..= nrSimplexChannel, - "ETH" J..= nrEth, - "BTC" J..= nrBtc, - "XMR" J..= nrXmr, - "DOT" J..= nrDot, - "owner" J..= nrOwner, - "resolver" J..= nrResolver - ] - -- explicit toEncoding to preserve the spec-documented key order; the default - -- routes through Value/KeyMap and re-emits keys alphabetically, breaking the - -- "two routers MUST emit byte-identical JSON" requirement. - toEncoding NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} = - J.pairs $ - "name" J..= nrName - <> "nickname" J..= nrNickname - <> "website" J..= nrWebsite - <> "location" J..= nrLocation - <> "simplex.contact" J..= nrSimplexContact - <> "simplex.channel" J..= nrSimplexChannel - <> "ETH" J..= nrEth - <> "BTC" J..= nrBtc - <> "XMR" J..= nrXmr - <> "DOT" J..= nrDot - <> "owner" J..= nrOwner - <> "resolver" J..= nrResolver - -instance J.FromJSON NameRecord where - parseJSON = J.withObject "NameRecord" $ \o -> do - nrName <- o J..: "name" >>= capUtf8 "name" 255 - nrNickname <- o J..:? "nickname" >>= traverse (capUtf8 "nickname" 255) - nrWebsite <- o J..:? "website" >>= traverse (capUtf8 "website" 255) - nrLocation <- o J..:? "location" >>= traverse (capUtf8 "location" 255) - nrSimplexContact <- o J..:? "simplex.contact" >>= traverse (capUtf8 "simplex.contact" 1024) - nrSimplexChannel <- o J..:? "simplex.channel" >>= traverse (capUtf8 "simplex.channel" 1024) - nrEth <- o J..:? "ETH" >>= traverse (capUtf8 "ETH" 255) - nrBtc <- o J..:? "BTC" >>= traverse (capUtf8 "BTC" 255) - nrXmr <- o J..:? "XMR" >>= traverse (capUtf8 "XMR" 255) - nrDot <- o J..:? "DOT" >>= traverse (capUtf8 "DOT" 255) - nrOwner <- o J..: "owner" - nrResolver <- o J..: "resolver" - pure NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} - where - capUtf8 fld lim t - | B.length (encodeUtf8 t) <= lim = pure t - | otherwise = fail $ fld <> " exceeds " <> show lim <> " bytes UTF-8" - data BrokerMsg where -- SMP broker messages (responses, client messages, notifications) IDS :: QueueIdsKeys -> BrokerMsg diff --git a/src/Simplex/Messaging/SimplexName/Contracts.hs b/src/Simplex/Messaging/SimplexName/Contracts.hs index 94075abce..0b6275d63 100644 --- a/src/Simplex/Messaging/SimplexName/Contracts.hs +++ b/src/Simplex/Messaging/SimplexName/Contracts.hs @@ -12,7 +12,7 @@ module Simplex.Messaging.SimplexName.Contracts where import qualified Data.ByteString.Char8 as B -import Simplex.Messaging.Protocol (NameOwner, mkNameOwner) +import Simplex.Messaging.Names.Owner (NameOwner, mkNameOwner) import Simplex.Messaging.SimplexName (SimplexTLD (..)) -- | Map a TLD to its SNRC contract address. `Nothing` means the TLD has diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 4d48d237b..30c177881 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -20,6 +20,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as LB import Simplex.Messaging.Protocol ( NameOwner, @@ -132,8 +133,11 @@ nameRecordEncodingSpec = do J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord)) `shouldBe` Right sampleRecord it "emits keys in spec-documented order (Python resolver shape)" $ do - -- Default toEncoding routes through Value/KeyMap and re-emits keys - -- alphabetically; spec requires byte-identical canonical encoding. + -- The wire encoding (J.encode -> toEncoding) MUST keep keys in spec + -- declaration order so resolvers in different runtimes emit + -- byte-identical JSON. Routing the same record through + -- J.encode . J.toJSON re-emits keys alphabetically (Aeson canonicalises + -- via KeyMap); that path is NOT the wire format. let bytes = LB.toStrict (J.encode sampleRecord) offset k = B.length (fst (B.breakSubstring k bytes)) offsets = @@ -154,6 +158,20 @@ nameRecordEncodingSpec = do ] offsets `shouldBe` sort offsets + it "toJSON and toEncoding agree on the field set (no divergence between paths)" $ do + -- The previous hand-rolled instance had a subtle divergence: toJSON + -- and toEncoding were two independent code paths and could drift on + -- which optional fields they emit. TH-deriving both from a single + -- Options value forecloses that. Order still differs (toJSON goes + -- through KeyMap, alphabetical), but the set of emitted keys MUST + -- match. + let objectKeys v = case v of + J.Object o -> sort (KM.keys o) + _ -> error "expected JSON object" + viaToJSON = objectKeys (J.toJSON sampleRecord) + viaEncode = either error objectKeys (J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord))) + viaToJSON `shouldBe` viaEncode + it "tolerates absent optional keys (forward-compat with sparse Python output)" $ do let minimal = "{\"name\":\"a.simplex\"," From 452e28330d1a193264653b30c7716e747d07329b Mon Sep 17 00:00:00 2001 From: shum Date: Mon, 8 Jun 2026 11:26:25 +0000 Subject: [PATCH 15/15] namespace: switch SMP server names backend to Python HTTP resolver MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the direct Ethereum JSON-RPC eth_call flow with HTTP calls to the snrc-resolve.py REST resolver (PR #1795). The Python service owns the on-chain registry mapping per TLD; the SMP server forwards each RSLV as `GET /resolve/` and parses the JSON response as a NameRecord. Wire-format changes (no SMP version bump): * RslvRequest.contract is now parsed but ignored server-side. The wire field is retained for forward compatibility with possible future eth-backed implementations. The agent sends a zero-address placeholder. * NameRecord JSON keys match the Python resolver exactly: lowercase camelCase (simplexContact / simplexChannel) and lowercase coin keys (eth/btc/xmr/dot). Text fields use the empty string `""` as the unset sentinel; coin fields use JSON null. Module changes: * New: Simplex.Messaging.Server.Names.HttpResolver — http-client + redirect-disabled GET, body cap, optional Authorization header, scrubUrl extracted from the old eth/RPC module. * Rewritten: Simplex.Messaging.Server.Names — HTTP backend with a ResolverCall test seam (replaces EthCall); ResolverCallKind tags fetch vs health probe so tests can assert routing. 404/400 map to NotFound; 5xx and transport failures map to ResolverError; decode errors to ResolverDecodeErr. parseName replaces verifyRslv (no more contract whitelist). * Deleted: Simplex.Messaging.Server.Names.Eth.{RPC,SNRC} and Simplex.Messaging.SimplexName.Contracts — the ABI decoder, the Keccak namehash, and the TLD->contract whitelist are all owned by the Python resolver now. Server-side flow: * Server.hs's RSLV handler: parseName (instead of verifyRslv) + a single resolveName call (no contract argument). * Env/STM.hs: pingEndpoint now hits `GET /health` (200 OK = ready). * Main.hs INI keys renamed from `ethereum_endpoint` / `rpc_*` to `resolver_endpoint` / `resolver_*`. Dropped `rpc_max_concurrency` (http-client manages its own pool). Default `resolver_max_response_bytes` lowered to 65536 (the Python resolver's responses are ~2 KB; the previous 262144 was sized for ABI-encoded blobs). validateUrl SSRF hardening is preserved verbatim, only error messages and INI key names changed. Agent side: * resolveSimplexName' no longer consults `tldContract`; it passes a zero-address placeholder as RslvRequest.contract. The agent's public API is unchanged. Spec doc updates: * Backing store section: reference implementation forwards RSLV to the Python REST resolver; alternatives are valid as long as they expose the same HTTP shape or substitute a different transport. * RslvRequest.contract documented as ignored / reserved. * NameRecord field table updated: simplexContact (was simplex.contact), eth/btc/xmr/dot (was ETH/BTC/XMR/DOT), Text fields use empty string when unset (was nullable). Tests: * SMPNamesTests.hs: ABI decoder tests deleted; HTTP resolver tests added (success, 404, 400, 502, transport failure, malformed JSON, non-NameRecord JSON, health probe routing). 31 examples. * RSLVTests.hs and AgentTests/ResolveNameTests.hs: switched from the eth-call stub to the resolver-call stub. The old INTERNAL "no resolver contract for TLD" branch is gone — TLDWeb now reaches the server and the resolver decides whether to honour it. --- protocol/simplex-messaging.md | 76 +-- simplexmq.cabal | 4 +- src/Simplex/Messaging/Agent.hs | 12 +- src/Simplex/Messaging/Names/Record.hs | 73 +-- src/Simplex/Messaging/Server.hs | 6 +- src/Simplex/Messaging/Server/Env/STM.hs | 4 +- src/Simplex/Messaging/Server/Main.hs | 47 +- src/Simplex/Messaging/Server/Main/Init.hs | 21 +- src/Simplex/Messaging/Server/Names.hs | 213 +++---- src/Simplex/Messaging/Server/Names/Eth/RPC.hs | 200 ------ .../Messaging/Server/Names/Eth/SNRC.hs | 258 -------- .../Messaging/Server/Names/HttpResolver.hs | 164 +++++ .../Messaging/SimplexName/Contracts.hs | 30 - tests/AgentTests/ResolveNameTests.hs | 179 ++---- tests/RSLVTests.hs | 191 ++---- tests/SMPNamesTests.hs | 567 ++++++------------ 16 files changed, 683 insertions(+), 1362 deletions(-) delete mode 100644 src/Simplex/Messaging/Server/Names/Eth/RPC.hs delete mode 100644 src/Simplex/Messaging/Server/Names/Eth/SNRC.hs create mode 100644 src/Simplex/Messaging/Server/Names/HttpResolver.hs delete mode 100644 src/Simplex/Messaging/SimplexName/Contracts.hs diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index 6623f7159..293721ece 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -428,7 +428,7 @@ Simplex messaging router implementations MUST NOT create, store or send to any o - Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using simplex messaging routers (the routers cannot compromise forward secrecy of any application layer protocol, such as double ratchet). -Routers with the names role make outbound JSON-RPC calls to an Ethereum endpoint to read `NameRecord` data; the lookup key reaches that endpoint. Operators MUST run the endpoint themselves (loopback Reth + Nimbus, or a self-hosted central deployment) — sharing one endpoint across multiple operators collapses the two-server privacy property because the endpoint operator would see every lookup key across all of them. The names role and the SMP-proxy role MUST NOT be enabled on the same router by default; a slow `RSLV` cache miss can serialise other forwarded commands on the same proxy-relay session. +Routers with the names role make outbound HTTP calls to a backing resolver service (the reference implementation is `scripts/resolver/snrc-resolve.py`, which in turn makes JSON-RPC calls to an Ethereum endpoint) to read `NameRecord` data; the lookup key reaches that resolver and its upstream RPC endpoint. Operators MUST run both the resolver process and its upstream RPC endpoint themselves (loopback Reth + Nimbus, or a self-hosted central deployment) — sharing them across multiple operators collapses the two-server privacy property because the resolver / RPC operator would see every lookup key across all of them. The names role and the SMP-proxy role MUST NOT be enabled on the same router by default; a slow `RSLV` cache miss can serialise other forwarded commands on the same proxy-relay session. ## Message delivery notifications @@ -1443,10 +1443,13 @@ session, or identity; the proxy router sees the client connection but cannot read the encrypted lookup key inside the forwarded transmission. **Backing store.** This protocol does not prescribe where the names router -reads `NameRecord` from. The reference implementation queries the SNRC contract -on Ethereum via a JSON-RPC endpoint; alternative backings (different chains, -DHT, etc.) are valid as long as they return a `NameRecord` matching the encoding -below. +reads `NameRecord` from. The reference implementation forwards each RSLV to a +companion REST resolver process (`scripts/resolver/snrc-resolve.py`) that +queries the SNRC contract on Ethereum; alternative backings (different chains, +DHT, etc.) are valid as long as they expose the documented HTTP shape (`GET +/resolve/` returning a `NameRecord` on 200, 404 / 400 for unknown names +or TLDs, 502 for upstream RPC failures) or substitute a different transport +while still returning a `NameRecord` matching the encoding below. #### Resolve name command @@ -1461,25 +1464,23 @@ rslv = %s"RSLV" SP json-bytes ; json-bytes consumes the remainder of the trans | Field | JSON type | Constraints | |---|---|---| | `name` | string | the canonical fully-qualified name (TLD always explicit, e.g. `"privacy.simplex"`, `"test.testing"`, `"example.com"`); UTF-8 bytes only | -| `contract` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes — the SNRC contract address the client expects the server to query) | +| `contract` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes); currently ignored by the server, reserved for future eth-backed implementations that may use it to constrain which on-chain registry the client expects the server to query | **Server-side validation.** The names router parses `name` as a fully-qualified -domain (TLD required — bare labels are rejected), extracts the TLD, and looks -up the expected SNRC contract address in a whitelist hardcoded in the server -binary (TLD-specific addresses with an optional catch-all for unspecified -TLDs and web domains). If no whitelist entry matches the TLD, or if the -client-supplied `contract` differs from the configured address, the server -replies with `ERR AUTH` without contacting the chain. This lets one names -router safely host multiple TLDs (each backed by its own SNRC contract) and -reject clients pointing at a contract the operator doesn't run. +domain (TLD required — bare labels are rejected) and forwards it to the +configured backing resolver. The `contract` field is parsed for forward +compatibility but ignored by the reference implementation: the backing +resolver is the source of truth for which on-chain registry maps to each TLD. +Any failure (malformed name, resolver 404 / 400 / 5xx, transport failure, +timeout, decode error, names role disabled) collapses to `ERR AUTH`. The names router responds with either a `NAME` response carrying the resolved record, or `ERR AUTH` collapsing every failure mode (name not found, malformed -name, TLD not in whitelist, contract mismatch, names role disabled, RPC -unreachable, decode error, timeout). The wire code does not distinguish -between these — stats counters MAY be exposed out-of-band for operator -observability (`bad_name` is incremented for validation/whitelist failures, -distinct from `not_found` for valid lookups with no on-chain record). +name, names role disabled, resolver unreachable, decode error, timeout). The +wire code does not distinguish between these — stats counters MAY be exposed +out-of-band for operator observability (`bad_name` is incremented for +validation failures, distinct from `not_found` for valid lookups with no +backing record). #### Name record response @@ -1494,22 +1495,29 @@ name = %s"NAME" SP json-bytes ; json-bytes consumes the remainder of the trans | Field | JSON type | Constraints | |---|---|---| | `name` | string | ≤ 255 bytes UTF-8 | -| `nickname` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | -| `website` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | -| `location` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | -| `simplex.contact` | string or null | ≤ 1024 bytes UTF-8; same null / absent rules | -| `simplex.channel` | string or null | ≤ 1024 bytes UTF-8; same null / absent rules | -| `ETH` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | -| `BTC` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | -| `XMR` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | -| `DOT` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `nickname` | string | ≤ 255 bytes UTF-8; senders MUST emit the empty string `""` when unset | +| `website` | string | ≤ 255 bytes UTF-8; same empty-string-when-unset rule | +| `location` | string | ≤ 255 bytes UTF-8; same empty-string-when-unset rule | +| `simplexContact` | string | ≤ 1024 bytes UTF-8; same empty-string-when-unset rule | +| `simplexChannel` | string | ≤ 1024 bytes UTF-8; same empty-string-when-unset rule | +| `eth` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | +| `btc` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `xmr` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | +| `dot` | string or null | ≤ 255 bytes UTF-8; same null / absent rules | | `owner` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes) | -| `resolver` | string | `"0x"` followed by 40 lowercase hex characters; the SNRC contract address that produced the record | - -The server MUST filter expired records before constructing the response -(returning `ERR AUTH` to the client), so the wire format carries no expiry -field. Testnet-vs-mainnet status is derived from the queried TLD rather than -an in-record flag. +| `resolver` | string | `"0x"` followed by 40 lowercase hex characters; the resolver contract address that produced the record | + +Text fields (`nickname`, `website`, `location`, `simplexContact`, +`simplexChannel`) use the empty string `""` as the "unset" sentinel: a +backing resolver with no value for the field MUST emit an empty string, not +JSON `null` and not an absent key. Coin fields (`eth`, `btc`, `xmr`, `dot`) +use JSON `null` as the "unset" sentinel and MAY also be absent from the +object entirely. + +The server MUST filter records its backing resolver indicates are expired +or otherwise unavailable (returning `ERR AUTH` to the client), so the wire +format carries no expiry field. Testnet-vs-mainnet status is derived from +the queried TLD rather than an in-record flag. Receivers MUST tolerate extra unknown fields (forward-compatibility for future field additions). Adding a required field is a breaking change requiring an diff --git a/simplexmq.cabal b/simplexmq.cabal index 01fa027ce..68fe13267 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -144,7 +144,6 @@ library Simplex.Messaging.Server.QueueStore.QueueInfo Simplex.Messaging.ServiceScheme Simplex.Messaging.SimplexName - Simplex.Messaging.SimplexName.Contracts Simplex.Messaging.Session Simplex.Messaging.SystemTime Simplex.Messaging.TMap @@ -266,8 +265,7 @@ library Simplex.Messaging.Server.MsgStore.STM Simplex.Messaging.Server.MsgStore.Types Simplex.Messaging.Server.Names - Simplex.Messaging.Server.Names.Eth.RPC - Simplex.Messaging.Server.Names.Eth.SNRC + Simplex.Messaging.Server.Names.HttpResolver Simplex.Messaging.Server.NtfStore Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 73be8269e..759efea4e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -239,7 +239,6 @@ import Simplex.Messaging.Protocol ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) -import Simplex.Messaging.SimplexName.Contracts (tldContract) import Simplex.Messaging.SystemTime import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPVersion, THClientService' (..), THandleAuth (..), THandleParams (..)) @@ -1193,9 +1192,14 @@ deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexNameDomain -> AM NameRecord -resolveSimplexName' c nm userId resolverSrv domain = case tldContract (nameTLD domain) of - Nothing -> throwE $ INTERNAL "resolveSimplexName: no resolver contract for TLD" - Just contract -> resolveName c nm userId resolverSrv contract (fullDomainName domain) +resolveSimplexName' c nm userId resolverSrv domain = + resolveName c nm userId resolverSrv placeholderContract (fullDomainName domain) + where + -- The wire format still carries a 20-byte `contract` field on RslvRequest + -- (no SMP version bump), but the server-side resolver ignores it: the + -- backing Python REST resolver is the source of truth for which on-chain + -- registry maps to each TLD. The agent sends the all-zero placeholder. + placeholderContract = either error id (SMP.mkNameOwner (B.replicate 20 '\NUL')) changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do diff --git a/src/Simplex/Messaging/Names/Record.hs b/src/Simplex/Messaging/Names/Record.hs index 68a40111b..460f85bbd 100644 --- a/src/Simplex/Messaging/Names/Record.hs +++ b/src/Simplex/Messaging/Names/Record.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -15,73 +14,53 @@ import qualified Data.ByteString.Char8 as B import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Simplex.Messaging.Names.Owner (NameOwner) -import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix) -- | Resolved name record returned by the names role. -- Wire format is JSON — change requires an SMP version bump. --- JSON keys match the Python resolver (PR #1795 `snrc-resolve.py`) so the --- same server can be backed by either the direct-ETH-RPC resolver or the --- Python REST resolver without changing the wire format clients see. +-- JSON keys match the Python REST resolver (PR #1795 `snrc-resolve.py`). +-- Text fields use the empty string as the "unset" sentinel; coin fields +-- use JSON `null`. `owner` and `resolver` carry 20-byte addresses encoded +-- as `0x`-prefixed lowercase hex (see Names.Owner). data NameRecord = NameRecord { nrName :: Text, - nrNickname :: Maybe Text, - nrWebsite :: Maybe Text, - nrLocation :: Maybe Text, - nrSimplexContact :: Maybe Text, - nrSimplexChannel :: Maybe Text, + nrNickname :: Text, + nrWebsite :: Text, + nrLocation :: Text, + nrSimplexContact :: Text, + nrSimplexChannel :: Text, nrEth :: Maybe Text, nrBtc :: Maybe Text, nrXmr :: Maybe Text, nrDot :: Maybe Text, nrOwner :: NameOwner, - nrResolver :: NameOwner -- SNRC contract address that produced the record + nrResolver :: NameOwner -- resolver address that produced the record } deriving (Eq, Show) --- ToJSON / toEncoding are TH-derived from a single Options value so both Aeson --- paths emit byte-identical output in declaration order. The default --- fieldLabelModifier cannot express dot-keys ("simplex.contact", --- "simplex.channel") or uppercase coin keys ("ETH", "BTC", "XMR", "DOT"). --- omitNothingFields is set to False to preserve the previous hand-rolled --- shape (absent optionals emitted as JSON `null`); FromJSON tolerates both --- missing and null keys for forward-compat with sparse Python output. --- Options inlined at the splice site because TH stage restriction forbids a --- module-local helper. +-- ToJSON / toEncoding TH-derived from a single Options value so both Aeson +-- paths emit byte-identical output in declaration order. omitNothingFields +-- is False so absent coin fields surface as JSON `null` (matches the Python +-- resolver output for unset coins). $( JQ.deriveToJSON - defaultJSON - { J.omitNothingFields = False, - J.fieldLabelModifier = \case - "nrName" -> "name" - "nrNickname" -> "nickname" - "nrWebsite" -> "website" - "nrLocation" -> "location" - "nrSimplexContact" -> "simplex.contact" - "nrSimplexChannel" -> "simplex.channel" - "nrEth" -> "ETH" - "nrBtc" -> "BTC" - "nrXmr" -> "XMR" - "nrDot" -> "DOT" - "nrOwner" -> "owner" - "nrResolver" -> "resolver" - s -> s - } + defaultJSON {J.omitNothingFields = False, J.fieldLabelModifier = dropPrefix "nr"} ''NameRecord ) --- FromJSON is hand-rolled to enforce per-field UTF-8 byte-length caps that the +-- FromJSON is hand-rolled to enforce per-field UTF-8 byte-length caps that -- TH derivation cannot express. instance J.FromJSON NameRecord where parseJSON = J.withObject "NameRecord" $ \o -> do nrName <- o J..: "name" >>= capUtf8 "name" 255 - nrNickname <- o J..:? "nickname" >>= traverse (capUtf8 "nickname" 255) - nrWebsite <- o J..:? "website" >>= traverse (capUtf8 "website" 255) - nrLocation <- o J..:? "location" >>= traverse (capUtf8 "location" 255) - nrSimplexContact <- o J..:? "simplex.contact" >>= traverse (capUtf8 "simplex.contact" 1024) - nrSimplexChannel <- o J..:? "simplex.channel" >>= traverse (capUtf8 "simplex.channel" 1024) - nrEth <- o J..:? "ETH" >>= traverse (capUtf8 "ETH" 255) - nrBtc <- o J..:? "BTC" >>= traverse (capUtf8 "BTC" 255) - nrXmr <- o J..:? "XMR" >>= traverse (capUtf8 "XMR" 255) - nrDot <- o J..:? "DOT" >>= traverse (capUtf8 "DOT" 255) + nrNickname <- o J..: "nickname" >>= capUtf8 "nickname" 255 + nrWebsite <- o J..: "website" >>= capUtf8 "website" 255 + nrLocation <- o J..: "location" >>= capUtf8 "location" 255 + nrSimplexContact <- o J..: "simplexContact" >>= capUtf8 "simplexContact" 1024 + nrSimplexChannel <- o J..: "simplexChannel" >>= capUtf8 "simplexChannel" 1024 + nrEth <- o J..:? "eth" >>= traverse (capUtf8 "eth" 255) + nrBtc <- o J..:? "btc" >>= traverse (capUtf8 "btc" 255) + nrXmr <- o J..:? "xmr" >>= traverse (capUtf8 "xmr" 255) + nrDot <- o J..:? "dot" >>= traverse (capUtf8 "dot" 255) nrOwner <- o J..: "owner" nrResolver <- o J..: "resolver" pure NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 9dfc89764..ae5383b2b 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -109,7 +109,7 @@ import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages) -import Simplex.Messaging.Server.Names (NamesEnv, ResolveError (..), closeNamesEnv, resolveName, verifyRslv) +import Simplex.Messaging.Server.Names (NamesEnv, ResolveError (..), closeNamesEnv, parseName, resolveName) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -1510,9 +1510,9 @@ client incStat (rslvReqs st) (selector, msg) <- asks namesEnv >>= \case Nothing -> pure (rslvDisabled, ERR AUTH) - Just nenv -> case verifyRslv nenv req of + Just nenv -> case parseName req of Nothing -> pure (rslvBadName, ERR AUTH) - Just (addr, d) -> liftIO (resolveName nenv addr d) <&> \case + Just d -> liftIO (resolveName nenv d) <&> \case Right rec -> (rslvSucc, NAME rec) Left NotFound -> (rslvNotFound, ERR AUTH) Left _ -> (rslvEthErrs, ERR AUTH) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 8ce51c106..835db4bd7 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -117,7 +117,7 @@ import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint) -import Simplex.Messaging.Server.Names.Eth.RPC (scrubUrl) +import Simplex.Messaging.Server.Names.HttpResolver (scrubUrl) import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Config @@ -621,7 +621,7 @@ newEnvWithNames config@ServerConfig {allowSMPProxy, smpCredentials, httpCredenti Nothing -> case namesConfig of Nothing -> pure Nothing Just nc -> do - logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (ethereumEndpoint nc) + logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (resolverEndpoint nc) when allowSMPProxy $ logWarn "[NAMES] enable: on on a proxy-role host: slow RSLV calls can serialise other forwarded commands on the same proxy-relay session. For high-volume deployments, run [NAMES] on a separate host." env <- newNamesEnv nc diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 442350e48..fedd0d508 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -806,28 +806,25 @@ readNamesConfig :: Ini -> Maybe NamesConfig readNamesConfig ini | not enabled = Nothing | otherwise = - let rpcAuth_ = either (error . ("[NAMES] rpc_auth: " <>)) Just . parseRpcAuth =<< eitherToMaybe (lookupValue "NAMES" "rpc_auth" ini) - endpoint = requiredText "ethereum_endpoint" + let resolverAuth_ = either (error . ("[NAMES] resolver_auth: " <>)) Just . parseRpcAuth =<< eitherToMaybe (lookupValue "NAMES" "resolver_auth" ini) + endpoint = requiredText "resolver_endpoint" in Just NamesConfig - { ethereumEndpoint = either (error . ("[NAMES] ethereum_endpoint: " <>)) id (validateUrl endpoint rpcAuth_), - rpcAuth = rpcAuth_, - rpcTimeoutMs = boundedIniInt 3000 100 60000 "rpc_timeout_ms", - rpcMaxResponseBytes = boundedIniInt 262144 1024 16777216 "rpc_max_response_bytes", - rpcMaxConcurrency = boundedIniInt 8 1 1024 "rpc_max_concurrency" + { resolverEndpoint = either (error . ("[NAMES] resolver_endpoint: " <>)) id (validateUrl endpoint resolverAuth_), + resolverAuth = resolverAuth_, + resolverTimeoutMs = boundedIniInt 3000 100 60000 "resolver_timeout_ms", + resolverMaxResponseBytes = boundedIniInt 65536 1024 16777216 "resolver_max_response_bytes" } where enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini) requiredText key = either (error . (("[NAMES] " <> T.unpack key <> " is required: ") <>)) id $ lookupValue "NAMES" key ini - -- Reject zero / negative values that would deadlock waitQSem (concurrency = 0), - -- time-out every RSLV immediately (timeout = 0), or accept zero-length - -- responses (max_response_bytes = 0). The lower bounds also catch sub-sane - -- values an operator might choose by accident. The upper bounds defend - -- against operator-misconfig footguns: 16 MiB response cap (worst-case - -- per-call memory), 60 s timeout (no operator wants RSLV to hang longer), - -- 1024 concurrent RPCs (any higher should run a separate names router). + -- Lower bound rejects values that would time-out every RSLV immediately + -- (timeout = 0) or accept zero-length responses (max_response_bytes = 0). + -- The upper bounds defend against operator-misconfig footguns: 16 MiB + -- response cap (worst-case per-call memory), 60 s timeout (no operator + -- wants RSLV to hang longer). boundedIniInt def floor_ ceiling_ key = case lookupValue "NAMES" key ini of Left _ -> def Right raw -> case readMaybe (T.unpack (T.strip raw)) of @@ -838,17 +835,17 @@ readNamesConfig ini | otherwise -> error $ "[NAMES] " <> T.unpack key <> " must be in [" <> show floor_ <> ".." <> show ceiling_ <> "] (got " <> show n <> ")" --- | Validate the ethereum_endpoint URL: +-- | Validate the resolver_endpoint URL: -- * scheme must be http: or https: -- * authority (host) must be present and non-empty --- * port MUST be explicit (rejects http://host without :8545 to avoid --- accidentally hitting :80 when Reth listens on :8545) +-- * port MUST be explicit (rejects http://host without :8000 to avoid +-- accidentally hitting :80 when the resolver listens on :8000) -- * userinfo (user:pass@) MUST NOT be present (credentials belong in --- rpc_auth so they don't leak via Host header or logs) +-- resolver_auth so they don't leak via Host header or logs) -- * query and fragment MUST NOT be present -- * http is rejected on non-loopback hosts (plaintext to a third party --- leaks rpc_auth on every request) --- * https requires rpc_auth on non-loopback hosts (a public endpoint +-- leaks resolver_auth on every request) +-- * https requires resolver_auth on non-loopback hosts (a public endpoint -- without auth is almost always misconfig) -- * link-local hosts (169.254.0.0/16, including the cloud metadata IP -- 169.254.169.254) are rejected unconditionally @@ -867,9 +864,9 @@ validateUrl url auth_ = do Left "non-canonical IPv4 form not allowed (use dotted-quad decimal 0-255 with no leading zeros); rejects inet_aton hex/octal/compact aliases of 169.254.169.254" when (isLinkLocal host || isForbiddenIpv6 host) $ Left "link-local host not allowed (rejects cloud metadata services and IPv6 aliases of 169.254.0.0/16)" - unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; use rpc_auth instead" + unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; use resolver_auth instead" case uriPort ua of - "" -> Left "explicit port required (e.g. http://host:8545)" + "" -> Left "explicit port required (e.g. http://host:8000)" ':' : portStr -> case readMaybe portStr of Just n | (n :: Int) >= 1 && n <= 65535 -> Right () _ -> Left $ "port " <> portStr <> " out of range (must be 1..65535)" @@ -878,10 +875,10 @@ validateUrl url auth_ = do unless (null (uriFragment uri)) $ Left "fragment not allowed" let path = uriPath uri unless (path == "" || path == "/") $ - Left "URL path not allowed; API keys embedded in the path leak to logs — use rpc_auth instead" + Left "URL path not allowed; API keys embedded in the path leak to logs — use resolver_auth instead" unless (isLoopback host) $ case scheme of - "http:" -> Left "http endpoint on a non-loopback host not allowed (plaintext leaks rpc_auth); use https" - "https:" | isNothing auth_ -> Left "https endpoint on a non-loopback host requires rpc_auth" + "http:" -> Left "http endpoint on a non-loopback host not allowed (plaintext leaks resolver_auth); use https" + "https:" | isNothing auth_ -> Left "https endpoint on a non-loopback host requires resolver_auth" _ -> Right () Right url where diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index 9ec67bc17..355615d4f 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -156,24 +156,21 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = <> ("# client_concurrency = " <> tshow defaultProxyClientConcurrency) <> "\n\n\ \[NAMES]\n\ - \# Public-namespace resolution (SNRC on Ethereum).\n\ - \# Requires an Ethereum JSON-RPC endpoint (Reth+Nimbus). See deployment guide.\n\ + \# Public-namespace resolution via the snrc-resolve.py REST resolver.\n\ + \# Operator runs the resolver alongside smp-server (default port 8000)\n\ + \# with its own Ethereum JSON-RPC endpoint configured in resolver.toml.\n\ \# Co-locating with the proxy role logs a startup advisory: slow RSLV calls can\n\ \# serialise other forwarded commands on the same proxy-relay session.\n\ \# For high-volume deployments, run [NAMES] on a separate host.\n\ \# Restart required to change settings.\n\ \enable: off\n\ \# Same-host:\n\ - \# ethereum_endpoint: http://127.0.0.1:8545\n\ - \# Central Reth via Caddy:\n\ - \# ethereum_endpoint: https://eth.simplex.chat:443\n\ - \# rpc_auth: basic :\n\ - \# The SNRC contract addresses are hardcoded in the server binary; each\n\ - \# RSLV's contract field is verified against the binary's whitelist for\n\ - \# the requested TLD. Operators do NOT configure registries here.\n\ - \# rpc_timeout_ms: 3000\n\ - \# rpc_max_response_bytes: 262144\n\ - \# rpc_max_concurrency: 8\n\n\ + \# resolver_endpoint: http://127.0.0.1:8000\n\ + \# Resolver behind TLS reverse proxy:\n\ + \# resolver_endpoint: https://names.simplex.chat:443\n\ + \# resolver_auth: basic :\n\ + \# resolver_timeout_ms: 3000\n\ + \# resolver_max_response_bytes: 65536\n\n\ \[INACTIVE_CLIENTS]\n\ \# TTL and interval to check inactive clients\n\ \disconnect = on\n" diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index 0f81f9c02..c2e17369f 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -4,150 +4,159 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} --- | Public-namespace resolver. Each RSLV becomes one eth_call to the --- Ethereum endpoint with the contract address selected by the requested --- TLD, bounded by rpcMaxConcurrency and rpcTimeoutMs. Zero-owner / expired --- records map to NotFound. +-- | Public-namespace resolver. Each RSLV becomes one HTTP GET to the +-- configured names resolver service (the Python REST resolver in PR #1795 +-- by default), bounded by resolverTimeoutMs and the maximum response size. +-- The resolver_endpoint URL is operator-supplied; the contract field on the +-- RSLV wire format is parsed for forward-compatibility but ignored — the +-- Python service is the source of truth for which on-chain registries are +-- queried per TLD. -- --- Transport details live in Names.Eth.RPC (HTTP + JSON-RPC + auth); --- Keccak-256 namehash and SNRC ABI decoder live in Names.Eth.SNRC. +-- HTTP details (URL building, redirects disabled, body cap, auth header) +-- live in Names.HttpResolver. module Simplex.Messaging.Server.Names ( NamesConfig (..), RpcAuth (..), NamesEnv (..), - EthCall, + ResolverCall, + ResolverCallKind (..), ResolveError (..), newNamesEnv, newNamesEnvWith, closeNamesEnv, pingEndpoint, resolveName, - verifyRslv, + parseName, ) where -import Control.Monad (guard) import qualified Control.Exception as E import Control.Logger.Simple (logError) -import Data.ByteString.Char8 (ByteString) -import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock.POSIX (getPOSIXTime) import Simplex.Messaging.Encoding.String (strDecode) -import Simplex.Messaging.Protocol (NameOwner, NameRecord, RslvRequest (..), unNameOwner) -import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) -import Simplex.Messaging.Server.Names.Eth.SNRC (decodeGetRecord, encodeGetRecord, namehash) -import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..), fullDomainName) -import Simplex.Messaging.SimplexName.Contracts (tldContract) +import Simplex.Messaging.Protocol (NameRecord, RslvRequest (..)) +import Simplex.Messaging.Server.Names.HttpResolver + ( ResolverEnv, + ResolverError (..), + RpcAuth (..), + closeResolverEnv, + healthHttp, + newResolverEnv, + resolveHttp, + ) +import Simplex.Messaging.SimplexName (SimplexNameDomain, fullDomainName) import System.Timeout (timeout) data NamesConfig = NamesConfig - { ethereumEndpoint :: Text, - rpcAuth :: Maybe RpcAuth, - rpcTimeoutMs :: Int, - rpcMaxResponseBytes :: Int, - rpcMaxConcurrency :: Int + { resolverEndpoint :: Text, + resolverAuth :: Maybe RpcAuth, + resolverTimeoutMs :: Int, + resolverMaxResponseBytes :: Int } deriving (Show) data ResolveError - = NotFound - | EthHttpErr - | EthRpcErr {rpcCode :: Int, rpcMessage :: Text} - | EthDecodeErr + = NotFound -- name not registered, unknown TLD, or malformed name (404 / 400) + | ResolverError -- upstream RPC failure (502) or transport error + | ResolverDecodeErr -- response was not a valid NameRecord JSON | TimedOut deriving (Eq, Show) --- | Test seam: a function from (to, data) -> raw return bytes or error. --- Production wires this to ethCallReal; tests substitute a stub. -type EthCall = ByteString -> ByteString -> IO (Either EthRpcError ByteString) +-- | Test seam: a function from URL path -> JSON value or error. Production +-- wires this to resolveHttp / healthHttp on a real `ResolverEnv`; tests +-- substitute a stub returning canned JSON or a chosen error. +-- +-- The first argument is the HTTP endpoint to hit: `ResolverFetch` for a +-- name lookup, `ResolverHealth` for the startup probe. Tests use the tag +-- to assert which kind of call the server made. +data ResolverCallKind = ResolverFetch Text | ResolverHealth + deriving (Eq, Show) + +-- Re-export so test seams (which need to match on the kind) can use it +-- without depending on the HttpResolver module. + +type ResolverCall = ResolverCallKind -> IO (Either ResolverError J.Value) data NamesEnv = NamesEnv { config :: NamesConfig, - ethCall :: EthCall, - rpcEnv :: Maybe EthRpcEnv -- Nothing for test stubs + resolverCall :: ResolverCall, + resolverEnv :: Maybe ResolverEnv -- Nothing for test stubs } newNamesEnv :: NamesConfig -> IO NamesEnv newNamesEnv cfg = do - rpc <- newEthRpcEnv (ethereumEndpoint cfg) (rpcAuth cfg) (rpcMaxResponseBytes cfg) (rpcMaxConcurrency cfg) - newNamesEnvWith cfg (ethCallReal rpc) (Just rpc) + rEnv <- newResolverEnv (resolverEndpoint cfg) (resolverAuth cfg) (resolverTimeoutMs cfg) (resolverMaxResponseBytes cfg) + newNamesEnvWith cfg (httpResolverCall rEnv) (Just rEnv) --- | Allocate resolver with an injected ethCall (test seam). -newNamesEnvWith :: NamesConfig -> EthCall -> Maybe EthRpcEnv -> IO NamesEnv -newNamesEnvWith config ethCall rpcEnv = pure NamesEnv {config, ethCall, rpcEnv} +httpResolverCall :: ResolverEnv -> ResolverCall +httpResolverCall env = \case + ResolverFetch n -> resolveHttp env n + ResolverHealth -> healthHttp env + +-- | Allocate resolver with an injected `resolverCall` (test seam). +newNamesEnvWith :: NamesConfig -> ResolverCall -> Maybe ResolverEnv -> IO NamesEnv +newNamesEnvWith config resolverCall resolverEnv = pure NamesEnv {config, resolverCall, resolverEnv} closeNamesEnv :: NamesEnv -> IO () -closeNamesEnv NamesEnv {rpcEnv} = mapM_ closeEthRpcEnv rpcEnv - --- | Parse the client-supplied domain, look up the TLD's expected contract, --- and verify the client-supplied contract matches. Returns the verified --- (address, parsed-domain) pair, or `Nothing` if any check fails — the --- handler maps this to `ERR AUTH` and increments `rslvBadName`. -verifyRslv :: NamesEnv -> RslvRequest -> Maybe (NameOwner, SimplexNameDomain) -verifyRslv _ RslvRequest {name, contract} = case strDecode (encodeUtf8 name) of - Left _ -> Nothing - Right d -> do - expected <- tldContract (nameTLD d) - guard (expected == contract) - pure (expected, d) - --- | Reach the configured endpoint with a harmless probe call to confirm --- network reachability. Uses any configured contract address (the static --- TLD->contract mapping guarantees at least one is set; TLDWeb has none by --- design). A JSON-RPC error (e.g. unknown contract on a healthy node) is --- treated as "endpoint reachable". HTTP transport failures, oversized --- responses, and non-JSON bodies (operator pointing at the wrong service) --- all surface as Left so startup fails loudly rather than every RSLV --- silently incrementing rslvEthErrs. -pingEndpoint :: NamesEnv -> IO (Either EthRpcError ()) -pingEndpoint NamesEnv {ethCall, config} = case mapMaybe tldContract [TLDSimplex, TLDTesting] of - [] -> pure (Right ()) - addr : _ -> do - -- Bound the probe by the same rpcTimeoutMs that resolveName uses, so a - -- slow-loris endpoint can't park startup until http-client's default - -- 30 s response timeout fires. - r <- timeout (rpcTimeoutMs config * 1000) $ - ethCall (unNameOwner addr) (encodeGetRecord (namehash "")) - pure $ case r of - Nothing -> Left ProbeTimedOut - Just (Left JsonRpcErr {}) -> Right () -- node answered, just doesn't know this contract - Just (Left e) -> Left e - Just (Right _) -> Right () - --- | Resolve a verified (contract, domain) pair with an rpcTimeoutMs --- ceiling. Synchronous exceptions are caught and logged; async exceptions --- propagate. -resolveName :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) -resolveName env contract d = do - r <- E.try (timeout (rpcTimeoutMs (config env) * 1000) (fetch env contract d)) +closeNamesEnv NamesEnv {resolverEnv} = mapM_ closeResolverEnv resolverEnv + +-- | Parse the client-supplied name. The wire-format `contract` field is +-- parsed by the protocol layer but ignored here: the resolver service +-- selects which registry to query based on the TLD. Returns the parsed +-- domain, or `Nothing` if the name is not a valid SimplexNameDomain (the +-- handler maps `Nothing` to `ERR AUTH` and increments `rslvBadName`). +parseName :: RslvRequest -> Maybe SimplexNameDomain +parseName RslvRequest {name} = either (const Nothing) Just $ strDecode (encodeUtf8 name) + +-- | Reach the configured resolver with `GET /health` to confirm reachability +-- at server startup. A non-2xx response or transport failure surfaces as +-- Left so misconfigured deployments fail loudly. Bounded by +-- `resolverTimeoutMs` so a slow-loris endpoint cannot park startup until +-- http-client's default 30 s response timeout fires. +pingEndpoint :: NamesEnv -> IO (Either ResolverError ()) +pingEndpoint NamesEnv {resolverCall, config} = do + r <- timeout (resolverTimeoutMs config * 1000) $ resolverCall ResolverHealth + pure $ case r of + Nothing -> Left (HttpStatusErr 0) -- transport-level timeout (0 is not a real HTTP code) + Just (Left e) -> Left e + Just (Right _) -> Right () + +-- | Resolve a parsed domain via the configured HTTP resolver, with an +-- `resolverTimeoutMs` ceiling. Synchronous exceptions are caught and +-- logged; async exceptions propagate. +resolveName :: NamesEnv -> SimplexNameDomain -> IO (Either ResolveError NameRecord) +resolveName env d = do + r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env d)) case r of - Right result -> pure (fromMaybe (Left TimedOut) result) + Right result -> pure (maybe (Left TimedOut) id result) Left e | Just (_ :: E.SomeAsyncException) <- E.fromException e -> E.throwIO e | otherwise -> do logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e) - pure (Left EthHttpErr) - -fetch :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) -fetch NamesEnv {ethCall} contract d = do - nowSec <- floor <$> getPOSIXTime - ethCall (unNameOwner contract) (encodeGetRecord (namehash (encodeUtf8 (fullDomainName d)))) >>= \case - Left e -> pure (Left (mapEthRpcError e)) - Right ret -> case decodeGetRecord contract nowSec ret of - Right Nothing -> pure (Left NotFound) - Right (Just rec) -> pure (Right rec) - Left _ -> pure (Left EthDecodeErr) - --- | Collapse the JSON-RPC transport-layer error space into the resolver's --- public error space. -mapEthRpcError :: EthRpcError -> ResolveError -mapEthRpcError = \case - HttpFailure _ -> EthHttpErr - HttpStatusErr _ -> EthHttpErr - BodyTooLarge -> EthHttpErr -- transport-side cap, not a decoder failure - InvalidJson _ -> EthDecodeErr - JsonRpcErr c m -> EthRpcErr {rpcCode = c, rpcMessage = m} - ProbeTimedOut -> EthHttpErr -- pingEndpoint-only; never raised by ethCallReal in the resolve path + pure (Left ResolverError) + +fetch :: NamesEnv -> SimplexNameDomain -> IO (Either ResolveError NameRecord) +fetch NamesEnv {resolverCall} d = + resolverCall (ResolverFetch (fullDomainName d)) >>= \case + Left e -> pure (Left (mapResolverError e)) + Right v -> case JT.parseEither J.parseJSON v of + Right nr -> pure (Right nr) + Left _ -> pure (Left ResolverDecodeErr) + +-- | Collapse the HTTP-layer error space into the resolver's public error +-- space. 404 / 400 both map to NotFound (name not registered, unknown TLD, +-- or malformed name — indistinguishable from the client's point of view). +-- Everything else collapses to ResolverError; the response body is not +-- inspected because adversarial endpoints could embed arbitrary content. +mapResolverError :: ResolverError -> ResolveError +mapResolverError = \case + HttpStatusErr 404 -> NotFound + HttpStatusErr 400 -> NotFound + HttpStatusErr _ -> ResolverError + HttpFailure _ -> ResolverError + BodyTooLarge -> ResolverError + InvalidJson _ -> ResolverDecodeErr diff --git a/src/Simplex/Messaging/Server/Names/Eth/RPC.hs b/src/Simplex/Messaging/Server/Names/Eth/RPC.hs deleted file mode 100644 index 1f0d2d02a..000000000 --- a/src/Simplex/Messaging/Server/Names/Eth/RPC.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} - --- | Ethereum JSON-RPC HTTP transport for the resolver. --- --- Boundary properties: --- * Response body read with `brReadSome rpcMaxResponseBytes` — adversarial --- endpoints cannot exhaust memory with multi-GB bodies. --- * Concurrency cap via QSem — bursts of cache-miss traffic cannot exhaust --- the http-client connection pool. --- * Authorization header attached only when configured. -module Simplex.Messaging.Server.Names.Eth.RPC - ( RpcAuth (..), - EthRpcEnv, - EthRpcError (..), - newEthRpcEnv, - closeEthRpcEnv, - ethCallReal, - scrubUrl, - ) -where - -import Control.Applicative ((<|>)) -import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) -import qualified Control.Exception as E -import Control.Exception (bracket_) -import qualified Data.Aeson as J -import qualified Data.Aeson.Types as J -import qualified Data.ByteArray.Encoding as BAE -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as BL -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Network.HTTP.Client - ( HttpException, - Manager, - ManagerSettings (..), - Request, - RequestBody (..), - brReadSome, - method, - parseRequest, - redirectCount, - requestBody, - requestHeaders, - responseBody, - responseStatus, - withResponse, - ) -import qualified Network.HTTP.Client as HC -import Network.HTTP.Client.TLS (tlsManagerSettings) -import qualified Network.HTTP.Types as HT - -data RpcAuth = AuthBearer Text | AuthBasic Text Text - --- | Redacts the bearer token / basic-auth password so an accidental --- `show` / `tshow` on NamesConfig never lands secrets in logs. -instance Show RpcAuth where - show (AuthBearer _) = "AuthBearer " - show (AuthBasic u _) = "AuthBasic " <> show u <> " " - -data EthRpcEnv = EthRpcEnv - { manager :: Manager, - request :: Request, - sem :: QSem, - maxResponseBytes :: Int - } - -data EthRpcError - = HttpFailure HttpException - | HttpStatusErr Int - | BodyTooLarge - | InvalidJson String - | JsonRpcErr Int Text - | ProbeTimedOut -- startup-probe timeout; resolveName uses its own Timeout - deriving (Show) - --- | Build a Request from a (validated) ethereum_endpoint URL. Redirects are --- disabled: an RPC endpoint that responds 3xx is a misconfiguration, and a --- compromised endpoint could otherwise redirect a credential-bearing POST --- to a private-IP target (SSRF amplification on top of the host validation --- performed at config load — DNS rebinding and chained redirects bypass it). -buildRequest :: Text -> Maybe RpcAuth -> IO Request -buildRequest endpoint auth_ = do - req <- parseRequest (T.unpack endpoint) - pure $ - req - { method = "POST", - redirectCount = 0, - requestHeaders = - ("Content-Type", "application/json") - : maybe [] (pure . authHeader) auth_ - } - -authHeader :: RpcAuth -> HT.Header -authHeader = \case - AuthBearer tok -> ("Authorization", "Bearer " <> encodeUtf8 tok) - AuthBasic u p -> - let encoded = BAE.convertToBase BAE.Base64 (encodeUtf8 u <> ":" <> encodeUtf8 p) :: ByteString - in ("Authorization", "Basic " <> encoded) - -newEthRpcEnv :: Text -> Maybe RpcAuth -> Int -> Int -> IO EthRpcEnv -newEthRpcEnv endpoint auth_ maxResponseBytes maxConcurrency = do - -- managerConnCount defaults to 10; without raising it the configured - -- rpcMaxConcurrency is silently capped to 10 by http-client's pool. - manager <- HC.newManager tlsManagerSettings {managerConnCount = max 10 maxConcurrency} - request <- buildRequest endpoint auth_ - sem <- newQSem maxConcurrency - pure EthRpcEnv {manager, request, sem, maxResponseBytes} - --- | http-client's `closeManager` is a deprecated no-op since 0.5; the manager --- is released by the GC finalizer attached to its internal state. We retain --- the close-env entry point as a hook for any future deterministic cleanup --- (e.g. draining the QSem) but do nothing here. -closeEthRpcEnv :: EthRpcEnv -> IO () -closeEthRpcEnv _ = pure () - --- | Make a single eth_call. `to` is the contract address (20 raw bytes); --- `dat` is the ABI-encoded call data. Returns the contract return bytes. -ethCallReal :: EthRpcEnv -> ByteString -> ByteString -> IO (Either EthRpcError ByteString) -ethCallReal EthRpcEnv {manager, request, sem, maxResponseBytes} to dat = - bracket_ (waitQSem sem) (signalQSem sem) $ do - let body = J.encode (rpcEnvelope to dat) - req = request {requestBody = RequestBodyLBS body} - result <- E.try $ withResponse req manager $ \res -> do - let status = responseStatus res - if HT.statusCode status >= 400 - then pure (Left (HttpStatusErr (HT.statusCode status))) - else do - bs <- brReadSome (responseBody res) (maxResponseBytes + 1) - if BL.length bs > fromIntegral maxResponseBytes - then pure (Left BodyTooLarge) - else pure (parseResult (BL.toStrict bs)) - pure (either (Left . HttpFailure) id result) - -rpcEnvelope :: ByteString -> ByteString -> J.Value -rpcEnvelope to dat = - J.object - [ "jsonrpc" J..= ("2.0" :: Text), - "id" J..= (1 :: Int), - "method" J..= ("eth_call" :: Text), - "params" - J..= [ J.object - [ "to" J..= toHex to, - "data" J..= toHex dat - ], - J.String "latest" - ] - ] - -parseResult :: ByteString -> Either EthRpcError ByteString -parseResult bs = case J.eitherDecodeStrict bs of - Left e -> Left (InvalidJson e) - Right (v :: J.Value) -> case J.parseEither parser v of - Left e -> Left (InvalidJson e) - Right r -> r - where - parser :: J.Value -> J.Parser (Either EthRpcError ByteString) - parser = J.withObject "rpc" $ \o -> do - mErr :: Maybe J.Value <- o J..:? "error" - case mErr of - Just (J.Object eo) -> do - code <- (eo J..: "code") <|> pure (-1 :: Int) - msg <- (eo J..: "message") <|> pure ("rpc error" :: Text) - pure (Left (JsonRpcErr code msg)) - _ -> do - result :: Text <- o J..: "result" - case decodeHexResult (encodeUtf8 result) of - Right b -> pure (Right b) - Left e -> pure (Left (InvalidJson e)) - --- | Encode raw bytes as "0x"-prefixed lowercase hex. -toHex :: ByteString -> Text -toHex bs = "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) - --- | Decode a "0x"/"0X"-prefixed hex string (the JSON-RPC result shape). -decodeHexResult :: ByteString -> Either String ByteString -decodeHexResult bs = - BAE.convertFromBase BAE.Base16 $ - fromMaybe bs (B.stripPrefix "0x" bs <|> B.stripPrefix "0X" bs) - --- | Strip userinfo from a URL so log lines never leak credentials. -scrubUrl :: Text -> Text -scrubUrl url = - let (scheme, rest) = T.breakOn "://" url - in if T.null rest - then url - else - let body = T.drop 3 rest - (host, query) = T.breakOn "/" body - in case T.breakOn "@" host of - (_userinfo, atRest) - | not (T.null atRest) -> scheme <> "://" <> T.drop 1 atRest <> query - _ -> url diff --git a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs deleted file mode 100644 index 480332b0b..000000000 --- a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} - --- | SNRC contract codec: Keccak-256 namehash + bounded Solidity ABI decoder. --- --- IMPORTANT: Ethereum uses Keccak-256, NOT NIST SHA3-256. --- --- ABI safety invariants (enforced before any allocation): --- 1. offset + 32 <= buf.length (head read in-bounds) --- 2. offset + 32 + length <= buf.length (body in-bounds) --- 3. offset >= headEnd (no backward jumps) --- 4. every length <= per-field cap (bounded allocations) --- 5. string[] outer count * 32 + offset <= buf.length (array head fits) --- 6. recursion depth <= 2 (no deep nesting) --- 7. uint256 -> Int64 fails if any high 24 bytes non-zero (range check) --- 8. UTF-8 via decodeUtf8' returns AbiBadUtf8 (no partial bytes) -module Simplex.Messaging.Server.Names.Eth.SNRC - ( -- * Namehash - keccak256, - namehash, - - -- * SNRC eth_call payload - snrcSelector, - encodeGetRecord, - - -- * ABI decoding - AbiError (..), - decodeGetRecord, - decodeWord256Int64, - decodeAddress, - decodeString, - decodeUtf8Text, - decodeStringArray, - isZeroOwner, - ) -where - -import Crypto.Hash (Digest, Keccak_256, hash) -import Data.Bifunctor (first) -import qualified Data.ByteArray as BA -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8') -import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), mkNameOwner, unNameOwner) - --- | ABI-decode failure modes (caller collapses to ResolveError EthDecodeErr). -data AbiError - = AbiTruncated - | AbiOversized - | AbiBackwardOffset - | AbiNonZeroHighBytes - | AbiBadUtf8 - | AbiDepthExceeded - | AbiInvariantViolated String - deriving (Eq, Show) - --- | Keccak-256 (Ethereum variant), NOT SHA3-256. -keccak256 :: ByteString -> ByteString -keccak256 = BA.convert . (hash :: ByteString -> Digest Keccak_256) -{-# INLINE keccak256 #-} - --- | ENS / SNRC namehash: recursive keccak256 over reversed labels. --- Empty name -> 32 zero bytes; "a.b.c" -> keccak(keccak(keccak(0 ++ keccak "c") ++ keccak "b") ++ keccak "a"). -namehash :: ByteString -> ByteString -namehash name - | B.null name = zeroNode - | otherwise = foldr step zeroNode (B.split '.' name) - where - zeroNode = B.replicate 32 '\NUL' - step label acc = keccak256 (acc <> keccak256 label) - --- | First 4 bytes of keccak("getRecord(bytes32)"). Confirm signature --- against the Part 1 SNRC contract before merging. -snrcSelector :: ByteString -snrcSelector = B.take 4 (keccak256 "getRecord(bytes32)") - --- | Build the eth_call `data` parameter for getRecord(lookupKey). -encodeGetRecord :: ByteString -> ByteString -encodeGetRecord node32 - | B.length node32 == 32 = snrcSelector <> node32 - | otherwise = snrcSelector <> padLeft32 node32 - -padLeft32 :: ByteString -> ByteString -padLeft32 bs - | n >= 32 = B.take 32 bs - | otherwise = B.replicate (32 - n) '\NUL' <> bs - where - n = B.length bs - --- | Read a uint256 at byte offset, fail if it doesn't fit in *signed* Int64. --- Rejects both (a) any non-zero byte in the high 24 bytes and (b) the high --- bit of the low 8 bytes being set — the latter is essential because Int64 --- would otherwise sign-flip a uint64 value into a negative integer, silently --- corrupting downstream length math. -decodeWord256Int64 :: Int -> ByteString -> Either AbiError Int64 -decodeWord256Int64 off buf - | off + 32 > B.length buf = Left AbiTruncated - | B.any (/= '\NUL') (B.take 24 (B.drop off buf)) = Left AbiNonZeroHighBytes - | B.index buf (off + 24) >= '\x80' = Left AbiNonZeroHighBytes - | otherwise = Right $ B.foldl shiftIn 0 (B.take 8 (B.drop (off + 24) buf)) - where - shiftIn :: Int64 -> Char -> Int64 - shiftIn !acc c = (acc * 256) + fromIntegral (fromEnum c :: Int) -{-# INLINE decodeWord256Int64 #-} - --- | Read an Ethereum address at byte offset (uint256 with high 12 bytes zero). -decodeAddress :: Int -> ByteString -> Either AbiError NameOwner -decodeAddress off buf - | off + 32 > B.length buf = Left AbiTruncated - | B.any (/= toEnum 0) (B.take 12 (B.drop off buf)) = Left (AbiInvariantViolated "address has non-zero high 12 bytes") - | otherwise = first AbiInvariantViolated $ mkNameOwner (B.take 20 (B.drop (off + 12) buf)) - --- | Decode a Solidity `string` whose data starts at byte offset `off`. --- Returns raw bytes; UTF-8 validity is the caller's choice (use --- `decodeUtf8Text` if a Text is required). -decodeString :: Int -> Int -> Int -> ByteString -> Either AbiError ByteString -decodeString headEnd off cap buf - | off < headEnd = Left AbiBackwardOffset - | off + 32 > B.length buf = Left AbiTruncated - | otherwise = do - n <- decodeWord256Int64 off buf - let len = fromIntegral n :: Int - if len > cap - then Left AbiOversized - else - if off + 32 + len > B.length buf - then Left AbiTruncated - else Right $ B.take len (B.drop (off + 32) buf) - --- | Decode a Solidity `string` as Text, failing with AbiBadUtf8 on --- invalid UTF-8. This is what NameRecord decoder composition will use. -decodeUtf8Text :: Int -> Int -> Int -> ByteString -> Either AbiError Text -decodeUtf8Text headEnd off cap buf = do - raw <- decodeString headEnd off cap buf - either (const (Left AbiBadUtf8)) Right (decodeUtf8' raw) - --- | Decode a Solidity `string[]` at byte offset `off`. Each element capped --- at `byteCap` bytes, total element count capped at `cntCap`. Depth must be --- < 2 (recurses one level into decodeString). -decodeStringArray :: Int -> Int -> Int -> Int -> Int -> ByteString -> Either AbiError [ByteString] -decodeStringArray depth headEnd off cntCap byteCap buf - | depth >= 2 = Left AbiDepthExceeded - | off < headEnd = Left AbiBackwardOffset - | off + 32 > B.length buf = Left AbiTruncated - | otherwise = do - n <- decodeWord256Int64 off buf - let cnt = fromIntegral n :: Int - if cnt > cntCap - then Left AbiOversized - else - let arrHead = off + 32 - arrHeadEnd = arrHead + cnt * 32 - in if arrHeadEnd > B.length buf - then Left AbiTruncated - else collectN 0 cnt arrHead arrHeadEnd [] - where - collectN i n base hd acc - | i >= n = Right (reverse acc) - | otherwise = do - relOff <- decodeWord256Int64 (base + i * 32) buf - let absOff = base + fromIntegral relOff - s <- decodeString hd absOff byteCap buf - collectN (i + 1) n base hd (s : acc) - --- | Decode the ABI-encoded return value of getRecord(bytes32) into a NameRecord. --- --- Assumed Solidity signature: --- --- function getRecord(bytes32 node) external view returns ( --- string name, string nickname, string website, string location, --- string simplexContact, string simplexChannel, --- string ETH, string BTC, string XMR, string DOT, --- address owner, uint256 expiry --- ) --- --- Tuple layout: 12 head slots (32 bytes each) followed by length-prefixed --- string data in declaration order. Slots 0-9 are string tail offsets --- (from the start of the buffer, which equals the start of the tuple for --- a top-level eth_call return), slot 10 is the owner address, slot 11 is --- the uint256 expiry. --- --- Zero-owner (0x000...000) is reported as Right Nothing so the caller maps it --- to NotFound (ENS-style sentinel). Records whose on-chain expiry is in the --- past are also reported as Right Nothing — clients trust the server's filter --- and the wire NameRecord carries no expiry field. --- --- `nowSec` is the current Unix time the caller wants the expiry compared --- against. Pass `0` to disable the expiry check (test scenarios); on-chain --- `expiry = 0` means "never expires" (reserved names) and is always accepted. --- --- `resolver` is the SNRC contract address that produced the record (i.e. the --- address the server's eth_call was sent to), populated into `nrResolver` --- since the ABI return doesn't carry it. -decodeGetRecord :: NameOwner -> Int64 -> ByteString -> Either AbiError (Maybe NameRecord) -decodeGetRecord resolver nowSec buf - | B.length buf < headEnd = Left AbiTruncated - | otherwise = do - nameOff <- decodeWord256Int64 (slot 0) buf - nicknameOff <- decodeWord256Int64 (slot 1) buf - websiteOff <- decodeWord256Int64 (slot 2) buf - locationOff <- decodeWord256Int64 (slot 3) buf - simplexContactOff <- decodeWord256Int64 (slot 4) buf - simplexChannelOff <- decodeWord256Int64 (slot 5) buf - ethOff <- decodeWord256Int64 (slot 6) buf - btcOff <- decodeWord256Int64 (slot 7) buf - xmrOff <- decodeWord256Int64 (slot 8) buf - dotOff <- decodeWord256Int64 (slot 9) buf - owner <- decodeAddress (slot 10) buf - expiry <- decodeWord256Int64 (slot 11) buf - if isZeroOwner owner || isExpired nowSec expiry - then pure Nothing - else do - nrName <- decodeStr 255 nameOff - nrNickname <- decodeOptStr 255 nicknameOff - nrWebsite <- decodeOptStr 255 websiteOff - nrLocation <- decodeOptStr 255 locationOff - nrSimplexContact <- decodeOptStr 1024 simplexContactOff - nrSimplexChannel <- decodeOptStr 1024 simplexChannelOff - nrEth <- decodeOptStr 255 ethOff - nrBtc <- decodeOptStr 255 btcOff - nrXmr <- decodeOptStr 255 xmrOff - nrDot <- decodeOptStr 255 dotOff - pure $ - Just - NameRecord - { nrName, - nrNickname, - nrWebsite, - nrLocation, - nrSimplexContact, - nrSimplexChannel, - nrEth, - nrBtc, - nrXmr, - nrDot, - nrOwner = owner, - nrResolver = resolver - } - where - headSlots = 12 :: Int - slotSize = 32 :: Int - headEnd = headSlots * slotSize - slot n = n * slotSize - -- on-chain expiry == 0 means "never expires"; nowSec == 0 disables the check. - isExpired now expiry = now /= 0 && expiry /= 0 && expiry < now - decodeStr cap off = decodeUtf8Text headEnd (fromIntegral off) cap buf - decodeOptStr cap off = nullToNothing <$> decodeStr cap off - nullToNothing t = if T.null t then Nothing else Just t - -isZeroOwner :: NameOwner -> Bool -isZeroOwner = (== B.replicate 20 '\NUL') . unNameOwner diff --git a/src/Simplex/Messaging/Server/Names/HttpResolver.hs b/src/Simplex/Messaging/Server/Names/HttpResolver.hs new file mode 100644 index 000000000..ed314c6de --- /dev/null +++ b/src/Simplex/Messaging/Server/Names/HttpResolver.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | HTTP transport for the public-namespace resolver. +-- +-- The Python REST resolver (see scripts/resolver/snrc-resolve.py) exposes +-- +-- GET /resolve/ -> 200 with a NameRecord JSON document +-- 404 / 400 for unknown names / TLDs +-- 502 for upstream RPC failures +-- GET /health -> 200 when the resolver process is ready +-- +-- Boundary properties: +-- * Response body read with `brReadSome maxResponseBytes` — adversarial +-- endpoints cannot exhaust memory with multi-GB bodies. +-- * `redirectCount = 0` — a compromised resolver cannot bounce credentials +-- to a private-IP target (SSRF amplification on top of the URL validation +-- performed at config load in Server.Main.validateUrl). +-- * Authorization header attached only when configured. +module Simplex.Messaging.Server.Names.HttpResolver + ( RpcAuth (..), + ResolverEnv, + ResolverError (..), + newResolverEnv, + closeResolverEnv, + resolveHttp, + healthHttp, + scrubUrl, + ) +where + +import qualified Control.Exception as E +import qualified Data.Aeson as J +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Network.HTTP.Client + ( HttpException, + Manager, + ManagerSettings (..), + Request, + brReadSome, + parseRequest, + redirectCount, + requestHeaders, + responseBody, + responseStatus, + responseTimeoutMicro, + withResponse, + ) +import qualified Network.HTTP.Client as HC +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.URI (urlEncode) + +data RpcAuth = AuthBearer Text | AuthBasic Text Text + +-- | Redacts the bearer token / basic-auth password so an accidental +-- `show` / `tshow` on NamesConfig never lands secrets in logs. +instance Show RpcAuth where + show (AuthBearer _) = "AuthBearer " + show (AuthBasic u _) = "AuthBasic " <> show u <> " " + +data ResolverEnv = ResolverEnv + { manager :: Manager, + baseUrl :: Text, + authHdr :: [HT.Header], + timeoutMicro :: Int, + maxResponseBytes :: Int + } + +data ResolverError + = HttpFailure HttpException + | HttpStatusErr Int + | BodyTooLarge + | InvalidJson String + deriving (Show) + +newResolverEnv :: Text -> Maybe RpcAuth -> Int -> Int -> IO ResolverEnv +newResolverEnv baseUrl auth_ timeoutMs maxResponseBytes = do + manager <- HC.newManager tlsManagerSettings {managerConnCount = 10} + pure + ResolverEnv + { manager, + baseUrl = stripTrailingSlash baseUrl, + authHdr = maybe [] (pure . authHeader) auth_, + timeoutMicro = timeoutMs * 1000, + maxResponseBytes + } + +-- | http-client's `closeManager` is a deprecated no-op since 0.5; the +-- manager is released by the GC finalizer on its internal state. Hook kept +-- as a future-cleanup seam. +closeResolverEnv :: ResolverEnv -> IO () +closeResolverEnv _ = pure () + +authHeader :: RpcAuth -> HT.Header +authHeader = \case + AuthBearer tok -> ("Authorization", "Bearer " <> encodeUtf8 tok) + AuthBasic u p -> + let encoded = BAE.convertToBase BAE.Base64 (encodeUtf8 u <> ":" <> encodeUtf8 p) :: ByteString + in ("Authorization", "Basic " <> encoded) + +-- | GET /resolve/, return the JSON body on 200. +resolveHttp :: ResolverEnv -> Text -> IO (Either ResolverError J.Value) +resolveHttp env name = doGet env ("/resolve/" <> percentEncode name) + +-- | GET /health, return the JSON body on 200. +healthHttp :: ResolverEnv -> IO (Either ResolverError J.Value) +healthHttp env = doGet env "/health" + +doGet :: ResolverEnv -> Text -> IO (Either ResolverError J.Value) +doGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes} path = do + req0 <- parseRequest (T.unpack (baseUrl <> path)) + let req = + req0 + { redirectCount = 0, + requestHeaders = ("Accept", "application/json") : authHdr, + HC.responseTimeout = responseTimeoutMicro timeoutMicro + } + result <- E.try $ withResponse req manager $ \res -> do + let status = HT.statusCode (responseStatus res) + if status >= 400 + then pure (Left (HttpStatusErr status)) + else do + bs <- brReadSome (responseBody res) (maxResponseBytes + 1) + if BL.length bs > fromIntegral maxResponseBytes + then pure (Left BodyTooLarge) + else case J.eitherDecodeStrict (BL.toStrict bs) of + Left e -> pure (Left (InvalidJson e)) + Right v -> pure (Right v) + pure (either (Left . HttpFailure) id result) + +-- | Percent-encode a name component (path-safe). Aggressive: encode every +-- byte that isn't an unreserved character per RFC 3986. The resolver expects +-- raw labels (e.g., `alice.simplex`); slashes and other ASCII punctuation +-- would change the request path semantics if passed through verbatim. +percentEncode :: Text -> Text +percentEncode = decodeLatin1 . urlEncode True . encodeUtf8 + +stripTrailingSlash :: Text -> Text +stripTrailingSlash t = case T.unsnoc t of + Just (rest, '/') -> rest + _ -> t + +-- | Strip userinfo from a URL so log lines never leak credentials. +scrubUrl :: Text -> Text +scrubUrl url = + let (scheme, rest) = T.breakOn "://" url + in if T.null rest + then url + else + let body = T.drop 3 rest + (host, query) = T.breakOn "/" body + in case T.breakOn "@" host of + (_userinfo, atRest) + | not (T.null atRest) -> scheme <> "://" <> T.drop 1 atRest <> query + _ -> url diff --git a/src/Simplex/Messaging/SimplexName/Contracts.hs b/src/Simplex/Messaging/SimplexName/Contracts.hs deleted file mode 100644 index 0b6275d63..000000000 --- a/src/Simplex/Messaging/SimplexName/Contracts.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Single source of truth for TLD -> SNRC contract address. --- Both the agent (which sends the contract in RslvRequest so the server --- can refuse mismatched calls) and the server (which checks the --- client-supplied contract against this mapping in verifyRslv) read --- from here. Lock-step bumps land in one place. -module Simplex.Messaging.SimplexName.Contracts - ( tldContract, - ) -where - -import qualified Data.ByteString.Char8 as B -import Simplex.Messaging.Names.Owner (NameOwner, mkNameOwner) -import Simplex.Messaging.SimplexName (SimplexTLD (..)) - --- | Map a TLD to its SNRC contract address. `Nothing` means the TLD has --- no SimpleX-native registry (e.g., `TLDWeb` is reserved for external --- web domains and never resolved on-chain via this stack). --- --- Both bytes are placeholders pending the live SNRC deployment; update --- here and the change is observed atomically by agent and server. -tldContract :: SimplexTLD -> Maybe NameOwner -tldContract = \case - TLDSimplex -> Just (placeholder '\x11') - TLDTesting -> Just (placeholder '\x22') - TLDWeb -> Nothing - where - placeholder c = either error id (mkNameOwner (B.replicate 20 c)) diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs index 5d092063b..711dbca10 100644 --- a/tests/AgentTests/ResolveNameTests.hs +++ b/tests/AgentTests/ResolveNameTests.hs @@ -12,94 +12,68 @@ -- | End-to-end tests for `Simplex.Messaging.Agent.resolveSimplexName`. -- --- Exercises the agent layer (real `AgentClient`) against an SMP server with --- a stub `NamesEnv` — same pattern as `RSLVTests` but going through --- `sendOrProxySMPCommand` so we cover the agent-side direct/proxy selection --- and the agent's error mapping (`SMP host AUTH`, `PROXY {.. proxyErr ..}`, --- `INTERNAL ..`). +-- Exercises the agent layer (real `AgentClient`) against an SMP server +-- whose `NamesEnv` is a stub `ResolverCall` — same pattern as `RSLVTests` +-- but going through `sendOrProxySMPCommand` so we cover the agent-side +-- direct/proxy selection and the agent's error mapping. module AgentTests.ResolveNameTests (resolveNameTests) where import AgentTests.FunctionalAPITests (withAgent) import Control.Monad.Except (runExceptT) -import qualified Data.ByteString.Char8 as B +import qualified Data.Aeson as J import Data.List (isInfixOf) import SMPAgentClient import SMPClient -import SMPNamesTests (encodeRecordAbi) +import SMPNamesTests (sampleRecord, sampleRecordJSON) import Simplex.Messaging.Agent (resolveSimplexName) import Simplex.Messaging.Agent.Client (AgentClient) import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive) -import Simplex.Messaging.Protocol (NameRecord (..), mkNameOwner, pattern SMPServer) +import Simplex.Messaging.Protocol (pattern SMPServer) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) -import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnvWith) -import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError) +import Simplex.Messaging.Server.Names + ( NamesConfig (..), + NamesEnv, + ResolverCall, + ResolverCallKind (..), + newNamesEnvWith, + ) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) import Simplex.Messaging.Transport import Test.Hspec hiding (fit, it) import Util (it) --- --------------------------------------------------------------------------- --- Fixtures (parallel to RSLVTests) --- --------------------------------------------------------------------------- - --- 12 slots * 32 bytes, all zero. `decodeGetRecord` reads the owner from --- slot 10 and treats the zero address as the NotFound sentinel, so the --- resolver maps to `ResolveError.NotFound` -> server `ERR AUTH`. -zeroOwnerAbi :: B.ByteString -zeroOwnerAbi = B.replicate (32 * 12) '\NUL' - stubNamesConfig :: NamesConfig stubNamesConfig = NamesConfig - { ethereumEndpoint = "http://stub", - rpcAuth = Nothing, - rpcTimeoutMs = 1000, - rpcMaxResponseBytes = 65536, - rpcMaxConcurrency = 4 + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 } -stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) -stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) - --- | A complete NameRecord used by the success-path test. The decoder fills --- `nrResolver` from the contract address the server's ethCall was sent to --- (i.e. the simplex TLD contract); the test asserts against that value. -aliceRecord :: NameRecord -aliceRecord = - NameRecord - { nrName = "alice.simplex", - nrNickname = Just "Alice", - nrWebsite = Just "https://alice.example", - nrLocation = Just "Earth", - nrSimplexContact = Just "simplex:/contact/abc#xyz", - nrSimplexChannel = Nothing, - nrEth = Just "0x0000000000000000000000000000000000000001", - nrBtc = Nothing, - nrXmr = Nothing, - nrDot = Nothing, - nrOwner = either error id (mkNameOwner (B.replicate 20 '\x33')), - -- Overwritten by the decoder; the placeholder here is never observed. - nrResolver = either error id (mkNameOwner (B.replicate 20 '\xFF')) - } +-- | 404 stub: the resolver returns "not registered". Server maps to ERR +-- AUTH; agent surfaces as SMP host AUTH. +stubResolverNotFound :: ResolverCall +stubResolverNotFound = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 404)) + ResolverHealth -> pure (Right (J.object [])) --- | Stub returning a valid ABI buffer for the success path (expiry = 0 -> --- never expires). -stubEthCallSuccess :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) -stubEthCallSuccess _to _data = pure (Right (encodeRecordAbi aliceRecord 0)) +-- | Success stub: returns the canned NameRecord JSON. +stubResolverSuccess :: ResolverCall +stubResolverSuccess = \case + ResolverFetch _ -> pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) --- | Names env using the static `tldContract` mapping: TLDSimplex and --- TLDTesting map to placeholder contracts; TLDWeb is unmapped and rejected --- by the resolver's `verifyRslv`. -mkSimplexOnlyNamesEnv :: IO NamesEnv -mkSimplexOnlyNamesEnv = newNamesEnvWith stubNamesConfig stubEthCallNotFound Nothing +mkNotFoundNamesEnv :: IO NamesEnv +mkNotFoundNamesEnv = newNamesEnvWith stubNamesConfig stubResolverNotFound Nothing --- | Same as `mkSimplexOnlyNamesEnv` but the stub returns a real record. mkSuccessNamesEnv :: IO NamesEnv -mkSuccessNamesEnv = newNamesEnvWith stubNamesConfig stubEthCallSuccess Nothing +mkSuccessNamesEnv = newNamesEnvWith stubNamesConfig stubResolverSuccess Nothing memCfg :: AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) @@ -107,9 +81,6 @@ memCfg = cfgMS (ASType SQSMemory SMSMemory) memProxyCfg :: AServerConfig memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) --- Second-server `memCfg` variant on `testStoreLogFile2` so the two servers --- can coexist on the same machine (StoreLog locks `testStoreLogFile`); see --- RSLVTests `memCfg2` for the same workaround. memCfg2 :: AServerConfig memCfg2 = case memCfg of ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)} @@ -119,9 +90,6 @@ memCfg2 = case memCfg of SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2}) other -> other --- | Single resolver server on `testPort`, paired with an agent configured --- for direct sends (SPMNever). The agent's only configured server is the --- resolver itself. withDirectResolver :: NamesEnv -> (AgentClient -> IO a) -> IO a withDirectResolver nenv k = withSmpServerConfigOnWithNames (transport @TLS) memCfg testPort nenv $ \_ -> @@ -129,11 +97,6 @@ withDirectResolver nenv k = where directServers = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = userServers [testSMPServer]} --- | Two-server setup for the proxy path. Proxy on `testPort` (no NamesEnv — --- proxy doesn't resolve locally), resolver on `testPort2` (stub NamesEnv). --- Agent's user-server list contains both, with SPMAlways so it always picks --- a proxy. `getNextServer` excludes the destination from candidates, so the --- agent picks the first server (proxy) when sending to the second (resolver). withProxyAndResolver :: NamesEnv -> (AgentClient -> IO a) -> IO a withProxyAndResolver nenv k = withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> @@ -142,8 +105,6 @@ withProxyAndResolver nenv k = where proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = userServers [testSMPServer, testSMPServer2]} --- The resolver address corresponds to whichever server has the stub NamesEnv: --- single-server -> testPort; two-server -> testPort2. directResolverSrv :: SMP.SMPServer directResolverSrv = SMPServer testHost testPort testKeyHash @@ -158,13 +119,13 @@ resolveNameTests :: Spec resolveNameTests = do describe "Agent resolveSimplexName" $ do describe "direct path (SPMNever)" $ - it "AUTH propagates as SMP host AUTH (zero-owner stub -> NotFound)" testDirectAuth + it "AUTH propagates as SMP host AUTH (resolver 404 -> NotFound)" testDirectAuth describe "proxy path (SPMAlways)" $ it "AUTH from resolver propagates via proxy as SMP AUTH" testProxyAuth describe "TLDTesting path" $ - it "AUTH (zero-owner stub -> NotFound) for TLDTesting too" testUnknownTldOnServer - describe "TLD without contract entry" $ - it "INTERNAL (TLDWeb has no tldContract entry)" testNoAgentContract + it "AUTH (resolver 404 -> NotFound) for TLDTesting too" testTestingTldAuth + describe "TLDWeb path" $ + it "AUTH (resolver 404 -> NotFound) for TLDWeb too" testWebTldAuth describe "success path" $ it "returns NameRecord" testDirectSuccess @@ -173,11 +134,11 @@ resolveNameTests = do -- --------------------------------------------------------------------------- -- | Direct path: agent with SPMNever sends RSLV without PFWD; resolver --- replies ERR AUTH (placeholder decoder -> NotFound); agent maps the SMP --- protocol error to `SMP host AUTH` (Client.hs:1255 -> protocolError_). +-- replies 404 (not found); server returns ERR AUTH; agent maps to +-- `SMP host AUTH`. testDirectAuth :: HasCallStack => IO () testDirectAuth = do - nenv <- mkSimplexOnlyNamesEnv + nenv <- mkNotFoundNamesEnv withDirectResolver nenv $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv simplexDomain case r of @@ -186,21 +147,12 @@ testDirectAuth = do where simplexDomain = SimplexNameDomain TLDSimplex "alice" [] --- | Proxy path: agent with SPMAlways wraps RSLV in PFWD; proxy forwards to --- the resolver, which replies ERR AUTH (placeholder decoder -> NotFound). --- The proxy's `proxySMPCommand` wraps a destination-relay protocol error in --- `throwE $ PCEProtocolError AUTH` (Client.hs:1231), which `liftClient SMP` --- in `sendOrProxySMPCommand` (Client.hs:1179) surfaces as `SMP proxyHost AUTH`. --- The agent-level `PROXY` constructor is reserved for proxy-side failures --- (e.g. PROXY NO_SESSION); relay-level protocol errors are reported --- transparently as SMP errors — this is the "transparent for AUTH/QUOTA" --- contract documented at Client.hs:1178. --- --- Note the host is the proxy server's host (testPort/5001), not the resolver --- — this is the proxy server the agent is connected to for forwarding. +-- | Proxy path: relay-level protocol errors are reported transparently as +-- SMP errors with the proxy host (see Client.hs:1178 "transparent for +-- AUTH/QUOTA"). testProxyAuth :: HasCallStack => IO () testProxyAuth = do - nenv <- mkSimplexOnlyNamesEnv + nenv <- mkNotFoundNamesEnv withProxyAndResolver nenv $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 proxiedResolverSrv simplexDomain case r of @@ -209,14 +161,11 @@ testProxyAuth = do where simplexDomain = SimplexNameDomain TLDSimplex "alice" [] --- | TLDTesting maps (on both agent and server, via the static --- `tldContract`) to its own placeholder contract. With the placeholder --- decoder the resolver collapses any non-zero buffer to NotFound, so the --- agent surfaces `SMP host AUTH`. Sanity-check that the non-default TLD --- routes through the same code path as TLDSimplex. -testUnknownTldOnServer :: HasCallStack => IO () -testUnknownTldOnServer = do - nenv <- mkSimplexOnlyNamesEnv +-- | TLDTesting routes through the same code path as TLDSimplex (the contract +-- field is ignored server-side; the resolver decides which registry to query). +testTestingTldAuth :: HasCallStack => IO () +testTestingTldAuth = do + nenv <- mkNotFoundNamesEnv withDirectResolver nenv $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv testingDomain case r of @@ -225,34 +174,30 @@ testUnknownTldOnServer = do where testingDomain = SimplexNameDomain TLDTesting "bob" [] --- | Pure agent-side test: `tldContract TLDWeb = Nothing` --- (SimplexName.Contracts), so `resolveSimplexName'` throws INTERNAL before --- any server contact. The agent still needs initialisation, but no server --- bracket: the throw happens before any network IO. -testNoAgentContract :: HasCallStack => IO () -testNoAgentContract = - withAgent 1 agentCfg agentServers testDB $ \c -> do +-- | TLDWeb is no longer a TLDContract-gated short-circuit on the agent side; +-- the agent forwards the request to the server, which forwards to the +-- resolver, which decides (per its configured TLDs) whether to honour the +-- lookup. The stub here returns 404 for every fetch, so we get AUTH. +testWebTldAuth :: HasCallStack => IO () +testWebTldAuth = do + nenv <- mkNotFoundNamesEnv + withDirectResolver nenv $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv webDomain case r of - Left (INTERNAL msg) | "no resolver contract for TLD" `isInfixOf` msg -> pure () - _ -> expectationFailure $ "expected Left (INTERNAL \"... no resolver contract for TLD\"), got: " <> show r + Left (SMP _ SMP.AUTH) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ AUTH), got: " <> show r where webDomain = SimplexNameDomain TLDWeb "example.com" [] - -- Non-empty userServers is required for agent init; never contacted. - agentServers = initAgentServers {smp = userServers [testSMPServer]} --- | Success path: stub returns a valid ABI buffer, the agent receives a --- decoded NameRecord. The decoder populates `nrResolver` with the contract --- the server's ethCall was sent to (i.e. `tldContract TLDSimplex`), so the --- expected record's resolver is `'\x11'`-bytes (see Contracts.hs). +-- | Success path: stub returns a real NameRecord. The agent surfaces it +-- verbatim. testDirectSuccess :: HasCallStack => IO () testDirectSuccess = do nenv <- mkSuccessNamesEnv withDirectResolver nenv $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 directResolverSrv simplexDomain case r of - Right nr -> nr `shouldBe` aliceRecord {nrResolver = simplexContract} + Right nr -> nr `shouldBe` sampleRecord _ -> expectationFailure $ "expected Right NameRecord, got: " <> show r where simplexDomain = SimplexNameDomain TLDSimplex "alice" [] - simplexContract = either error id (mkNameOwner (B.replicate 20 '\x11')) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 0578a9cbd..f6ada606d 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -11,24 +11,26 @@ -- | Functional-API tests for the public-namespace resolver (RSLV). -- --- Mocks the resolver at the `ethCall` layer using `newNamesEnvWith`. Tests: --- * direct RSLV (post-`ecd89cf1`) is accepted (not `CMD PROHIBITED`) --- * `ERR AUTH` for contract / TLD config mismatches (verifyRslv layer) --- * `ERR AUTH` for backend `NotFound` (zero-owner sentinel) --- * `ERR AUTH` for backend transport errors +-- Mocks the resolver at the `resolverCall` layer using `newNamesEnvWith`. +-- Tests: +-- * direct RSLV is accepted (not `CMD PROHIBITED`) +-- * `ERR AUTH` for malformed names (parseName layer) +-- * `ERR AUTH` for backend `NotFound` (404 / 400 from the HTTP resolver) +-- * `ERR AUTH` for backend transport errors (HTTP 502 or transport failure) -- * `ERR AUTH` when the server has no `namesEnv` (rslvDisabled) --- * `NAME` returned when the ABI buffer decodes to a real record +-- * `NAME` returned when the resolver returns a valid JSON record -- * the same paths via PFWD round-trip (proxy + resolver wiring works) module RSLVTests (rslvTests) where import Control.Monad.Trans.Except (ExceptT, runExceptT) +import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty (..)) import Data.Time.Clock (getCurrentTime) import SMPClient import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C -import SMPNamesTests (encodeRecordAbi) +import SMPNamesTests (sampleRecord, sampleRecordJSON) import Simplex.Messaging.Protocol ( BrokerMsg (..), Cmd (..), @@ -36,7 +38,6 @@ import Simplex.Messaging.Protocol CorrId (..), ErrorType (..), NameOwner, - NameRecord (..), RslvRequest (..), SParty (..), Transmission, @@ -53,9 +54,11 @@ import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.Names ( NamesConfig (..), NamesEnv, + ResolverCall, + ResolverCallKind (..), newNamesEnvWith, ) -import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcError (..)) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec hiding (fit, it) @@ -68,75 +71,41 @@ import Util (it) unsafeOwner :: B.ByteString -> NameOwner unsafeOwner = either error id . mkNameOwner --- contract address configured in the server's TLD registry -serverContract :: NameOwner -serverContract = unsafeOwner (B.replicate 20 '\x11') - --- a different contract address (client points at the wrong one) -otherContract :: NameOwner -otherContract = unsafeOwner (B.replicate 20 '\x22') - --- 12 slots * 32 bytes, all zero — `decodeGetRecord` treats slot 10 (owner) as --- the zero sentinel and returns `Right Nothing` -> resolver maps to NotFound. -zeroOwnerAbi :: B.ByteString -zeroOwnerAbi = B.replicate (32 * 12) '\NUL' +-- A placeholder contract used in RslvRequest. The server ignores the +-- contract field, so the value doesn't affect behaviour. +placeholderContract :: NameOwner +placeholderContract = unsafeOwner (B.replicate 20 '\NUL') stubNamesConfig :: NamesConfig stubNamesConfig = NamesConfig - { ethereumEndpoint = "http://stub", - rpcAuth = Nothing, - rpcTimeoutMs = 1000, - rpcMaxResponseBytes = 65536, - rpcMaxConcurrency = 4 + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 } --- | Default stub: returns the all-zero ABI buffer. The decoder treats the --- zero owner address as the NotFound sentinel -> resolver returns --- `ResolveError.NotFound` -> server `ERR AUTH`. -stubEthCallNotFound :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) -stubEthCallNotFound _to _data = pure (Right zeroOwnerAbi) +-- | Default stub: the resolver replies 404. Server maps to NotFound -> AUTH. +stubResolverNotFound :: ResolverCall +stubResolverNotFound = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 404)) + ResolverHealth -> pure (Right (J.object [])) --- | Stub that always raises a transport-layer error (e.g. operator pointed --- at the wrong endpoint). Server should map to `ERR AUTH` via --- `rslvEthErrs` selector. We use `BodyTooLarge` because `HttpFailure` wraps --- an `HttpException` value which is not easily constructed in tests; both --- map to `EthHttpErr` via `mapEthRpcError`. -stubEthCallHttpErr :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) -stubEthCallHttpErr _to _data = pure (Left BodyTooLarge) - --- | Stub that returns a valid ABI buffer for the success-path test. The --- buffer encodes `aliceRecord` with no expiry (0 = never expires); the --- decoder fills in `nrResolver` from the caller's contract argument, so the --- test asserts on a record where `nrResolver = serverContract`. -aliceRecord :: NameRecord -aliceRecord = - NameRecord - { nrName = "alice.simplex", - nrNickname = Just "Alice", - nrWebsite = Just "https://alice.example", - nrLocation = Just "Earth", - nrSimplexContact = Just "simplex:/contact/abc#xyz", - nrSimplexChannel = Nothing, - nrEth = Just "0x0000000000000000000000000000000000000001", - nrBtc = Nothing, - nrXmr = Nothing, - nrDot = Nothing, - nrOwner = unsafeOwner (B.replicate 20 '\x33'), - -- Will be overwritten by the decoder using the contract address the - -- server's ethCall was sent to (i.e. `serverContract`). - nrResolver = unsafeOwner (B.replicate 20 '\xFF') - } +-- | Stub that returns a 502 upstream-RPC failure on resolve. Server maps to +-- ResolverError -> ERR AUTH via `rslvEthErrs`. +stubResolverHttpErr :: ResolverCall +stubResolverHttpErr = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 502)) + ResolverHealth -> pure (Right (J.object [])) -stubEthCallSuccess :: B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString) -stubEthCallSuccess _to _data = pure (Right (encodeRecordAbi aliceRecord 0)) +-- | Stub returning a real NameRecord JSON value (success path). +stubResolverSuccess :: ResolverCall +stubResolverSuccess = \case + ResolverFetch _ -> pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) --- | Names env using the static TLD->contract mapping in --- `SimplexName.Contracts.tldContract`: TLDSimplex maps to `serverContract`, --- TLDTesting to a different placeholder, and TLDWeb is unmapped (rejected --- by `verifyRslv`). -mkSimplexOnlyNamesEnv :: (B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString)) -> IO NamesEnv -mkSimplexOnlyNamesEnv eth = newNamesEnvWith stubNamesConfig eth Nothing +mkNamesEnv :: ResolverCall -> IO NamesEnv +mkNamesEnv stub = newNamesEnvWith stubNamesConfig stub Nothing memCfg :: AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) @@ -144,40 +113,24 @@ memCfg = cfgMS (ASType SQSMemory SMSMemory) memProxyCfg :: AServerConfig memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) --- | Second-server variant of `memCfg` that uses the `.2` store paths so it --- can coexist with a first server using `memCfg` on the same machine --- (StoreLog locks `testStoreLogFile`). `updateCfg` doesn't help here --- because `serverStoreCfg` is GADT-typed; instead we override the field --- directly inside the existential. memCfg2 :: AServerConfig memCfg2 = case memCfg of ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)} where - -- For SMSMemory the storeCfg is `SSCMemory (Maybe StorePaths)`; for any - -- other store the original is kept unchanged. newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s newStoreCfg = \case SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2}) other -> other --- | Run a single SMP server with stub `NamesEnv` on `testPort`. withResolverServer :: NamesEnv -> IO a -> IO a withResolverServer nenv = withSmpServerConfigOnWithNames (transport @TLS) memCfg testPort nenv . const --- | Two-server setup for PFWD RSLV. Proxy on `testPort` (no NamesEnv — --- proxy doesn't resolve locally); resolver on `testPort2` (stub NamesEnv). withProxyAndResolver :: NamesEnv -> IO a -> IO a withProxyAndResolver nenv runTest = withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> withSmpServerConfigOnWithNames (transport @TLS) memCfg2 testPort2 nenv (const runTest) --- --------------------------------------------------------------------------- --- Direct-RSLV send/recv on a raw THandle --- --------------------------------------------------------------------------- - --- RSLV is `noAuthCmd` (Protocol.hs:1974) — sent unsigned. Helper sends one --- transmission and reads the single-element batched response. sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> RslvRequest -> IO (Transmission (Either ErrorType BrokerMsg)) sendRslv h@THandle {params} corrId req = do let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV req)) @@ -193,81 +146,58 @@ rslvTests :: Spec rslvTests = do describe "RSLV direct (non-forwarded)" $ do it "server accepts RSLV without PFWD (not CMD PROHIBITED)" testRslvDirectAccepted - it "AUTH when contract address does not match TLD config" testRslvWrongContract - it "AUTH when TLD has no contract configured" testRslvUnknownTld - it "AUTH when backend reports zero owner (NotFound via decoder)" testRslvBackendNotFound - it "AUTH when backend transport fails (EthHttpErr)" testRslvBackendHttpErr + it "AUTH when name is malformed (bare label, no TLD)" testRslvBadName + it "AUTH when resolver replies 404 (not registered)" testRslvBackendNotFound + it "AUTH when resolver replies 502 (upstream failure)" testRslvBackendHttpErr it "AUTH when server has no names config (namesEnv = Nothing)" testRslvDisabled describe "RSLV forwarded (PFWD)" $ do it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError AUTH)" testRslvForwarded describe "RSLV success path (NAME response)" $ do it "returns NAME with NameRecord" testRslvSuccess --- --- direct path ----------------------------------------------------------- - testRslvDirectAccepted :: IO () testRslvDirectAccepted = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + nenv <- mkNamesEnv stubResolverNotFound withResolverServer nenv $ testSMPClient @TLS $ \h -> do - (corrId, _entId, resp) <- sendRslv h "rs01" RslvRequest {name = "alice.simplex", contract = serverContract} - -- Zero-owner stub buffer -> NotFound -> AUTH. The point of this test - -- is that the server accepted RSLV at all (CMD PROHIBITED would mean - -- the no-PFWD path was rejected). + (corrId, _entId, resp) <- sendRslv h "rs01" RslvRequest {name = "alice.simplex", contract = placeholderContract} corrId `shouldBe` CorrId "rs01" resp `shouldBe` Right (ERR AUTH) -testRslvWrongContract :: IO () -testRslvWrongContract = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound +testRslvBadName :: IO () +testRslvBadName = do + nenv <- mkNamesEnv stubResolverNotFound withResolverServer nenv $ testSMPClient @TLS $ \h -> do - -- contract mismatch is caught by `verifyRslv` before any ethCall. - (_, _, resp) <- sendRslv h "rs02" RslvRequest {name = "alice.simplex", contract = otherContract} - resp `shouldBe` Right (ERR AUTH) - -testRslvUnknownTld :: IO () -testRslvUnknownTld = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound - withResolverServer nenv $ - testSMPClient @TLS $ \h -> do - -- TLDWeb has no entry in the static `tldContract` mapping; - -- verifyRslv -> Nothing -> AUTH. - (_, _, resp) <- sendRslv h "rs03" RslvRequest {name = "example.web", contract = serverContract} + (_, _, resp) <- sendRslv h "rs02" RslvRequest {name = "alice", contract = placeholderContract} resp `shouldBe` Right (ERR AUTH) testRslvBackendNotFound :: IO () testRslvBackendNotFound = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + nenv <- mkNamesEnv stubResolverNotFound withResolverServer nenv $ testSMPClient @TLS $ \h -> do - (_, _, resp) <- sendRslv h "rs04" RslvRequest {name = "ghost.simplex", contract = serverContract} + (_, _, resp) <- sendRslv h "rs04" RslvRequest {name = "ghost.simplex", contract = placeholderContract} resp `shouldBe` Right (ERR AUTH) testRslvBackendHttpErr :: IO () testRslvBackendHttpErr = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallHttpErr + nenv <- mkNamesEnv stubResolverHttpErr withResolverServer nenv $ testSMPClient @TLS $ \h -> do - (_, _, resp) <- sendRslv h "rs05" RslvRequest {name = "alice.simplex", contract = serverContract} - -- EthHttpErr maps to ERR AUTH (rslvEthErrs selector). + (_, _, resp) <- sendRslv h "rs05" RslvRequest {name = "alice.simplex", contract = placeholderContract} resp `shouldBe` Right (ERR AUTH) testRslvDisabled :: IO () -testRslvDisabled = do - -- Default cfgMS sets `namesConfig = Nothing` and we do NOT inject an - -- override -> server's `namesEnv = Nothing` -> RSLV returns AUTH via - -- the `rslvDisabled` selector path. +testRslvDisabled = withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $ testSMPClient @TLS $ \h -> do - (_, _, resp) <- sendRslv h "rs06" RslvRequest {name = "alice.simplex", contract = serverContract} + (_, _, resp) <- sendRslv h "rs06" RslvRequest {name = "alice.simplex", contract = placeholderContract} resp `shouldBe` Right (ERR AUTH) --- --- PFWD path ------------------------------------------------------------- - testRslvForwarded :: IO () testRslvForwarded = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallNotFound + nenv <- mkNamesEnv stubResolverNotFound withProxyAndResolver nenv $ do g <- C.newRandom ts <- getCurrentTime @@ -276,26 +206,21 @@ testRslvForwarded = do cfg' = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} pcE <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) cfg' [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pcE - -- proxyCfgMS has no `newQueueBasicAuth`; PRXY with Nothing succeeds. sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing) - -- The destination relay replies ERR AUTH; proxy decodes and reports as - -- `PCEProtocolError AUTH`; `proxyResolveName` lets that throwE propagate. - r <- runExceptT (proxyResolveName pc NRMInteractive sess serverContract "alice.simplex") + r <- runExceptT (proxyResolveName pc NRMInteractive sess placeholderContract "alice.simplex") case r of Left (PCEProtocolError SMP.AUTH) -> pure () _ -> expectationFailure $ "expected Left (PCEProtocolError AUTH), got: " <> show r --- --- success path ---------------------------------------------------------- - testRslvSuccess :: IO () testRslvSuccess = do - nenv <- mkSimplexOnlyNamesEnv stubEthCallSuccess + nenv <- mkNamesEnv stubResolverSuccess withResolverServer nenv $ testSMPClient @TLS $ \h -> do - (corrId, _entId, resp) <- sendRslv h "rs07" RslvRequest {name = "alice.simplex", contract = serverContract} + (corrId, _entId, resp) <- sendRslv h "rs07" RslvRequest {name = "alice.simplex", contract = placeholderContract} corrId `shouldBe` CorrId "rs07" case resp of - Right (NAME nr) -> nr `shouldBe` aliceRecord {nrResolver = serverContract} + Right (NAME nr) -> nr `shouldBe` sampleRecord _ -> expectationFailure $ "expected Right (NAME ..), got: " <> show resp runExceptT' :: Show e => ExceptT e IO a -> IO a diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 30c177881..d7e83b2c9 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -1,113 +1,52 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module SMPNamesTests (smpNamesTests, encodeRecordAbi) where +module SMPNamesTests (smpNamesTests, sampleRecord, sampleRecordJSON) where -import qualified Crypto.Hash as Crypton -import Data.Bits (shiftR, (.&.)) -import Data.ByteString.Char8 (ByteString) +import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B -import qualified Data.ByteArray as BA +import qualified Data.ByteString.Lazy as LB import Data.Either (isLeft, isRight) -import Data.Foldable (for_) -import Data.Int (Int64) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (sort) -import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Word (Word8) -import qualified Data.Aeson as J -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy as LB -import Simplex.Messaging.Protocol - ( NameOwner, - NameRecord (..), - RslvRequest (..), - mkNameOwner, - unNameOwner, - ) +import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), RslvRequest (..), mkNameOwner, unNameOwner) import Simplex.Messaging.Server.Names ( NamesConfig (..), ResolveError (..), + ResolverCallKind (..), newNamesEnvWith, + parseName, + pingEndpoint, resolveName, - verifyRslv, - ) -import Simplex.Messaging.SimplexName.Contracts (tldContract) -import Simplex.Messaging.Server.Names.Eth.SNRC - ( AbiError (..), - decodeAddress, - decodeGetRecord, - decodeString, - decodeStringArray, - decodeWord256Int64, - encodeGetRecord, - keccak256, - namehash, - snrcSelector, ) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) import Test.Hspec --- Reference vectors: --- keccak256("") = c5d2460186f7233c927e7db2dcc703c0e500b653ca8227b7bfad8045d85a470 --- keccak256("abc") = 4e03657aea45a94fc7d47ba826c8d667c0d1e6e33a64a036ec44f58fa12d6c45 --- sha3_256("abc") = 3a985da74fe225b2045c172d6bd390bd855f086e3e9d525b46bfe24511431532 --- namehash("eth") = 93cdeb708b7545dc668eb9280176169d1c33cfd8ed6f04690a0bcc88a93fc4ae - -keccak256Empty :: ByteString -keccak256Empty = "\xc5\xd2\x46\x01\x86\xf7\x23\x3c\x92\x7e\x7d\xb2\xdc\xc7\x03\xc0\xe5\x00\xb6\x53\xca\x82\x27\x3b\x7b\xfa\xd8\x04\x5d\x85\xa4\x70" - -keccak256Abc :: ByteString -keccak256Abc = "\x4e\x03\x65\x7a\xea\x45\xa9\x4f\xc7\xd4\x7b\xa8\x26\xc8\xd6\x67\xc0\xd1\xe6\xe3\x3a\x64\xa0\x36\xec\x44\xf5\x8f\xa1\x2d\x6c\x45" - -sha3_256Abc :: ByteString -sha3_256Abc = "\x3a\x98\x5d\xa7\x4f\xe2\x25\xb2\x04\x5c\x17\x2d\x6b\xd3\x90\xbd\x85\x5f\x08\x6e\x3e\x9d\x52\x5b\x46\xbf\xe2\x45\x11\x43\x15\x32" - -namehashEth :: ByteString -namehashEth = "\x93\xcd\xeb\x70\x8b\x75\x45\xdc\x66\x8e\xb9\x28\x01\x76\x16\x9d\x1c\x33\xcf\xd8\xed\x6f\x04\x69\x0a\x0b\xcc\x88\xa9\x3f\xc4\xae" - -twentyOnes :: ByteString +twentyOnes :: B.ByteString twentyOnes = B.replicate 20 '\x01' --- | Test-only constructor that crashes on the smart-ctor's Left. Used for --- fixtures where we know the input satisfies the invariant; production code --- always goes through `mkNameOwner`. -unsafeOwner :: ByteString -> NameOwner +unsafeOwner :: B.ByteString -> NameOwner unsafeOwner = either error id . mkNameOwner -addr1, addr2 :: NameOwner +addr1 :: NameOwner addr1 = unsafeOwner twentyOnes -addr2 = unsafeOwner (B.replicate 20 '\x02') - --- Match the static `tldContract` mapping in SimplexName.Contracts so RSLV --- verifyRslv accepts these as the expected contract per TLD. -simplexContract, testingContract :: NameOwner -simplexContract = unsafeOwner (B.replicate 20 '\x11') -testingContract = unsafeOwner (B.replicate 20 '\x22') - -testNamesConfig :: NamesConfig -testNamesConfig = - NamesConfig - { ethereumEndpoint = "http://stub", - rpcAuth = Nothing, - rpcTimeoutMs = 1000, - rpcMaxResponseBytes = 65536, - rpcMaxConcurrency = 4 - } +-- | Sample record matching the Python resolver JSON shape (PR #1795). +-- Text fields use the empty string as the "unset" sentinel; coin fields +-- use Nothing -> JSON null. sampleRecord :: NameRecord sampleRecord = NameRecord { nrName = "alice.simplex", - nrNickname = Just "Alice", - nrWebsite = Just "https://alice.example", - nrLocation = Just "Earth", - nrSimplexContact = Just "simplex:/contact/abc#xyz", - nrSimplexChannel = Nothing, + nrNickname = "Alice", + nrWebsite = "https://alice.example", + nrLocation = "Earth", + nrSimplexContact = "simplex:/contact/abc#xyz", + nrSimplexChannel = "", nrEth = Just "0x0000000000000000000000000000000000000001", nrBtc = Nothing, nrXmr = Nothing, @@ -116,16 +55,26 @@ sampleRecord = nrResolver = unsafeOwner (B.replicate 20 '\x02') } +-- | JSON value canned by the resolver-stub for the "success" tests. +sampleRecordJSON :: J.Value +sampleRecordJSON = J.toJSON sampleRecord + +testNamesConfig :: NamesConfig +testNamesConfig = + NamesConfig + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 + } + smpNamesTests :: Spec smpNamesTests = do describe "NameRecord encoding (Protocol)" nameRecordEncodingSpec describe "Smart constructors (NameOwner)" smartCtorsSpec - describe "Keccak-256 and namehash" namehashSpec - describe "ABI primitive bounds" abiBoundsSpec - describe "decodeGetRecord (zero-owner sentinel)" zeroOwnerSpec - describe "decodeGetRecord (record + expiry)" decodeGetRecordSpec - describe "TLD whitelist + RSLV verification" tldWhitelistSpec - describe "Resolver" resolverSpec + describe "RSLV request parsing" parseNameSpec + describe "HTTP resolver" resolverSpec + describe "Resolver health probe" healthSpec nameRecordEncodingSpec :: Spec nameRecordEncodingSpec = do @@ -133,11 +82,6 @@ nameRecordEncodingSpec = do J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord)) `shouldBe` Right sampleRecord it "emits keys in spec-documented order (Python resolver shape)" $ do - -- The wire encoding (J.encode -> toEncoding) MUST keep keys in spec - -- declaration order so resolvers in different runtimes emit - -- byte-identical JSON. Routing the same record through - -- J.encode . J.toJSON re-emits keys alphabetically (Aeson canonicalises - -- via KeyMap); that path is NOT the wire format. let bytes = LB.toStrict (J.encode sampleRecord) offset k = B.length (fst (B.breakSubstring k bytes)) offsets = @@ -147,45 +91,35 @@ nameRecordEncodingSpec = do "nickname", "website", "location", - "simplex.contact", - "simplex.channel", - "ETH", - "BTC", - "XMR", - "DOT", + "simplexContact", + "simplexChannel", + "eth", + "btc", + "xmr", + "dot", "owner", "resolver" ] offsets `shouldBe` sort offsets - it "toJSON and toEncoding agree on the field set (no divergence between paths)" $ do - -- The previous hand-rolled instance had a subtle divergence: toJSON - -- and toEncoding were two independent code paths and could drift on - -- which optional fields they emit. TH-deriving both from a single - -- Options value forecloses that. Order still differs (toJSON goes - -- through KeyMap, alphabetical), but the set of emitted keys MUST - -- match. - let objectKeys v = case v of - J.Object o -> sort (KM.keys o) - _ -> error "expected JSON object" - viaToJSON = objectKeys (J.toJSON sampleRecord) - viaEncode = either error objectKeys (J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord))) - viaToJSON `shouldBe` viaEncode - - it "tolerates absent optional keys (forward-compat with sparse Python output)" $ do - let minimal = - "{\"name\":\"a.simplex\"," - <> "\"owner\":\"0x0101010101010101010101010101010101010101\"," - <> "\"resolver\":\"0x0202020202020202020202020202020202020202\"}" - (J.eitherDecodeStrict minimal :: Either String NameRecord) `shouldSatisfy` isRight + it "emits unset coin fields as null (not absent)" $ do + let bytes = LB.toStrict (J.encode sampleRecord) + B.isInfixOf "\"btc\":null" bytes `shouldBe` True + B.isInfixOf "\"xmr\":null" bytes `shouldBe` True + B.isInfixOf "\"dot\":null" bytes `shouldBe` True + + it "emits unset text fields as empty strings (not null)" $ do + let bytes = LB.toStrict (J.encode sampleRecord) + B.isInfixOf "\"simplexChannel\":\"\"" bytes `shouldBe` True + B.isInfixOf "\"simplexChannel\":null" bytes `shouldBe` False it "rejects nrName > 255 bytes UTF-8" $ do let oversize = sampleRecord {nrName = T.replicate 256 "x"} bytes = LB.toStrict (J.encode oversize) (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft - it "rejects simplex.contact > 1024 bytes UTF-8" $ do - let oversize = sampleRecord {nrSimplexContact = Just (T.replicate 1025 "x")} + it "rejects simplexContact > 1024 bytes UTF-8" $ do + let oversize = sampleRecord {nrSimplexContact = T.replicate 1025 "x"} bytes = LB.toStrict (J.encode oversize) (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft @@ -194,15 +128,22 @@ nameRecordEncodingSpec = do (J.eitherDecodeStrict (json "0x") :: Either String NameOwner) `shouldSatisfy` isRight (J.eitherDecodeStrict (json "0X") :: Either String NameOwner) `shouldSatisfy` isRight + it "owner / resolver are emitted as lowercase hex" $ do + -- The Python resolver returns lowercase hex; encoded form must match. + let mixedCase = unsafeOwner (B.pack ['\xde', '\xad', '\xbe', '\xef'] <> B.replicate 16 '\x00') + bytes = LB.toStrict (J.encode sampleRecord {nrOwner = mixedCase, nrResolver = mixedCase}) + B.isInfixOf "0xdeadbeef" bytes `shouldBe` True + B.isInfixOf "0xDEADBEEF" bytes `shouldBe` False + it "encodes within the proxied transmission budget" $ do let wide = sampleRecord { nrName = T.replicate 255 "n", - nrNickname = Just (T.replicate 255 "k"), - nrWebsite = Just (T.replicate 255 "w"), - nrLocation = Just (T.replicate 255 "l"), - nrSimplexContact = Just (T.replicate 1024 "x"), - nrSimplexChannel = Just (T.replicate 1024 "y"), + nrNickname = T.replicate 255 "k", + nrWebsite = T.replicate 255 "w", + nrLocation = T.replicate 255 "l", + nrSimplexContact = T.replicate 1024 "x", + nrSimplexChannel = T.replicate 1024 "y", nrEth = Just (T.replicate 255 "e"), nrBtc = Just (T.replicate 255 "b"), nrXmr = Just (T.replicate 255 "m"), @@ -222,280 +163,122 @@ smartCtorsSpec = do Right o -> unNameOwner o `shouldBe` twentyOnes Left e -> expectationFailure ("mkNameOwner failed: " <> e) -namehashSpec :: Spec -namehashSpec = do - it "keccak256 of empty string matches reference vector" $ - keccak256 "" `shouldBe` keccak256Empty - - it "keccak256 of \"abc\" matches reference vector" $ - keccak256 "abc" `shouldBe` keccak256Abc - - it "Keccak-256 is NOT SHA3-256 (different output for same input)" $ do - let sha3 = BA.convert (Crypton.hash @ByteString @Crypton.SHA3_256 "abc") :: ByteString - sha3 `shouldBe` sha3_256Abc - keccak256 "abc" `shouldNotBe` sha3 - - it "namehash of empty name is 32 zero bytes" $ - namehash "" `shouldBe` B.replicate 32 '\NUL' - - it "namehash of \"eth\" matches ENS reference vector" $ - namehash "eth" `shouldBe` namehashEth - - it "snrcSelector is 4 bytes" $ - B.length snrcSelector `shouldBe` 4 - - it "encodeGetRecord = selector ++ 32-byte node" $ do - let node = namehash "alice.eth" - bytes = encodeGetRecord node - B.length bytes `shouldBe` 36 - B.take 4 bytes `shouldBe` snrcSelector - B.drop 4 bytes `shouldBe` node - -abiBoundsSpec :: Spec -abiBoundsSpec = do - let mkBuf n = B.replicate n '\NUL' - - it "decodeWord256Int64 fails when offset + 32 > buf length" $ - decodeWord256Int64 0 (mkBuf 31) `shouldBe` Left AbiTruncated - - it "decodeWord256Int64 rejects non-zero high 24 bytes (Int64 overflow)" $ do - let buf = B.replicate 23 '\NUL' <> B.singleton '\x01' <> B.replicate 8 '\NUL' - decodeWord256Int64 0 buf `shouldBe` Left AbiNonZeroHighBytes - - it "decodeWord256Int64 rejects sign bit set in low 8 bytes (silent negative)" $ do - -- 0x8000000000000000 would decode to Int64.minBound without the check; - -- downstream length math would then see a negative len and silently - -- return empty bytes from B.take instead of failing. - let buf = B.replicate 24 '\NUL' <> "\x80\x00\x00\x00\x00\x00\x00\x00" - decodeWord256Int64 0 buf `shouldBe` Left AbiNonZeroHighBytes - - it "decodeWord256Int64 succeeds for the max representable positive value" $ do - let buf = B.replicate 24 '\NUL' <> "\x7F\xFF\xFF\xFF\xFF\xFF\xFF\xFF" - decodeWord256Int64 0 buf `shouldBe` Right maxBound - - it "decodeWord256Int64 succeeds for low 8 bytes set" $ do - let buf = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x12\x34" - decodeWord256Int64 0 buf `shouldBe` Right 0x1234 - - it "decodeAddress rejects non-zero high 12 bytes" $ do - let buf = B.replicate 11 '\NUL' <> B.singleton '\x01' <> B.replicate 20 '\NUL' - decodeAddress 0 buf `shouldSatisfy` isLeft - - it "decodeString fails on backward offset" $ - decodeString 100 50 1024 (mkBuf 200) `shouldBe` Left AbiBackwardOffset - - it "decodeString fails when declared length exceeds the per-field cap" $ do - let lenBytes = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x00\x64" -- length 100 - buf = lenBytes <> B.replicate 100 'x' - decodeString 0 0 10 buf `shouldBe` Left AbiOversized - - it "decodeStringArray fails when depth ≥ 2" $ - decodeStringArray 2 0 0 8 1024 (mkBuf 64) `shouldBe` Left AbiDepthExceeded - - it "decodeStringArray fails when array count exceeds cap" $ do - let lenBytes = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x00\x09" -- 9 elements - buf = lenBytes <> B.replicate 1024 '\NUL' - decodeStringArray 0 0 0 8 1024 buf `shouldBe` Left AbiOversized - -zeroOwnerSpec :: Spec -zeroOwnerSpec = do - it "decodeGetRecord returns Nothing for zero-owner buffer" $ do - -- 12 slots * 32 bytes; owner at slot 10 is all-zero by construction - let buf = B.replicate (32 * 12) '\NUL' - decodeGetRecord addr1 0 buf `shouldBe` Right Nothing - - it "decodeGetRecord fails on truncated buffer (< 12 head slots)" $ do - let tiny = B.replicate (32 * 11) '\NUL' - decodeGetRecord addr1 0 tiny `shouldBe` Left AbiTruncated - -decodeGetRecordSpec :: Spec -decodeGetRecordSpec = do - it "decodes a full record with all optional fields populated" $ do - let buf = encodeRecordAbi sampleRecord 0 - case decodeGetRecord (nrResolver sampleRecord) 0 buf of - Right (Just r) -> r `shouldBe` sampleRecord - other -> expectationFailure $ "expected Just sampleRecord, got: " <> show other - - it "decodes a minimal record (empty optional strings -> Nothing)" $ do - -- Empty strings in the ABI should map to Nothing for optional fields. - let minimal = - sampleRecord - { nrNickname = Nothing, - nrWebsite = Nothing, - nrLocation = Nothing, - nrSimplexContact = Nothing, - nrSimplexChannel = Nothing, - nrEth = Nothing, - nrBtc = Nothing, - nrXmr = Nothing, - nrDot = Nothing - } - buf = encodeRecordAbi minimal 0 - decodeGetRecord (nrResolver minimal) 0 buf `shouldBe` Right (Just minimal) - - it "preserves resolver address passed in (not derived from buffer)" $ do - let buf = encodeRecordAbi sampleRecord 0 - case decodeGetRecord addr2 0 buf of - Right (Just r) -> nrResolver r `shouldBe` addr2 - other -> expectationFailure $ "expected Just .. with resolver=addr2, got: " <> show other - - it "returns Nothing for expired record (expiry < nowSec, both non-zero)" $ do - let buf = encodeRecordAbi sampleRecord 1000 - -- nowSec = 2000 > expiry = 1000 -> expired - decodeGetRecord testResolver 2000 buf `shouldBe` Right Nothing - - it "returns Just for non-expired record (expiry > nowSec)" $ do - let buf = encodeRecordAbi sampleRecord 5000 - case decodeGetRecord testResolver 2000 buf of - Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} - other -> expectationFailure $ "expected Just, got: " <> show other - - it "returns Just for expiry == 0 (never expires) even when nowSec is large" $ do - let buf = encodeRecordAbi sampleRecord 0 - case decodeGetRecord testResolver maxBound buf of - Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} - other -> expectationFailure $ "expected Just (expiry=0 is never-expires), got: " <> show other - - it "returns Just when nowSec == 0 (expiry check disabled) even if expiry is in the past" $ do - let buf = encodeRecordAbi sampleRecord 1 - case decodeGetRecord testResolver 0 buf of - Right (Just r) -> r `shouldBe` sampleRecord {nrResolver = testResolver} - other -> expectationFailure $ "expected Just (nowSec=0 disables check), got: " <> show other +parseNameSpec :: Spec +parseNameSpec = do + it "accepts a valid simplex-TLD name" $ do + let req = req' "privacy.simplex" + case parseName req of + Just d -> do + nameTLD d `shouldBe` TLDSimplex + domain d `shouldBe` "privacy" + Nothing -> expectationFailure "expected Just" + + it "normalises case across labels (Alice.SIMPLEX = alice.simplex)" $ do + let dL = parseName (req' "alice.simplex") + dM = parseName (req' "Alice.SIMPLEX") + dL `shouldBe` dM + + it "accepts a testing-TLD name" $ do + case parseName (req' "bob.testing") of + Just d -> nameTLD d `shouldBe` TLDTesting + Nothing -> expectationFailure "expected Just" + + it "accepts a TLDWeb name (server forwards to resolver, which will likely 404/400)" $ + parseName (req' "example.com") `shouldSatisfy` \case + Just _ -> True + Nothing -> False + + it "rejects a bare (no-TLD) name" $ + parseName (req' "privacy") `shouldBe` Nothing + + it "rejects non-ASCII labels (homograph attacks)" $ + parseName (req' "\1072lice.simplex") `shouldBe` Nothing + + it "rejects oversized inputs (>253 bytes)" $ + parseName (req' (T.replicate 254 "a" <> ".simplex")) `shouldBe` Nothing where - testResolver = nrResolver sampleRecord - --- | Build a valid ABI-encoded tuple of (string x10, address, uint256) for tests. --- HEAD: 12 slots of 32 bytes each. Slots 0-9 are tail offsets for the 10 --- string fields in declaration order (name, nickname, website, location, --- simplex.contact, simplex.channel, ETH, BTC, XMR, DOT); slot 10 is the --- owner address; slot 11 is the uint256 expiry. TAIL: each string is --- length-prefixed (32-byte big-endian length) and padded to a 32-byte --- boundary. Missing optional fields (Nothing) encode as empty strings. -encodeRecordAbi :: NameRecord -> Int64 -> ByteString -encodeRecordAbi r expiry = - let headSize = 12 * 32 - strs = - [ encodeUtf8 (nrName r), - encodeUtf8 (fromMaybe "" (nrNickname r)), - encodeUtf8 (fromMaybe "" (nrWebsite r)), - encodeUtf8 (fromMaybe "" (nrLocation r)), - encodeUtf8 (fromMaybe "" (nrSimplexContact r)), - encodeUtf8 (fromMaybe "" (nrSimplexChannel r)), - encodeUtf8 (fromMaybe "" (nrEth r)), - encodeUtf8 (fromMaybe "" (nrBtc r)), - encodeUtf8 (fromMaybe "" (nrXmr r)), - encodeUtf8 (fromMaybe "" (nrDot r)) - ] - -- offsets of each string-tail body from start of buffer - offsets = scanl (\o s -> o + encodedStringSize s) headSize strs - stringOffsets = take 10 offsets - headBytes = - B.concat (map (encodeWord256 . fromIntegral) stringOffsets) - <> encodeAddressSlot (nrOwner r) - <> encodeWord256 (fromIntegral expiry) - tailBytes = B.concat (map encodeStringTail strs) - in headBytes <> tailBytes - --- | Length-prefix + 32-byte padding for a single ABI string body. -encodeStringTail :: ByteString -> ByteString -encodeStringTail s = - let len = B.length s - pad = (32 - (len `mod` 32)) `mod` 32 - in encodeWord256 (fromIntegral len) <> s <> B.replicate pad '\NUL' - -encodedStringSize :: ByteString -> Int -encodedStringSize s = - let len = B.length s - pad = (32 - (len `mod` 32)) `mod` 32 - in 32 + len + pad - --- | 20-byte address padded to 32 bytes (12 zero bytes then 20 address bytes). -encodeAddressSlot :: NameOwner -> ByteString -encodeAddressSlot owner = B.replicate 12 '\NUL' <> unNameOwner owner - --- | uint256 big-endian over a non-negative Int64; high 24 bytes are zero --- (the production decoder rejects buffers with any non-zero high bytes, --- which is exactly what we want for non-overflowing test values). -encodeWord256 :: Int64 -> ByteString -encodeWord256 n - | n < 0 = error "encodeWord256: negative value" - | otherwise = B.replicate 24 '\NUL' <> B.pack (map byteAt [56, 48, 40, 32, 24, 16, 8, 0]) - where - byteAt :: Int -> Char - byteAt shift = - let b = fromIntegral (n `shiftR` shift) .&. 0xFF :: Word8 - in toEnum (fromIntegral b) - -tldWhitelistSpec :: Spec -tldWhitelistSpec = do - describe "tldContract" $ do - it "maps TLDSimplex and TLDTesting to distinct contracts; TLDWeb is unmapped" $ do - tldContract TLDSimplex `shouldBe` Just simplexContract - tldContract TLDTesting `shouldBe` Just testingContract - tldContract TLDWeb `shouldBe` Nothing - - describe "verifyRslv" $ do - let mkEnv = newNamesEnvWith testNamesConfig (\_ _ -> pure (Right "")) Nothing - - it "accepts a valid name with matching TLD-specific contract" $ do - env <- mkEnv - let req = RslvRequest {name = "privacy.simplex", contract = simplexContract} - case verifyRslv env req of - Just (a, d) -> do - a `shouldBe` simplexContract - nameTLD d `shouldBe` TLDSimplex - domain d `shouldBe` "privacy" - Nothing -> expectationFailure "expected Just" - - it "normalizes case across all labels (Alice.SIMPLEX ≡ alice.simplex for namehash)" $ do - env <- mkEnv - let lower = RslvRequest {name = "alice.simplex", contract = simplexContract} - mixed = RslvRequest {name = "Alice.SIMPLEX", contract = simplexContract} - case (verifyRslv env lower, verifyRslv env mixed) of - (Just (_, dL), Just (_, dM)) -> dL `shouldBe` dM - _ -> expectationFailure "both should parse" - - it "rejects mismatched contract address" $ do - env <- mkEnv - let req = RslvRequest {name = "privacy.simplex", contract = addr2} - verifyRslv env req `shouldBe` Nothing - - it "rejects TLD with no whitelist entry (TLDWeb is unmapped)" $ do - env <- mkEnv - let req = RslvRequest {name = "example.web", contract = simplexContract} - verifyRslv env req `shouldBe` Nothing - - it "rejects bare (no-TLD) name (SimplexNameDomain.strP requires TLD)" $ do - env <- mkEnv - let req = RslvRequest {name = "privacy", contract = simplexContract} - verifyRslv env req `shouldBe` Nothing - - it "rejects non-ASCII labels (Cyrillic а homograph would hash to different namehash than ASCII a)" $ do - env <- mkEnv - -- Cyrillic а (U+0430), Greek α (U+03B1), full-width A (U+FF21) - for_ ["\1072lice.simplex", "\945pple.simplex", "\65313pple.simplex"] $ \name -> - verifyRslv env RslvRequest {name, contract = simplexContract} `shouldBe` Nothing - - it "rejects oversized inputs (>253 bytes) — bounded parser allocation" $ do - env <- mkEnv - let oversize = T.replicate 254 "a" <> ".simplex" - verifyRslv env RslvRequest {name = oversize, contract = simplexContract} `shouldBe` Nothing + req' n = RslvRequest {name = n, contract = addr1} resolverSpec :: Spec resolverSpec = do - let mkEnv ethCall = newNamesEnvWith testNamesConfig ethCall Nothing + let mkEnv stub = newNamesEnvWith testNamesConfig stub Nothing aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} - zeroOwnerResponse = Right (B.replicate (32 * 12) '\NUL') - it "maps stub zero-owner response to NotFound" $ do - env <- mkEnv (\_ _ -> pure zeroOwnerResponse) - resolveName env addr1 aliceDomain `shouldReturn` Left NotFound + it "returns NameRecord on 200 OK" $ do + env <- mkEnv (\_ -> pure (Right sampleRecordJSON)) + r <- resolveName env aliceDomain + r `shouldBe` Right sampleRecord + + it "returns NotFound on 404" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 404))) + resolveName env aliceDomain `shouldReturn` Left NotFound + + it "returns NotFound on 400 (unknown TLD)" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 400))) + resolveName env aliceDomain `shouldReturn` Left NotFound + + it "returns ResolverError on 502 (upstream RPC failure)" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 502))) + resolveName env aliceDomain `shouldReturn` Left ResolverError + + it "returns ResolverError on 5xx other than 502" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 500))) + resolveName env aliceDomain `shouldReturn` Left ResolverError - it "every lookup hits the endpoint (no cache)" $ do + it "returns ResolverError on transport-layer body-too-large" $ do + env <- mkEnv (\_ -> pure (Left BodyTooLarge)) + resolveName env aliceDomain `shouldReturn` Left ResolverError + + it "returns ResolverDecodeErr on malformed JSON from the resolver" $ do + env <- mkEnv (\_ -> pure (Left (InvalidJson "expected object"))) + resolveName env aliceDomain `shouldReturn` Left ResolverDecodeErr + + it "returns ResolverDecodeErr when JSON parses but isn't a NameRecord shape" $ do + env <- mkEnv (\_ -> pure (Right (J.object []))) + resolveName env aliceDomain `shouldReturn` Left ResolverDecodeErr + + it "sends one HTTP request per lookup (no cache)" $ do callCount <- newIORef (0 :: Int) - env <- mkEnv $ \_ _ -> do + env <- mkEnv $ \_ -> do atomicModifyIORef' callCount (\v -> (v + 1, ())) - pure zeroOwnerResponse - _ <- resolveName env addr1 aliceDomain - _ <- resolveName env addr1 aliceDomain + pure (Right sampleRecordJSON) + _ <- resolveName env aliceDomain + _ <- resolveName env aliceDomain readIORef callCount `shouldReturn` 2 + + it "addresses the resolver with the full canonical domain name" $ do + seenName <- newIORef ("" :: T.Text) + env <- + mkEnv $ \case + ResolverFetch n -> do + atomicModifyIORef' seenName (\_ -> (n, ())) + pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) + _ <- resolveName env aliceDomain + readIORef seenName `shouldReturn` "alice.simplex" + +healthSpec :: Spec +healthSpec = do + let mkEnv stub = newNamesEnvWith testNamesConfig stub Nothing + + it "pingEndpoint succeeds on a 200 OK /health response" $ do + env <- mkEnv (\_ -> pure (Right (J.object []))) + r <- pingEndpoint env + case r of + Right () -> pure () + Left e -> expectationFailure $ "expected Right (), got Left " <> show e + + it "pingEndpoint fails on a 500 /health response" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 500))) + r <- pingEndpoint env + case r of + Left (HttpStatusErr 500) -> pure () + _ -> expectationFailure $ "expected Left (HttpStatusErr 500), got " <> show r + + it "pingEndpoint routes to ResolverHealth (not ResolverFetch)" $ do + seenKind <- newIORef Nothing + env <- mkEnv $ \k -> do + atomicModifyIORef' seenKind (\_ -> (Just k, ())) + pure (Right (J.object [])) + _ <- pingEndpoint env + readIORef seenKind `shouldReturn` Just ResolverHealth