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/simplexmq.cabal b/simplexmq.cabal index 08c8b9625..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 @@ -142,6 +144,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 @@ -496,10 +499,12 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests + AgentTests.ResolveNameTests AgentTests.ServerChoice AgentTests.ShortLinkTests CLITests CoreTests.BatchingTests + CoreTests.ConnectTargetTests CoreTests.CryptoFileTests CoreTests.CryptoTests CoreTests.EncodingTests @@ -512,6 +517,7 @@ test-suite simplexmq-test CoreTests.VersionRangeTests FileDescriptionTests RemoteControl + RSLVTests ServerTests SMPAgentClient SMPClient diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bd77b892a..73be8269e 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,7 @@ import Simplex.Messaging.Protocol ErrorType (AUTH), MsgBody, MsgFlags (..), + NameRecord, NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), @@ -237,6 +239,7 @@ 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 (..)) @@ -440,6 +443,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 +1192,11 @@ getConnShortLink' c nm userId = \case 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) + 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..232705c54 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 +-- | 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 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 = withSMPClient c NRMBackground rq "NKEY " $ \smp -> 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/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 67b31de18..9fb525553 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -73,6 +73,8 @@ module Simplex.Messaging.Client deleteSMPQueues, connectSMPProxiedRelay, proxySMPMessage, + proxyResolveName, + directResolveName, forwardSMPTransmission, getSMPQueueInfo, sendProtocolCommand, @@ -1046,6 +1048,26 @@ 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. 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 + Right (NAME nr) -> pure $ Right nr + 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/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 ebe3506ba..83204ccf1 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, @@ -246,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 (..)) @@ -256,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 @@ -273,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 @@ -488,7 +486,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 @@ -736,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) @@ -774,85 +744,6 @@ 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. -data NameRecord = NameRecord - { nrDisplayName :: Text, - nrOwner :: NameOwner, - nrChannelLinks :: [NameLink], - nrContactLinks :: [NameLink], - nrAdminAddress :: Maybe Text, - nrAdminEmail :: Maybe Text, - nrExpiry :: Int64, -- Unix seconds, ≥ 0 - nrIsTest :: Bool - } - deriving (Eq, Show) - -instance J.ToJSON NameRecord where - toJSON NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} = - J.object - [ "displayName" J..= nrDisplayName, - "owner" J..= nrOwner, - "channelLinks" J..= nrChannelLinks, - "contactLinks" J..= nrContactLinks, - "adminAddress" J..= nrAdminAddress, - "adminEmail" J..= nrAdminEmail, - "expiry" J..= nrExpiry, - "isTest" J..= nrIsTest - ] - -- 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} = - J.pairs $ - "displayName" J..= nrDisplayName - <> "owner" J..= nrOwner - <> "channelLinks" J..= nrChannelLinks - <> "contactLinks" J..= nrContactLinks - <> "adminAddress" J..= nrAdminAddress - <> "adminEmail" J..= nrAdminEmail - <> "expiry" J..= nrExpiry - <> "isTest" J..= nrIsTest - -instance J.FromJSON NameRecord where - parseJSON = J.withObject "NameRecord" $ \o -> do - nrDisplayName <- o J..: "displayName" >>= capUtf8 "displayName" 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} - 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/Server.hs b/src/Simplex/Messaging/Server.hs index 4c3447176..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 () @@ -1157,8 +1165,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 +1246,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 @@ -1270,9 +1278,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 @@ -2149,7 +2157,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 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/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 c1aeef489..0f81f9c02 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,48 +20,31 @@ module Simplex.Messaging.Server.Names newNamesEnv, newNamesEnvWith, closeNamesEnv, - lookupTldAddress, pingEndpoint, resolveName, verifyRslv, ) where -import Control.Applicative ((<|>)) -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) +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.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) --- | 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, @@ -85,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 @@ -98,45 +77,35 @@ 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 --- | 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 +116,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 @@ -166,42 +132,14 @@ resolveName env contract d = do pure (Left EthHttpErr) fetch :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) -fetch env@NamesEnv {ethCall} contract d = +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 ret of - Right Nothing -> notFoundWithPlaceholderWarn ret - Right (Just rec) -> checkExpiry rec + 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. - 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 - 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 2e645fa60..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,19 +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). +-- 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. -- --- 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 - | 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. - | otherwise = Nothing <$ decodeAddress 32 buf +-- `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/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index 62973727a..f02ced0bd 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -27,7 +27,8 @@ 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 (ToField (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) @@ -87,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 @@ -123,6 +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 + $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) diff --git a/src/Simplex/Messaging/SimplexName/Contracts.hs b/src/Simplex/Messaging/SimplexName/Contracts.hs new file mode 100644 index 000000000..0b6275d63 --- /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.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.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..5d092063b --- /dev/null +++ b/tests/AgentTests/ResolveNameTests.hs @@ -0,0 +1,258 @@ +{-# 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 ..`). +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 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 (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 (..)) +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 +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 + } + +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) + +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 (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 (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" testDirectSuccess + +-- --------------------------------------------------------------------------- +-- 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" [] + +-- | 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 + 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: `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 + 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]} + +-- | 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/CoreTests/ConnectTargetTests.hs b/tests/CoreTests/ConnectTargetTests.hs new file mode 100644 index 000000000..a068c6abf --- /dev/null +++ b/tests/CoreTests/ConnectTargetTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +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) +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 "#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" $ + "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)) + decodesSuccessfully s + s `encodesAs` s + it "parses simplex:/invitation#… as CTLink" $ do + let s = strEncode (ACL SCMInvitation (CLFull invConnRequest)) + decodesSuccessfully s + + 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 "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 = + strDecode @ConnectTarget s `shouldSatisfy` either (const False) (const True) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs new file mode 100644 index 000000000..0578a9cbd --- /dev/null +++ b/tests/RSLVTests.hs @@ -0,0 +1,302 @@ +{-# 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`. 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 +-- * `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 + +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 SMPNamesTests (encodeRecordAbi) +import Simplex.Messaging.Protocol + ( BrokerMsg (..), + Cmd (..), + Command (..), + CorrId (..), + ErrorType (..), + NameOwner, + NameRecord (..), + 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, + 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') + +-- 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' + +stubNamesConfig :: NamesConfig +stubNamesConfig = + NamesConfig + { ethereumEndpoint = "http://stub", + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + +-- | 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) + +-- | 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') + } + +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 +-- by `verifyRslv`). +mkSimplexOnlyNamesEnv :: (B.ByteString -> B.ByteString -> IO (Either EthRpcError B.ByteString)) -> IO NamesEnv +mkSimplexOnlyNamesEnv eth = newNamesEnvWith stubNamesConfig eth 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 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" testRslvSuccess + +-- --- 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} + -- 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) + +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 + -- 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 () +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 + +-- --- 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/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/SMPNamesTests.hs b/tests/SMPNamesTests.hs index 412b6fa2b..30c177881 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -3,39 +3,40 @@ {-# 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.Text (Text) +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 - ( NameLink, - NameOwner, + ( NameOwner, NameRecord (..), RslvRequest (..), - mkNameLink, mkNameOwner, - unNameLink, unNameOwner, ) 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, @@ -72,25 +73,26 @@ 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, 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, @@ -100,23 +102,28 @@ 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 + describe "decodeGetRecord (record + expiry)" decodeGetRecordSpec describe "TLD whitelist + RSLV verification" tldWhitelistSpec describe "Resolver" resolverSpec @@ -125,26 +132,60 @@ 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 - -- Default toEncoding routes through Value/KeyMap and re-emits keys - -- alphabetically; spec requires byte-identical canonical encoding. + 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 = 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 "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 "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 "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 +195,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 +217,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 @@ -263,95 +300,192 @@ 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 buf `shouldBe` Right Nothing - - it "decodeGetRecord fails on truncated buffer" $ do - let tiny = B.replicate 31 '\NUL' - decodeGetRecord 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 - 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 Ａ (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') + zeroOwnerResponse = Right (B.replicate (32 * 12) '\NUL') it "maps stub zero-owner response to NotFound" $ do env <- mkEnv (\_ _ -> pure zeroOwnerResponse) diff --git a/tests/Test.hs b/tests/Test.hs index 84718a9fc..22cc8c03c 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 @@ -21,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) @@ -83,6 +85,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 @@ -99,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) $