From 0308d0536fcd5125449d30005bbc86be68311dc2 Mon Sep 17 00:00:00 2001
From: shum <github.shum@liber.li>
Date: Wed, 30 Sep 2026 11:31:30 +0000
Subject: [PATCH] smp-server: reuse resolver connection on errors

---
 src/Simplex/Messaging/Server/Names/HttpResolver.hs |  3 ++-
 tests/NamesResolverServer.hs                       | 14 ++++++++++++--
 tests/SMPNamesTests.hs                             | 10 +++++++++-
 3 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Server/Names/HttpResolver.hs b/src/Simplex/Messaging/Server/Names/HttpResolver.hs
index 504348fe8..caa49229a 100644
--- a/src/Simplex/Messaging/Server/Names/HttpResolver.hs
+++ b/src/Simplex/Messaging/Server/Names/HttpResolver.hs
@@ -136,8 +136,9 @@ httpGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes}
           }
   result <- E.try $ withResponse req manager $ \res -> do
     let status = HT.statusCode (responseStatus res)
+    -- http-client closes the connection unless the body is read to the end
     if status >= 400
-      then pure (Left (HttpStatusErr status))
+      then Left (HttpStatusErr status) <$ brReadSome (responseBody res) (maxResponseBytes + 1)
       else do
         bs <- brReadSome (responseBody res) (maxResponseBytes + 1)
         pure $ if BL.length bs > fromIntegral maxResponseBytes then Left BodyTooLarge else Right bs
diff --git a/tests/NamesResolverServer.hs b/tests/NamesResolverServer.hs
index 59414dc6b..90ce6338f 100644
--- a/tests/NamesResolverServer.hs
+++ b/tests/NamesResolverServer.hs
@@ -9,6 +9,7 @@
 module NamesResolverServer
   ( withResolverServer,
     withResolverServerDelayed,
+    withResolverServerConns,
     resolveResp,
     testNamesConfig,
     memCfg,
@@ -36,9 +37,18 @@ withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Tex
 withResolverServer = withResolverServerDelayed 0
 
 withResolverServerDelayed :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
-withResolverServerDelayed delayMs handler action = do
+withResolverServerDelayed delayMs handler action = withResolverServer_ delayMs handler $ \port reqs _ -> action port reqs
+
+-- | Also counts the TCP connections the resolver accepted.
+withResolverServerConns :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a
+withResolverServerConns = withResolverServer_ 0
+
+withResolverServer_ :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a
+withResolverServer_ delayMs handler action = do
   reqs <- newIORef []
-  Warp.withApplication (pure (app reqs)) $ \port -> action port reqs
+  conns <- newIORef 0
+  let settings = Warp.setOnOpen (\_ -> True <$ atomicModifyIORef' conns (\n -> (n + 1, ()))) Warp.defaultSettings
+  Warp.withApplicationSettings settings (pure (app reqs)) $ \port -> action port reqs conns
   where
     app :: IORef [[Text]] -> Application
     app reqs req send = do
diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs
index 7f28a0b34..78ae09751 100644
--- a/tests/SMPNamesTests.hs
+++ b/tests/SMPNamesTests.hs
@@ -5,6 +5,7 @@
 
 module SMPNamesTests (smpNamesTests, testNameRecord, testPricing, registeredBody, availableBody, reservedBody, responseBody, resolved) where
 
+import Control.Monad (forM_)
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
@@ -15,7 +16,7 @@ import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Network.HTTP.Types (status200, status400, status404, status500, status502)
-import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerDelayed)
+import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerConns, withResolverServerDelayed)
 import Simplex.Messaging.Encoding (smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String (strDecode)
 import Simplex.Messaging.Protocol (Command (..), ErrorType (..), NameErrorType (..), NamePricing (..), NameQuery (..), NameRecord (..), NameRegistration (..), NameResponse (..), NameReservedReason (..), ProtocolEncoding (..), USDCents (..))
@@ -302,6 +303,13 @@ resolverSpec = do
       _ <- resolveName env aliceDomain
       readIORef reqs >>= \rs -> length rs `shouldBe` 2
 
+  it "keeps the resolver connection alive across error responses" $
+    withResolverServerConns (resolveResp status502 "{\"error\":\"upstream\"}") $ \port reqs conns -> do
+      env <- newNamesEnv (testNamesConfig port)
+      forM_ [1 .. 5 :: Int] $ \_ -> resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 502")
+      length <$> readIORef reqs `shouldReturn` 5
+      readIORef conns `shouldReturn` 1
+
   it "addresses the resolver with the full canonical domain name" $
     withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port reqs -> do
       env <- newNamesEnv (testNamesConfig port)