diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e3d4e72282..cb36e989da 100644 --- a/simplex-chat.cabal +++ b/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: diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 6304b22f72..c803570d99 100644 --- a/tests/ChatClient.hs +++ b/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" diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index ab532edaf2..3bb796d89b 100644 --- a/tests/ChatTests.hs +++ b/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 diff --git a/tests/ChatTests/Names.hs b/tests/ChatTests/Names.hs new file mode 100644 index 0000000000..205f942be2 --- /dev/null +++ b/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") diff --git a/tests/NameResolver.hs b/tests/NameResolver.hs new file mode 100644 index 0000000000..b7c0aaf2fc --- /dev/null +++ b/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/ 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 + }