name resolution test

simplex-chat.cabal

@@ -582,12 +582,14 @@ test-suite simplex-chat-test
       ChatTests.Forward
       ChatTests.Groups
       ChatTests.Local
+      ChatTests.Names
       ChatTests.Profiles
       ChatTests.Utils
       JSONFixtures
       JSONTests
       MarkdownTests
       MemberRelationsTests
+      NameResolver
       MessageBatching
       OperatorTests
       ProtocolTests
@@ -668,6 +670,8 @@ test-suite simplex-chat-test
     , unicode-transforms ==0.4.*
     , unliftio ==0.2.*
     , uri-bytestring >=0.3.3.1 && <0.4
+    , wai ==3.2.*
+    , warp ==3.3.*
   default-language: Haskell2010
   if flag(client_postgres)
     other-modules:

tests/ChatClient.hs

@@ -59,6 +59,7 @@ import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..), defaultMessageExpiration, defaultIdleQueueInterval, defaultNtfExpiration, defaultInactiveClientExpiration)
+import NameResolver (NameRegistry, resolverNamesConfig, withNameResolver)
 import Simplex.Messaging.Server.MsgStore.STM (STMMsgStore)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
@@ -590,6 +591,13 @@ withSmpServer = withSmpServer' smpServerCfg
 withSmpServer' :: ServerConfig STMMsgStore -> IO a -> IO a
 withSmpServer' cfg = serverBracket (\started -> runSMPServerBlocking started cfg Nothing)
 
+-- | SMP server with a local names resolver attached; the action gets the resolver
+-- registry to map names to the addresses it creates.
+withSmpServerAndNames :: (NameRegistry -> IO a) -> IO a
+withSmpServerAndNames action =
+  withNameResolver $ \port reg ->
+    withSmpServer' smpServerCfg {namesConfig = Just (resolverNamesConfig port)} (action reg)
+
 xftpTestPort :: ServiceName
 xftpTestPort = "7002"
 

tests/ChatTests.hs

@@ -8,6 +8,7 @@ import ChatTests.Files
 import ChatTests.Forward
 import ChatTests.Groups
 import ChatTests.Local
+import ChatTests.Names
 import ChatTests.Profiles
 import Test.Hspec hiding (it)
 
@@ -21,3 +22,4 @@ chatTests = do
   describe "file tests" chatFileTests
   describe "profile tests" chatProfileTests
   describe "chat list pagination tests" chatListTests
+  describe "names tests" chatNamesTests

tests/ChatTests/Names.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PostfixOperators #-}
+
+module ChatTests.Names where
+
+import ChatClient
+import ChatTests.DBUtils
+import ChatTests.Utils
+import Control.Concurrent.Async (concurrently_)
+import qualified Data.Text as T
+import NameResolver
+import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..))
+import Test.Hspec hiding (it)
+
+chatNamesTests :: SpecWith TestParams
+chatNamesTests =
+  it "connect by resolved name" testConnectByName
+
+testConnectByName :: HasCallStack => TestParams -> IO ()
+testConnectByName ps = withSmpServerAndNames $ \reg ->
+  testChat2 aliceProfile bobProfile (test reg) ps
+  where
+    aliceName = SimplexNameInfo NTContact (SimplexNameDomain TLDSimplex "alice" [])
+    test reg alice bob = do
+      alice ##> "/ad"
+      cLink <- getContactLink alice True
+      registerName reg aliceName (contactNameRecord "alice" (T.pack cLink))
+      bob ##> "/c @alice.simplex"
+      alice <#? bob
+      alice ##> "/ac bob"
+      concurrently_
+        (bob <## "alice (Alice): contact is connected")
+        (alice <## "bob (Bob): contact is connected")

tests/NameResolver.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Local HTTP names resolver for chat tests, copied from simplexmq's
+-- NamesResolverServer and made dynamic: it answers /resolve/<domain> from a
+-- mutable name -> NameRecord registry, so a test can resolve a name to the
+-- address it just created.
+module NameResolver
+  ( NameRegistry,
+    withNameResolver,
+    registerName,
+    contactNameRecord,
+    channelNameRecord,
+    resolverNamesConfig,
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Data.Aeson as J
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import Network.HTTP.Types (hContentType, notFound404, ok200)
+import Network.Wai (Application, pathInfo, responseLBS)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Messaging.Names.Record (NameRecord (..))
+import Simplex.Messaging.Server.Names (NamesConfig (..))
+import Simplex.Messaging.SimplexName (SimplexNameInfo (..), fullDomainName)
+
+type NameRegistry = TVar (Map Text NameRecord)
+
+-- | Run an action with a local resolver on a free port and its registry (keyed
+-- by full domain name, what the resolver looks the name up by).
+withNameResolver :: (Int -> TVar (Map Text NameRecord) -> IO a) -> IO a
+withNameResolver action = do
+  reg <- newTVarIO M.empty
+  Warp.withApplication (pure (app reg)) $ \port -> action port reg
+  where
+    app :: TVar (Map Text NameRecord) -> Application
+    app reg req send = do
+      (st, body) <- case pathInfo req of
+        ["health"] -> pure (ok200, "{}")
+        ["resolve", d] -> maybe (notFound404, "{}") (\r -> (ok200, J.encode r)) . M.lookup d <$> readTVarIO reg
+        _ -> pure (notFound404, "{}")
+      send $ responseLBS st [(hContentType, "application/json")] body
+
+-- | Register a name's domain to resolve to the given record.
+registerName :: TVar (Map Text NameRecord) -> SimplexNameInfo -> NameRecord -> IO ()
+registerName reg SimplexNameInfo {nameDomain} r =
+  atomically $ modifyTVar' reg $ M.insert (fullDomainName nameDomain) r
+
+contactNameRecord :: Text -> Text -> NameRecord
+contactNameRecord name link = (emptyRecord name) {nrSimplexContact = [link]}
+
+channelNameRecord :: Text -> Text -> NameRecord
+channelNameRecord name link = (emptyRecord name) {nrSimplexChannel = [link]}
+
+emptyRecord :: Text -> NameRecord
+emptyRecord name =
+  NameRecord
+    { nrName = name,
+      nrNickname = "",
+      nrWebsite = "",
+      nrLocation = "",
+      nrSimplexContact = [],
+      nrSimplexChannel = [],
+      nrEth = Nothing,
+      nrBtc = Nothing,
+      nrXmr = Nothing,
+      nrDot = Nothing,
+      nrOwner = "",
+      nrResolver = ""
+    }
+
+-- | NamesConfig for a chat test SMP server pointing at this resolver.
+resolverNamesConfig :: Int -> NamesConfig
+resolverNamesConfig port =
+  NamesConfig
+    { resolverEndpoint = "http://127.0.0.1:" <> show port,
+      resolverAuth = Nothing,
+      resolverTimeoutMs = 1000,
+      resolverMaxResponseBytes = 65536
+    }