smp-server: address audit findings (canonical JSON, INI guards, SSRF, TLD case, shutdown)

src/Simplex/Messaging/Protocol.hs

@@ -816,6 +816,19 @@ instance J.ToJSON NameRecord where
         "expiry" J..= nrExpiry,
         "isTest" J..= nrIsTest
       ]
+  -- explicit toEncoding to preserve the spec-documented key order; the default
+  -- routes through Value/KeyMap and re-emits keys alphabetically, breaking the
+  -- "two routers MUST emit byte-identical JSON" requirement.
+  toEncoding NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} =
+    J.pairs $
+      "displayName" J..= nrDisplayName
+        <> "owner" J..= nrOwner
+        <> "channelLinks" J..= nrChannelLinks
+        <> "contactLinks" J..= nrContactLinks
+        <> "adminAddress" J..= nrAdminAddress
+        <> "adminEmail" J..= nrAdminEmail
+        <> "expiry" J..= nrExpiry
+        <> "isTest" J..= nrIsTest
 
 instance J.FromJSON NameRecord where
   parseJSON = J.withObject "NameRecord" $ \o -> do

src/Simplex/Messaging/Server.hs

@@ -247,8 +247,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
 
     closeServer :: M s ()
     closeServer = do
-      asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
-      asks namesEnv >>= liftIO . mapM_ closeNamesEnv
+      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 ::
       forall sub. String ->

src/Simplex/Messaging/Server/Main.hs

@@ -813,15 +813,22 @@ readNamesConfig ini
               { ethereumEndpoint = either (error . ("[NAMES] ethereum_endpoint: " <>)) id (validateUrl endpoint rpcAuth_),
                 tldRegistries = registries,
                 rpcAuth = rpcAuth_,
-                rpcTimeoutMs = readIniDefault 3000 "NAMES" "rpc_timeout_ms" ini,
-                rpcMaxResponseBytes = readIniDefault 262144 "NAMES" "rpc_max_response_bytes" ini,
-                rpcMaxConcurrency = readIniDefault 8 "NAMES" "rpc_max_concurrency" ini
+                rpcTimeoutMs = positiveIniInt 3000 100 "rpc_timeout_ms",
+                rpcMaxResponseBytes = positiveIniInt 262144 1024 "rpc_max_response_bytes",
+                rpcMaxConcurrency = positiveIniInt 8 1 "rpc_max_concurrency"
               }
   where
     enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini)
     requiredText key =
       either (error . (("[NAMES] " <> T.unpack key <> " is required: ") <>)) id $
         lookupValue "NAMES" key ini
+    -- Reject zero / negative values that would deadlock waitQSem (concurrency = 0),
+    -- time-out every RSLV immediately (timeout = 0), or accept zero-length
+    -- responses (max_response_bytes = 0). The lower bounds also catch sub-sane
+    -- values an operator might choose by accident.
+    positiveIniInt def floor_ key = case readIniDefault def "NAMES" key ini of
+      n | n >= floor_ -> n
+        | otherwise -> error $ "[NAMES] " <> T.unpack key <> " must be at least " <> show floor_ <> " (got " <> show n <> ")"
     readTldRegistries =
       let regs = TldRegistries
             { tldSimplex = optionalAddr "registry_tld_simplex",
@@ -843,8 +850,12 @@ readNamesConfig ini
 --   * userinfo (user:pass@) MUST NOT be present (credentials belong in
 --     rpc_auth so they don't leak via Host header or logs)
 --   * query and fragment MUST NOT be present
---   * https requires rpc_auth on non-loopback hosts (operator misconfig
---     guard — a public HTTPS endpoint without auth is almost always wrong)
+--   * http is rejected on non-loopback hosts (plaintext to a third party
+--     leaks rpc_auth on every request)
+--   * https requires rpc_auth on non-loopback hosts (a public endpoint
+--     without auth is almost always misconfig)
+--   * link-local hosts (169.254.0.0/16, including the cloud metadata IP
+--     169.254.169.254) are rejected unconditionally
 validateUrl :: Text -> Maybe RpcAuth -> Either String Text
 validateUrl url auth_ = do
   uri <- maybe (Left "not an absolute URI") Right $ parseAbsoluteURI (T.unpack url)
@@ -852,12 +863,14 @@ validateUrl url auth_ = do
   unless (scheme == "http:" || scheme == "https:") $
     Left ("scheme " <> show scheme <> " not supported (use http or https)")
   ua <- maybe (Left "missing authority (host)") Right (uriAuthority uri)
-  when (null (uriRegName ua)) $ Left "empty host"
+  let host = uriRegName ua
+  when (null host) $ Left "empty host"
+  when (isLinkLocal host) $ Left "link-local host not allowed (rejects cloud metadata services)"
   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)"
     ':' : portStr -> case readMaybe portStr of
-      Just n | n >= 1 && n <= 65535 -> Right ()
+      Just n | (n :: Int) >= 1 && n <= 65535 -> Right ()
       _ -> Left $ "port " <> portStr <> " out of range (must be 1..65535)"
     other -> Left $ "unexpected port syntax: " <> other
   unless (null (uriQuery uri)) $ Left "query string not allowed"
@@ -865,11 +878,14 @@ 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 == "https:" && not (isLoopback (uriRegName ua)) && isNothing auth_) $
+  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"
   Right url
   where
     isLoopback h = h == "127.0.0.1" || h == "localhost" || h == "[::1]"
+    isLinkLocal h = "169.254." `isPrefixOf` h || h == "[fe80::1]"
 
 -- | Parse a 20-byte Ethereum address as text "0x[hex40]" or "[hex40]".
 -- EIP-55 mixed-case checksum verification is a follow-up.

src/Simplex/Messaging/Server/Names.hs

@@ -201,6 +201,6 @@ mapEthRpcError :: EthRpcError -> ResolveError
 mapEthRpcError = \case
   HttpFailure _ -> EthHttpErr
   HttpStatusErr _ -> EthHttpErr
-  BodyTooLarge -> EthDecodeErr
+  BodyTooLarge -> EthHttpErr -- transport-side cap, not a decoder failure
   InvalidJson _ -> EthDecodeErr
   JsonRpcErr c m -> EthRpcErr {rpcCode = c, rpcMessage = m}

src/Simplex/Messaging/SimplexName.hs

@@ -75,12 +75,16 @@ instance StrEncoding SimplexNameDomain where
   strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
     where
       parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain
+      -- TLD label compared lowercase: DNS labels are case-insensitive, and a
+      -- mixed-case `foo.SIMPLEX` would otherwise fall through to TLDWeb and
+      -- route through `registry_tld_all` instead of `registry_tld_simplex`.
       mkDomain labels = case reverse labels of
         [] -> Left "empty name"
         [_] -> Left "domain requires TLD"
-        "simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub
-        "testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub
-        _ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) []
+        tld : name : sub -> Right $ case T.toLower tld of
+          "simplex" -> SimplexNameDomain TLDSimplex name sub
+          "testing" -> SimplexNameDomain TLDTesting name sub
+          _ -> SimplexNameDomain TLDWeb (T.intercalate "." labels) []
 
 fullDomainName :: SimplexNameDomain -> Text
 fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')

tests/SMPNamesTests.hs

@@ -10,6 +10,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteArray as BA
 import Data.Either (isLeft, isRight)
 import Data.IORef (atomicModifyIORef', newIORef, readIORef)
+import Data.List (sort)
 import qualified Data.Text as T
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Lazy as LB
@@ -97,6 +98,14 @@ nameRecordEncodingSpec = do
   it "round-trips JSON encode / decode" $
     J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord)) `shouldBe` Right sampleRecord
 
+  it "emits keys in spec-documented order (displayName, owner, channelLinks, contactLinks, adminAddress, adminEmail, expiry, isTest)" $ do
+    -- Default toEncoding routes through Value/KeyMap and re-emits keys
+    -- alphabetically; spec requires byte-identical canonical encoding.
+    let bytes = LB.toStrict (J.encode sampleRecord)
+        offset k = B.length (fst (B.breakSubstring k bytes))
+        offsets = map offset ["displayName", "owner", "channelLinks", "contactLinks", "adminAddress", "adminEmail", "expiry", "isTest"]
+    offsets `shouldBe` sort offsets
+
   it "rejects negative expiry" $ do
     let badBytes = LB.toStrict (J.encode sampleRecord {nrExpiry = -1})
     (J.eitherDecodeStrict badBytes :: Either String NameRecord) `shouldSatisfy` isLeft