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

@@ -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)

src/Simplex/Messaging/Encoding.hs

@@ -15,7 +15,6 @@ module Simplex.Messaging.Encoding
     smpEncodeList,
     smpListP,
     lenEncode,
-    lenP,
   )
 where
 

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]

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]
 

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 (..))

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 <token>" / "BEARER <token>" (Caddy / RFC 7235 convention) work

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

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

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

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')

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