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.

Author: shumvgolove

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