smp-server: reuse resolver connection on errors

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

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

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)