From 9cfdb554676c49ef5919c5184c983fb4e987c857 Mon Sep 17 00:00:00 2001 From: sh Date: Tue, 2 Jun 2026 09:26:22 +0000 Subject: [PATCH] smp-server: round 6 audit fixes (IPv6 SSRF, redirects, ASCII labels) - Reject IPv6 aliases of 169.254.169.254 (IPv4-compatible / IPv4-mapped / 6to4 / NAT64) via numeric range check on parsed IPv6. - Disable HTTP redirects on the Eth RPC request. - Restrict SimplexName labels to ASCII (Cyrillic/Greek/full-width otherwise hash to different on-chain records and diverge from UTS-46 registrars). - pingEndpoint: only JsonRpcErr means "reachable"; transport/decode failures fail startup. boundedIniInt: readMaybe over partial read. - Add 127.0.0.0/8 and 0.0.0.0 to isLoopback. - Replace hand-rolled hex helpers with Data.ByteArray.Encoding; raise managerConnCount to match rpcMaxConcurrency; hex Show for NameOwner. - Fuse parallel http/https when into unless+case; drop reverse/re-reverse in mkDomain TLDWeb; first AbiInvariantViolated; Nothing <$ decodeAddress; forM_ (eitherToMaybe ...); >>= chain in NameOwner FromJSON. - Drop dead imports/exports/pragmas and two restating comments. - Tests: factor unsafeOwner/unsafeLink, addr1/2/3, testNamesConfig; add non-ASCII label rejection coverage. --- src/Simplex/Messaging/Agent/Protocol.hs | 3 +- src/Simplex/Messaging/Encoding.hs | 1 - src/Simplex/Messaging/Protocol.hs | 26 ++-- src/Simplex/Messaging/Server.hs | 4 - src/Simplex/Messaging/Server/Env/STM.hs | 3 +- src/Simplex/Messaging/Server/Main.hs | 118 ++++++++++++++---- src/Simplex/Messaging/Server/Names.hs | 22 ++-- src/Simplex/Messaging/Server/Names/Eth/RPC.hs | 67 ++++------ .../Messaging/Server/Names/Eth/SNRC.hs | 14 +-- src/Simplex/Messaging/SimplexName.hs | 20 +-- tests/SMPNamesTests.hs | 110 ++++++++-------- 11 files changed, 221 insertions(+), 167 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index f518c7b0d..0860adf2a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -195,11 +195,10 @@ 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 qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (isAlpha, isDigit, toLower, toUpper) +import Data.Char (toLower, toUpper) import Data.Foldable (find) import Data.Functor (($>)) import Data.Int (Int64) diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index b5b51ab90..d069e5518 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -15,7 +15,6 @@ module Simplex.Messaging.Encoding smpEncodeList, smpListP, lenEncode, - lenP, ) where diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index d7ec0666e..ebe3506ba 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -260,7 +260,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.String import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Data.Type.Equality import Data.Word (Word8, Word16) @@ -566,12 +566,13 @@ type LinkId = QueueId -- | SMP queue ID on the server. type QueueId = EntityId --- | Name resolution request. The client sends the canonical SimplexNameDomain --- (TLD always explicit) plus the SNRC contract address it expects the server --- to query. The server parses the domain (validating syntax) and checks the --- supplied contract against its INI whitelist before reading the chain — so a --- single names router can safely host multiple TLDs (each backed by its own --- SNRC contract) and reject clients that ask for the wrong one. +-- | Name resolution request. The client sends the name in canonical +-- SimplexNameDomain form (TLD always explicit) as a Text plus the SNRC +-- contract address it expects the server to query. The server parses the +-- name into SimplexNameDomain (validating syntax) and checks the supplied +-- contract against its hardcoded TLD whitelist before reading the chain — +-- so a single names router can safely host multiple TLDs (each backed by +-- its own SNRC contract) and reject clients that ask for the wrong one. data RslvRequest = RslvRequest { name :: Text, contract :: NameOwner @@ -738,7 +739,12 @@ newtype EncFwdTransmission = EncFwdTransmission ByteString -- | 20-byte Ethereum address (NameRecord owner). Bare constructor not exported; -- use `mkNameOwner` to enforce the 20-byte invariant. newtype NameOwner = NameOwner ByteString - deriving (Eq, Show) + 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 @@ -756,9 +762,7 @@ 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) - case BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) of - Left e -> fail e - Right bs -> either fail pure (mkNameOwner bs) + 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] diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5fae9b8a8..4c3447176 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -249,8 +249,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt closeServer = do pa <- asks (smpAgent . proxyAgent) ne <- asks namesEnv - -- finally: if the proxy-agent close throws, we still release the resolver's - -- HTTP connection manager. liftIO $ closeSMPClientAgent pa `E.finally` mapM_ closeNamesEnv ne serverThread :: @@ -664,8 +662,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt map tshow [_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther] showServiceStats ServiceStatsData {_srvAssocNew, _srvAssocDuplicate, _srvAssocUpdated, _srvAssocRemoved, _srvSubCount, _srvSubDuplicate, _srvSubQueues, _srvSubEnd} = map tshow [_srvAssocNew, _srvAssocDuplicate, _srvAssocUpdated, _srvAssocRemoved, _srvSubCount, _srvSubDuplicate, _srvSubQueues, _srvSubEnd] - -- Column order matches `Stats.hs:strEncode NameResolverStatsData`: - -- new counters appended at the end so existing CSV readers don't shift. showNameResolverStats NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvEthErrs, _rslvDisabled, _rslvBadName} = map tshow [_rslvReqs, _rslvSucc, _rslvNotFound, _rslvEthErrs, _rslvDisabled, _rslvBadName] diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index a23963b1c..a9e9d91ea 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -117,7 +117,6 @@ import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint) import Simplex.Messaging.Server.Names.Eth.RPC (scrubUrl) -import Simplex.Messaging.Util (tshow) import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Config @@ -131,7 +130,7 @@ import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP) import Simplex.Messaging.Transport.Server -import Simplex.Messaging.Util (ifM, whenM, ($>>=)) +import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=)) import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.IO (IOMode (..)) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 6435c6483..47345ef01 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -66,7 +66,11 @@ import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClie import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) +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.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM @@ -76,8 +80,6 @@ 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 Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) -import Simplex.Messaging.Protocol (mkNameOwner) import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..), TldRegistries (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) @@ -827,10 +829,15 @@ readNamesConfig ini -- against operator-misconfig footguns: 16 MiB response cap (worst-case -- per-call memory), 60 s timeout (no operator wants RSLV to hang longer), -- 1024 concurrent RPCs (any higher should run a separate names router). - boundedIniInt def floor_ ceiling_ key = case readIniDefault def "NAMES" key ini of - n | n >= floor_ && n <= ceiling_ -> n - | otherwise -> - error $ "[NAMES] " <> T.unpack key <> " must be in [" <> show floor_ <> ".." <> show ceiling_ <> "] (got " <> show n <> ")" + boundedIniInt def floor_ ceiling_ key = case lookupValue "NAMES" key ini of + Left _ -> def + Right raw -> case readMaybe (T.unpack (T.strip raw)) of + Nothing -> + error $ "[NAMES] " <> T.unpack key <> ": not an integer (got " <> show raw <> ")" + Just n + | n >= floor_ && n <= ceiling_ -> n + | 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 @@ -873,7 +880,10 @@ validateUrl url auth_ = do when (null host) $ Left "empty host" when (isBareIntegerHost host) $ Left "bare-integer host not allowed (use a hostname or dotted-quad / bracketed IP); rejects 169.254.169.254 decimal/hex aliases" - when (isLinkLocal host) $ Left "link-local host not allowed (rejects cloud metadata services)" + when (isObfuscatedIpv4 host) $ + Left "non-canonical IPv4 form not allowed (use dotted-quad decimal 0-255 with no leading zeros); rejects inet_aton hex/octal/compact aliases of 169.254.169.254" + when (isLinkLocal host || isForbiddenIpv6 host) $ + Left "link-local host not allowed (rejects cloud metadata services and IPv6 aliases of 169.254.0.0/16)" unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; use rpc_auth instead" case uriPort ua of "" -> Left "explicit port required (e.g. http://host:8545)" @@ -886,26 +896,36 @@ validateUrl url auth_ = do let path = uriPath uri unless (path == "" || path == "/") $ Left "URL path not allowed; API keys embedded in the path leak to logs — use rpc_auth instead" - when (scheme == "http:" && not (isLoopback host)) $ - Left "http endpoint on a non-loopback host not allowed (plaintext leaks rpc_auth); use https" - when (scheme == "https:" && not (isLoopback host) && isNothing auth_) $ - Left "https endpoint on a non-loopback host requires rpc_auth" + unless (isLoopback host) $ case scheme of + "http:" -> Left "http endpoint on a non-loopback host not allowed (plaintext leaks rpc_auth); use https" + "https:" | isNothing auth_ -> Left "https endpoint on a non-loopback host requires rpc_auth" + _ -> Right () Right url where - isLoopback h = h == "127.0.0.1" || h == "localhost" || h == "[::1]" - -- IPv4 link-local 169.254.0.0/16, the IPv6 link-local prefix fe80::/10, - -- and IPv4-mapped IPv6 forms of the cloud-metadata IP 169.254.169.254 - -- in every textual variant: dotted-quad, hex `a9fe:a9fe`, and the - -- zero-run-expanded `0:0:0:0:0:ffff:…` / `0000:0000:…` forms. - isLinkLocal h = - "169.254." `isPrefixOf` h - || "[fe80:" `isPrefixOf` lh - || any (`isInfixOf` lh) v6MappedMetadata + -- 127.0.0.0/8 and 0.0.0.0 both bind locally on Linux/BSD; treat them all + -- as loopback for the http/auth gate so a misconfigured 0.0.0.0:8545 (or + -- 127.0.0.5) doesn't get an Authorization header sent to a colocated + -- service or silently dropped onto the wire. + isLoopback = \case + "localhost" -> True + "[::1]" -> True + "0.0.0.0" -> True + h -> case parseDottedQuad h of + Just (127, _, _, _) -> True + _ -> False + parseDottedQuad s = case splitOnDot s of + [a, b, c, d] -> (,,,) <$> octet a <*> octet b <*> octet c <*> octet d + _ -> Nothing where - lh = map toLower h - -- Substrings rather than prefixes so we catch every zero-run-expansion - -- (`[::ffff:…`, `[0:0:0:0:0:ffff:…`, `[0000:0000:0000:0000:0000:ffff:…`). - v6MappedMetadata = [":ffff:169.254.", ":ffff:a9fe:a9fe"] :: [String] + octet o = case readMaybe o of + Just n | (n :: Int) >= 0 && n <= 255 -> Just n + _ -> Nothing + splitOnDot s = case break (== '.') s of + (chunk, []) -> [chunk] + (chunk, _ : rest) -> chunk : splitOnDot rest + -- IPv4 link-local 169.254.0.0/16 in dotted-quad form. IPv6 forms are + -- delegated to isForbiddenIpv6 which parses the address numerically. + isLinkLocal h = "169.254." `isPrefixOf` h -- Reject hostnames that look like decimal or `0x`/`0X`-hex integers — -- glibc's inet_aton accepts both as IPv4 aliases (`2852039166`, -- `0xa9fea9fe`, `0XA9FEA9FE` all resolve to 169.254.169.254). The literal @@ -914,6 +934,54 @@ validateUrl url auth_ = do isBareIntegerHost h = case map toLower h of '0' : 'x' : rest -> all isHexDigit rest lh -> not (null lh) && all isDigit lh + -- Reject dotted hosts whose every component is numeric (decimal or `0x`-hex) + -- but which aren't strict canonical IPv4 (exactly 4 decimal octets 0..255 with + -- no leading zeros). inet_aton accepts hex octets (`0xA9.0xFE.0xA9.0xFE`), + -- octal octets (`0251.0376.0251.0376`, leading zero), mixed forms + -- (`169.0376.169.254`), and compact 2/3-segment forms (`169.16689638`, + -- `169.254.43518`) as aliases for 169.254.169.254. The literal-prefix check + -- in isLinkLocal misses all of these; this predicate closes the gap. + isObfuscatedIpv4 h + | '.' `notElem` h = False + | otherwise = allNumericParts && not strictCanonical + where + parts = splitOnDot h + allNumericParts = not (null parts) && all isNumericPart parts + isNumericPart p = case map toLower p of + '0' : 'x' : rest@(_ : _) -> all isHexDigit rest + lp@(_ : _) -> all isDigit lp + _ -> False + strictCanonical = length parts == 4 && all isStrictDecOctet parts + isStrictDecOctet "0" = True + isStrictDecOctet p@(c : _) = + c /= '0' && all isDigit p && maybe False (\n -> (n :: Int) <= 255) (readMaybe p) + isStrictDecOctet _ = False + -- Strip the [...] brackets that parseAbsoluteURI keeps on IPv6 hosts, parse + -- as numeric IPv6, and check 128-bit ranges: + -- * fe80::/10 (link-local) + -- * ::1 (loopback) + -- * IPv4-compatible (::/96), IPv4-mapped (::ffff/96), 6to4 (2002::/16), + -- NAT64 WKP (64:ff9b::/96) — when they alias an IPv4 in 169.254.0.0/16 + -- This covers every textual form of those addresses (compressed, uncompressed, + -- mixed dotted-quad embed) because Data.IP normalises before we inspect bits. + isForbiddenIpv6 h = maybe False (isForbiddenIpv6Word . IP.fromIPv6w) $ + stripBrackets h >>= readMaybe + where + stripBrackets ('[' : rest@(_ : _)) | last rest == ']' = Just (init rest) + stripBrackets _ = Nothing + -- Loopback (::1) is intentionally NOT in this list: loopback is gated + -- separately by isLoopback for the http/auth decision. + isForbiddenIpv6Word :: (Word32, Word32, Word32, Word32) -> Bool + isForbiddenIpv6Word (w1, w2, w3, w4) = + linkLocal || compatTo169 || mappedTo169 || sixToFour169 || nat64To169 + where + linkLocal = (w1 `shiftR` 22) == 0x3fa -- fe80::/10 + is169254v4 = (w4 `shiftR` 16) == 0xa9fe + high96Zero = w1 == 0 && w2 == 0 + compatTo169 = high96Zero && w3 == 0 && is169254v4 + mappedTo169 = high96Zero && w3 == 0xffff && is169254v4 + sixToFour169 = (w1 `shiftR` 16) == 0x2002 && (w1 .&. 0xffff) == 0xa9fe + nat64To169 = w1 == 0x0064ff9b && w2 == 0 && w3 == 0 && is169254v4 -- | Parse an rpc_auth INI value. Scheme keyword is case-insensitive so -- "Bearer " / "BEARER " (Caddy / RFC 7235 convention) work diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs index df689d90a..c1aeef489 100644 --- a/src/Simplex/Messaging/Server/Names.hs +++ b/src/Simplex/Messaging/Server/Names.hs @@ -29,7 +29,7 @@ module Simplex.Messaging.Server.Names where import Control.Applicative ((<|>)) -import Control.Monad (guard, unless, when) +import Control.Monad (forM_, guard, unless, when) import qualified Control.Exception as E import Control.Logger.Simple (logError) import Data.ByteString.Char8 (ByteString) @@ -40,6 +40,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock.POSIX (getPOSIXTime) import Simplex.Messaging.Encoding.String (strDecode) +import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), RslvRequest (..), unNameOwner) import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) import Simplex.Messaging.Server.Names.Eth.SNRC (decodeAddress, decodeGetRecord, encodeGetRecord, isZeroOwner, namehash) @@ -127,9 +128,11 @@ verifyRslv NamesEnv {config} RslvRequest {name, contract} = case strDecode (enco -- | 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). Returns Left only on transport-level --- failures; JSON-RPC errors (misconfigured address etc.) are treated as --- "endpoint reachable" — that distinction surfaces later via rslvEthErrs. +-- 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. pingEndpoint :: NamesEnv -> IO (Either EthRpcError ()) pingEndpoint NamesEnv {ethCall, config} = case anyAddress (tldRegistries config) of Nothing -> pure (Right ()) @@ -141,9 +144,9 @@ pingEndpoint NamesEnv {ethCall, config} = case anyAddress (tldRegistries config) ethCall (unNameOwner addr) (encodeGetRecord (namehash "")) pure $ case r of Nothing -> Left ProbeTimedOut - Just (Left e@(HttpFailure _)) -> Left e - Just (Left e@(HttpStatusErr _)) -> Left e - Just _ -> Right () + 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 @@ -178,9 +181,8 @@ fetch env@NamesEnv {ethCall} contract d = -- an operator who enables [NAMES] against a working SNRC contract sees -- the resolver is functionally stubbed. notFoundWithPlaceholderWarn ret = do - case decodeAddress 32 ret of - Right owner -> unless (isZeroOwner owner) (warnPlaceholderOnce env) - Left _ -> pure () + 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 diff --git a/src/Simplex/Messaging/Server/Names/Eth/RPC.hs b/src/Simplex/Messaging/Server/Names/Eth/RPC.hs index 63b10d320..1f0d2d02a 100644 --- a/src/Simplex/Messaging/Server/Names/Eth/RPC.hs +++ b/src/Simplex/Messaging/Server/Names/Eth/RPC.hs @@ -1,7 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} @@ -15,12 +14,11 @@ -- * Authorization header attached only when configured. module Simplex.Messaging.Server.Names.Eth.RPC ( RpcAuth (..), - EthRpcEnv (..), + EthRpcEnv, EthRpcError (..), newEthRpcEnv, closeEthRpcEnv, ethCallReal, - fromHex, scrubUrl, ) where @@ -35,17 +33,20 @@ import qualified Data.ByteArray.Encoding as BAE import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Network.HTTP.Client ( HttpException, Manager, + ManagerSettings (..), Request, RequestBody (..), brReadSome, method, parseRequest, + redirectCount, requestBody, requestHeaders, responseBody, @@ -80,13 +81,18 @@ data EthRpcError | ProbeTimedOut -- startup-probe timeout; resolveName uses its own Timeout deriving (Show) --- | Build a Request from a (validated) ethereum_endpoint URL. +-- | Build a Request from a (validated) ethereum_endpoint URL. Redirects are +-- disabled: an RPC endpoint that responds 3xx is a misconfiguration, and a +-- compromised endpoint could otherwise redirect a credential-bearing POST +-- to a private-IP target (SSRF amplification on top of the host validation +-- performed at config load — DNS rebinding and chained redirects bypass it). buildRequest :: Text -> Maybe RpcAuth -> IO Request buildRequest endpoint auth_ = do req <- parseRequest (T.unpack endpoint) pure $ req { method = "POST", + redirectCount = 0, requestHeaders = ("Content-Type", "application/json") : maybe [] (pure . authHeader) auth_ @@ -101,7 +107,9 @@ authHeader = \case newEthRpcEnv :: Text -> Maybe RpcAuth -> Int -> Int -> IO EthRpcEnv newEthRpcEnv endpoint auth_ maxResponseBytes maxConcurrency = do - manager <- HC.newManager tlsManagerSettings + -- managerConnCount defaults to 10; without raising it the configured + -- rpcMaxConcurrency is silently capped to 10 by http-client's pool. + manager <- HC.newManager tlsManagerSettings {managerConnCount = max 10 maxConcurrency} request <- buildRequest endpoint auth_ sem <- newQSem maxConcurrency pure EthRpcEnv {manager, request, sem, maxResponseBytes} @@ -163,50 +171,19 @@ parseResult bs = case J.eitherDecodeStrict bs of pure (Left (JsonRpcErr code msg)) _ -> do result :: Text <- o J..: "result" - case fromHex (encodeUtf8 result) of + case decodeHexResult (encodeUtf8 result) of Right b -> pure (Right b) Left e -> pure (Left (InvalidJson e)) +-- | Encode raw bytes as "0x"-prefixed lowercase hex. toHex :: ByteString -> Text -toHex bs = T.pack $ "0x" <> concatMap byte (B.unpack bs) - where - byte c = - let n = fromEnum c - (h, l) = quotRem n 16 - in [hexChar h, hexChar l] - hexChar n - | n < 10 = toEnum (fromEnum '0' + n) - | otherwise = toEnum (fromEnum 'a' + n - 10) +toHex bs = "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) -fromHex :: ByteString -> Either String ByteString -fromHex bs0 = - let bs = case B.stripPrefix "0x" bs0 of - Just rest -> rest - Nothing -> case B.stripPrefix "0X" bs0 of - Just rest -> rest - Nothing -> bs0 - in if B.null bs - then Right B.empty - else - if odd (B.length bs) || not (B.all isHex bs) - then Left "invalid hex" - else Right (decodeHex bs) - where - isHex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') - -decodeHex :: ByteString -> ByteString -decodeHex = B.pack . go - where - go s - | B.null s = [] - | otherwise = - let hi = digit (B.head s) - lo = digit (B.index s 1) - in toEnum (16 * hi + lo) : go (B.drop 2 s) - digit c - | c >= '0' && c <= '9' = fromEnum c - fromEnum '0' - | c >= 'a' && c <= 'f' = 10 + fromEnum c - fromEnum 'a' - | otherwise = 10 + fromEnum c - fromEnum 'A' +-- | Decode a "0x"/"0X"-prefixed hex string (the JSON-RPC result shape). +decodeHexResult :: ByteString -> Either String ByteString +decodeHexResult bs = + BAE.convertFromBase BAE.Base16 $ + fromMaybe bs (B.stripPrefix "0x" bs <|> B.stripPrefix "0X" bs) -- | Strip userinfo from a URL so log lines never leak credentials. scrubUrl :: Text -> Text diff --git a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs index adf3d2d5e..2e645fa60 100644 --- a/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs +++ b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs @@ -40,6 +40,7 @@ module Simplex.Messaging.Server.Names.Eth.SNRC where import Crypto.Hash (Digest, Keccak_256, hash) +import Data.Bifunctor (first) import qualified Data.ByteArray as BA import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -113,9 +114,7 @@ decodeAddress :: Int -> ByteString -> Either AbiError NameOwner decodeAddress off buf | off + 32 > B.length buf = Left AbiTruncated | B.any (/= toEnum 0) (B.take 12 (B.drop off buf)) = Left (AbiInvariantViolated "address has non-zero high 12 bytes") - | otherwise = case mkNameOwner (B.take 20 (B.drop (off + 12) buf)) of - Right addr -> Right addr - Left e -> Left (AbiInvariantViolated e) + | otherwise = first AbiInvariantViolated $ mkNameOwner (B.take 20 (B.drop (off + 12) buf)) -- | Decode a Solidity `string` whose data starts at byte offset `off`. -- Returns raw bytes; UTF-8 validity is the caller's choice (use @@ -179,11 +178,10 @@ decodeStringArray depth headEnd off cntCap byteCap buf decodeGetRecord :: ByteString -> Either AbiError (Maybe NameRecord) decodeGetRecord buf | B.length buf < 32 * 8 = Left AbiTruncated - | otherwise = case decodeAddress 32 buf of - Left e -> Left e - Right owner - | isZeroOwner owner -> Right Nothing - | otherwise -> Right Nothing -- placeholder until SNRC ABI is finalised + -- 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 isZeroOwner :: NameOwner -> Bool isZeroOwner = (== B.replicate 20 '\NUL') . unNameOwner diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs index af5c4d793..be0fb0019 100644 --- a/src/Simplex/Messaging/SimplexName.hs +++ b/src/Simplex/Messaging/SimplexName.hs @@ -21,7 +21,7 @@ import Control.Applicative (optional, (<|>)) import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.Text as AT -import Data.Char (isAlpha, isDigit) +import Data.Char (isDigit) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T @@ -58,7 +58,12 @@ instance StrEncoding SimplexNameType where nameLabelP :: AT.Parser Text nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' where - isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') + -- ASCII letters only. SNRC contracts hash byte sequences via keccak; ENS + -- uses UTS-46 + Punycode for IDN, which we do not implement. Admitting + -- Cyrillic / Greek / etc. via Data.Char.isAlpha would (a) make namehash + -- diverge from any IDN-aware registrar and (b) allow homograph spoofing + -- (Cyrillic а vs ASCII a hash to different on-chain records). + isNameLetter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' instance StrEncoding SimplexNameInfo where strEncode SimplexNameInfo {nameType, nameDomain} = @@ -78,15 +83,14 @@ instance StrEncoding SimplexNameDomain where -- All labels lowercased: DNS labels are case-insensitive, and namehash is -- byte-defined — preserving original case would make `Alice.simplex` and -- `alice.simplex` resolve to different on-chain records. A mixed-case TLD - -- would also fall through to TLDWeb and route through `registry_tld_all` - -- instead of `registry_tld_simplex`. + -- would also fall through to TLDWeb and route through the `tldAll` + -- catch-all entry instead of the TLDSimplex registry. mkDomain labels = case reverse (map T.toLower labels) of [] -> Left "empty name" [_] -> Left "domain requires TLD" - tld : name : sub -> Right $ case tld of - "simplex" -> SimplexNameDomain TLDSimplex name sub - "testing" -> SimplexNameDomain TLDTesting name sub - _ -> SimplexNameDomain TLDWeb (T.intercalate "." (reverse (tld : name : sub))) [] + "simplex" : name : sub -> Right (SimplexNameDomain TLDSimplex name sub) + "testing" : name : sub -> Right (SimplexNameDomain TLDTesting name sub) + _ -> Right (SimplexNameDomain TLDWeb (T.intercalate "." (map T.toLower labels)) []) fullDomainName :: SimplexNameDomain -> Text fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs index f281e8763..8513cb5db 100644 --- a/tests/SMPNamesTests.hs +++ b/tests/SMPNamesTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,13 +10,16 @@ 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.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (sort) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LB import Simplex.Messaging.Protocol - ( NameOwner, + ( NameLink, + NameOwner, NameRecord (..), RslvRequest (..), mkNameLink, @@ -68,20 +72,43 @@ 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 +-- fixtures where we know the input satisfies the invariant; production code +-- always goes through `mkNameOwner` / `mkNameLink`. +unsafeOwner :: ByteString -> NameOwner +unsafeOwner = either error id . mkNameOwner + +unsafeLink :: Text -> NameLink +unsafeLink = either error id . mkNameLink + +addr1, addr2, addr3 :: NameOwner +addr1 = unsafeOwner twentyOnes +addr2 = unsafeOwner (B.replicate 20 '\x02') +addr3 = unsafeOwner (B.replicate 20 '\x03') + +testNamesConfig :: TldRegistries -> NamesConfig +testNamesConfig regs = + NamesConfig + { ethereumEndpoint = "http://stub", + tldRegistries = regs, + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + sampleRecord :: NameRecord -sampleRecord = case (mkNameOwner twentyOnes, mkNameLink "simplex:/contact/abc#xyz") of - (Right o, Right l) -> - NameRecord - { nrDisplayName = "Alice", - nrOwner = o, - nrChannelLinks = [], - nrContactLinks = [l], - nrAdminAddress = Just "simplex:/admin/...", - nrAdminEmail = Just "admin@example.org", - nrExpiry = 1735689600, - nrIsTest = False - } - _ -> error "sampleRecord smart ctors failed" +sampleRecord = + NameRecord + { nrDisplayName = "Alice", + nrOwner = unsafeOwner twentyOnes, + nrChannelLinks = [], + nrContactLinks = [unsafeLink "simplex:/contact/abc#xyz"], + nrAdminAddress = Just "simplex:/admin/...", + nrAdminEmail = Just "admin@example.org", + nrExpiry = 1735689600, + nrIsTest = False + } smpNamesTests :: Spec smpNamesTests = do @@ -111,8 +138,7 @@ nameRecordEncodingSpec = do (J.eitherDecodeStrict badBytes :: Either String NameRecord) `shouldSatisfy` isLeft it "enforces combined channel+contact list cap of 8" $ do - let mkLink i = either error id (mkNameLink ("simplex:/contact/" <> T.pack (show (i :: Int)))) - nineLinks = map mkLink [0 .. 8] + 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) (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft @@ -128,7 +154,7 @@ nameRecordEncodingSpec = do (J.eitherDecodeStrict (json "0X") :: Either String NameOwner) `shouldSatisfy` isRight it "encodes within the proxied transmission budget" $ do - let huge = either error id (mkNameLink (T.replicate 1024 "x")) + let huge = unsafeLink (T.replicate 1024 "x") wide = sampleRecord { nrChannelLinks = replicate 4 huge, @@ -247,10 +273,6 @@ zeroOwnerSpec = do tldWhitelistSpec :: Spec tldWhitelistSpec = do - let addr1 = either error id (mkNameOwner twentyOnes) - addr2 = either error id (mkNameOwner (B.replicate 20 '\x02')) - addr3 = either error id (mkNameOwner (B.replicate 20 '\x03')) - describe "lookupTldAddress" $ do it "TLD-specific entry takes precedence over _all" $ do let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Just addr3} @@ -271,16 +293,7 @@ tldWhitelistSpec = do lookupTldAddress regs TLDWeb `shouldBe` Nothing describe "verifyRslv" $ do - let cfgWith regs = - NamesConfig - { ethereumEndpoint = "http://stub", - tldRegistries = regs, - rpcAuth = Nothing, - rpcTimeoutMs = 1000, - rpcMaxResponseBytes = 65536, - rpcMaxConcurrency = 4 - } - mkEnv regs = newNamesEnvWith (cfgWith regs) (\_ _ -> pure (Right "")) Nothing + let mkEnv regs = newNamesEnvWith (testNamesConfig regs) (\_ _ -> pure (Right "")) Nothing it "accepts a valid name with matching TLD-specific contract" $ do env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} @@ -322,33 +335,28 @@ tldWhitelistSpec = do let req = RslvRequest {name = "privacy", contract = addr1} 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} + -- 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 + resolverSpec :: Spec resolverSpec = do - let mkEnv ethCall = do - let cfg = - NamesConfig - { ethereumEndpoint = "http://stub", - tldRegistries = TldRegistries {tldSimplex = Just (either error id (mkNameOwner twentyOnes)), tldTesting = Nothing, tldAll = Nothing}, - rpcAuth = Nothing, - rpcTimeoutMs = 1000, - rpcMaxResponseBytes = 65536, - rpcMaxConcurrency = 4 - } - newNamesEnvWith cfg ethCall Nothing + let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + mkEnv ethCall = newNamesEnvWith (testNamesConfig regs) ethCall Nothing aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} - aliceAddr = either error id (mkNameOwner twentyOnes) + zeroOwnerResponse = Right (B.replicate (32 * 8) '\NUL') it "maps stub zero-owner response to NotFound" $ do - env <- mkEnv $ \_ _ -> pure (Right (B.replicate (32 * 8) '\NUL')) - r <- resolveName env aliceAddr aliceDomain - r `shouldBe` Left NotFound + env <- mkEnv (\_ _ -> pure zeroOwnerResponse) + resolveName env addr1 aliceDomain `shouldReturn` Left NotFound it "every lookup hits the endpoint (no cache)" $ do callCount <- newIORef (0 :: Int) env <- mkEnv $ \_ _ -> do atomicModifyIORef' callCount (\v -> (v + 1, ())) - pure (Right (B.replicate (32 * 8) '\NUL')) - _ <- resolveName env aliceAddr aliceDomain - _ <- resolveName env aliceAddr aliceDomain - n <- readIORef callCount - n `shouldBe` 2 + pure zeroOwnerResponse + _ <- resolveName env addr1 aliceDomain + _ <- resolveName env addr1 aliceDomain + readIORef callCount `shouldReturn` 2