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)