From e56bd0b47b22781f9b5936e3b8a9d51cc3f9e8d5 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 12 Jul 2024 12:41:55 +0100 Subject: [PATCH] agent: add known servers (#1225) * agent: add known servers * test delays * ServerCfg * json encoding * enabledServerCfg * checkUserServers --- src/Simplex/Messaging/Agent.hs | 35 ++++++++++----- src/Simplex/Messaging/Agent/Client.hs | 17 ++++---- src/Simplex/Messaging/Agent/Env/SQLite.hs | 52 +++++++++++++++++++++-- tests/AgentTests/FunctionalAPITests.hs | 24 +++++------ tests/SMPAgentClient.hs | 19 ++++++--- tests/SMPProxyTests.hs | 8 ++-- 6 files changed, 111 insertions(+), 44 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 2262a96e5..c08e04298 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -77,6 +77,7 @@ module Simplex.Messaging.Agent getConnectionServers, getConnectionRatchetAdHash, setProtocolServers, + checkUserServers, testProtocolServer, setNtfServers, setNetworkConfig, @@ -172,7 +173,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth, sndAuthKeySMPClientVersion) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -197,15 +198,18 @@ getSMPAgentClient = getSMPAgentClient_ 1 {-# INLINE getSMPAgentClient #-} getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient -getSMPAgentClient_ clientId cfg initServers store backgroundMode = - liftIO $ newSMPAgentEnv cfg store >>= runReaderT runAgent +getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp} store backgroundMode = + newSMPAgentEnv cfg store >>= runReaderT runAgent where runAgent = do + liftIO $ checkServers "SMP" smp >> checkServers "XFTP" xftp currentTs <- liftIO getCurrentTime c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers currentTs =<< ask t <- runAgentThreads c `forkFinally` const (liftIO $ disconnectAgentClient c) atomically . writeTVar acThread . Just =<< mkWeakThreadId t pure c + checkServers protocol srvs = + forM_ (M.assocs srvs) $ \(userId, srvs') -> checkUserServers ("getSMPAgentClient " <> protocol <> " " <> tshow userId) srvs' runAgentThreads c | backgroundMode = run c "subscriber" $ subscriber c | otherwise = do @@ -271,7 +275,7 @@ resumeAgentClient :: AgentClient -> IO () resumeAgentClient c = atomically $ writeTVar (active c) True {-# INLINE resumeAgentClient #-} -createUser :: AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> AE UserId +createUser :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AE UserId createUser c = withAgentEnv c .: createUser' c {-# INLINE createUser #-} @@ -600,11 +604,13 @@ logConnection c connected = let event = if connected then "connected to" else "disconnected from" in logInfo $ T.unwords ["client", tshow (clientId c), event, "Agent"] -createUser' :: AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> AM UserId +createUser' :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AM UserId createUser' c smp xftp = do + liftIO $ checkUserServers "createUser SMP" smp + liftIO $ checkUserServers "createUser XFTP" xftp userId <- withStore' c createUserRecord - atomically $ TM.insert userId smp $ smpServers c - atomically $ TM.insert userId xftp $ xftpServers c + atomically $ TM.insert userId (mkUserServers smp) $ smpServers c + atomically $ TM.insert userId (mkUserServers xftp) $ xftpServers c pure userId deleteUser' :: AgentClient -> UserId -> Bool -> AM () @@ -1815,10 +1821,17 @@ connectionStats = \case ratchetSyncSupported = connAgentVersion >= ratchetSyncSMPAgentVersion } --- | Change servers to be used for creating new queues, in Reader monad -setProtocolServers :: (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> IO () -setProtocolServers c userId srvs = atomically $ TM.insert userId srvs (userServers c) -{-# INLINE setProtocolServers #-} +-- | Change servers to be used for creating new queues. +-- This function will set all servers as enabled in case all passed servers are disabled. +setProtocolServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> NonEmpty (ServerCfg p) -> IO () +setProtocolServers c userId srvs = do + checkUserServers "setProtocolServers" srvs + atomically $ TM.insert userId (mkUserServers srvs) (userServers c) + +checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () +checkUserServers name srvs = + unless (any (\ServerCfg {enabled} -> enabled) srvs) $ + logWarn (name <> ": all passed servers are disabled, using all servers.") registerNtfToken' :: AgentClient -> DeviceToken -> NotificationsMode -> AM NtfTknStatus registerNtfToken' c suppliedDeviceToken suppliedNtfMode = diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 0467c31f8..b8614c460 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -236,6 +236,7 @@ import Simplex.Messaging.Protocol ProtoServerWithAuth (..), Protocol (..), ProtocolServer (..), + ProtocolType (..), ProtocolTypeI (..), QueueId, QueueIdsKeys (..), @@ -289,7 +290,7 @@ data AgentClient = AgentClient active :: TVar Bool, subQ :: TBQueue ATransmission, msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), - smpServers :: TMap UserId (NonEmpty SMPServerWithAuth), + smpServers :: TMap UserId (UserServers 'PSMP), smpClients :: TMap SMPTransportSession SMPClientVar, -- smpProxiedRelays: -- SMPTransportSession defines connection from proxy to relay, @@ -297,7 +298,7 @@ data AgentClient = AgentClient smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth, ntfServers :: TVar [NtfServer], ntfClients :: TMap NtfTransportSession NtfClientVar, - xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth), + xftpServers :: TMap UserId (UserServers 'PXFTP), xftpClients :: TMap XFTPTransportSession XFTPClientVar, useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks userNetworkInfo :: TVar UserNetworkInfo, @@ -456,12 +457,12 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a active <- newTVar True subQ <- newTBQueue qSize msgQ <- newTBQueue qSize - smpServers <- newTVar smp + smpServers <- newTVar $ M.map mkUserServers smp smpClients <- TM.empty smpProxiedRelays <- TM.empty ntfServers <- newTVar ntf ntfClients <- TM.empty - xftpServers <- newTVar xftp + xftpServers <- newTVar $ M.map mkUserServers xftp xftpClients <- TM.empty useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg) userNetworkInfo <- newTVar $ UserNetworkInfo UNOther True @@ -1069,7 +1070,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi SPFAllow -> True SPFAllowProtected -> ipAddressProtected cfg destSrv SPFProhibit -> False - unknownServer = maybe True (all ((destSrv /=) . protoServer)) <$> TM.lookup userId (userServers c) + unknownServer = maybe True (notElem destSrv . knownSrvs) <$> TM.lookup userId (smpServers c) sendViaProxy destSess@(_, _, qId) = do r <- tryAgentError . withProxySession c destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess) -> do r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess @@ -1904,7 +1905,7 @@ storeError = \case SEDatabaseBusy e -> CRITICAL True $ B.unpack e e -> INTERNAL $ show e -userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (NonEmpty (ProtoServerWithAuth p)) +userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (UserServers p) userServers c = case protocolTypeI @p of SPSMP -> smpServers c SPXFTP -> xftpServers c @@ -1926,7 +1927,7 @@ getNextServer c userId usedSrvs = withUserServers c userId $ \srvs -> withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a withUserServers c userId action = atomically (TM.lookup userId $ userServers c) >>= \case - Just srvs -> action srvs + Just srvs -> action $ enabledSrvs srvs _ -> throwE $ INTERNAL "unknown userId - no user servers" withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a @@ -1935,7 +1936,7 @@ withNextSrv c userId usedSrvs initUsed action = do srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used atomically $ do srvs_ <- TM.lookup userId $ userServers c - let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_ + let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_ used' = if null unused then initUsed else srv : used writeTVar usedSrvs $! used' action srvAuth diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 2ae2ad5c0..0f88508b9 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -15,7 +16,12 @@ module Simplex.Messaging.Agent.Env.SQLite AM, AgentConfig (..), InitialAgentServers (..), + ServerCfg (..), + UserServers (..), NetworkConfig (..), + presetServerCfg, + enabledServerCfg, + mkUserServers, defaultAgentConfig, defaultReconnectInterval, tryAgentError, @@ -39,10 +45,14 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as JQ import Data.ByteArray (ScrubbedBytes) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import Data.Map (Map) +import Data.Maybe (fromMaybe) import Data.Time.Clock (NominalDiffTime, nominalDay) import Data.Time.Clock.System (SystemTime (..)) import Data.Word (Word16) @@ -59,7 +69,8 @@ import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRa import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Protocol (NtfServer, VersionRangeSMPC, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange) +import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..)) @@ -74,12 +85,38 @@ type AM' a = ReaderT Env IO a type AM a = ExceptT AgentErrorType (ReaderT Env IO) a data InitialAgentServers = InitialAgentServers - { smp :: Map UserId (NonEmpty SMPServerWithAuth), + { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)), ntf :: [NtfServer], - xftp :: Map UserId (NonEmpty XFTPServerWithAuth), + xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)), netCfg :: NetworkConfig } +data ServerCfg p = ServerCfg + { server :: ProtoServerWithAuth p, + preset :: Bool, + tested :: Maybe Bool, + enabled :: Bool + } + deriving (Show) + +enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p +enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True} + +presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p +presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled} + +data UserServers p = UserServers + { enabledSrvs :: NonEmpty (ProtoServerWithAuth p), + knownSrvs :: NonEmpty (ProtocolServer p) + } + +-- This function sets all servers as enabled in case all passed servers are disabled. +mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p +mkUserServers srvs = UserServers {enabledSrvs, knownSrvs} + where + enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs + knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs + data AgentConfig = AgentConfig { tcpPort :: Maybe ServiceName, rcvAuthAlg :: C.AuthAlg, @@ -294,3 +331,12 @@ updateRestartCount :: SystemTime -> RestartCount -> RestartCount updateRestartCount t (RestartCount minute count) = do let min' = systemSeconds t `div` 60 in RestartCount min' $ if minute == min' then count + 1 else 1 + +$(pure []) + +instance ProtocolTypeI p => ToJSON (ServerCfg p) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg) + toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg) + +instance ProtocolTypeI p => FromJSON (ServerCfg p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index ab78d2ee9..1893ae105 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -980,7 +980,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO () testAllowConnectionClientRestart t = do - let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 withSmpServerStoreLogOn t testPort $ \_ -> do @@ -1335,7 +1335,7 @@ testExpireMessage t = testExpireManyMessages :: HasCallStack => ATransport -> IO () testExpireManyMessages t = - withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b runRight_ $ do @@ -1344,7 +1344,7 @@ testExpireManyMessages t = 2 <- sendMessage a bId SMP.noMsgFlags "1" 3 <- sendMessage a bId SMP.noMsgFlags "2" 4 <- sendMessage a bId SMP.noMsgFlags "3" - liftIO $ threadDelay 1500000 + liftIO $ threadDelay 2000000 5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False -- get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False @@ -1401,7 +1401,7 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP testExpireManyMessagesQuota :: ATransport -> IO () testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB + a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b @@ -1411,7 +1411,7 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} 3 <- sendMessage a bId SMP.noMsgFlags "2" 4 <- sendMessage a bId SMP.noMsgFlags "3" 5 <- sendMessage a bId SMP.noMsgFlags "4" - liftIO $ threadDelay 1000000 + liftIO $ threadDelay 2000000 6 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False get a >>= \case @@ -2226,7 +2226,7 @@ testWaitDeliveryTimeout2 t = testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () testJoinConnectionAsyncReplyErrorV8 t = do - let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do @@ -2265,7 +2265,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () testJoinConnectionAsyncReplyError t = do - let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do @@ -2308,7 +2308,7 @@ testUsers = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetings a bId' b aId' deleteUser a auId True @@ -2323,7 +2323,7 @@ testDeleteUserQuietly = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetings a bId' b aId' deleteUser a auId False @@ -2335,7 +2335,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetings a bId' b aId' pure (aId, bId, auId, aId', bId') @@ -2759,7 +2759,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 baseId = do pure r where getClient clientId (clntAuth, clntVersion) db = - let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]} + let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]} alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 @@ -2931,7 +2931,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a a `hasClients` 1 - aUserId2 <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + aUserId2 <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1 exchangeGreetings a bId2 b aId2 (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1 diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 7cb2a88c5..e0de57466 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -11,6 +11,7 @@ module SMPAgentClient where import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import NtfClient (ntfTestPort) @@ -20,7 +21,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) -import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth) +import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer) import Simplex.Messaging.Transport import XFTPClient (testXFTPServer) @@ -48,14 +49,14 @@ testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6 initAgentServers :: InitialAgentServers initAgentServers = InitialAgentServers - { smp = userServers [noAuthSrv testSMPServer], + { smp = userServers [testSMPServer], ntf = [testNtfServer], - xftp = userServers [noAuthSrv testXFTPServer], + xftp = userServers [testXFTPServer], netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000} } initAgentServers2 :: InitialAgentServers -initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]} +initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]} initAgentServersProxy :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers initAgentServersProxy smpProxyMode smpProxyFallback = @@ -89,5 +90,11 @@ fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} fastMessageRetryInterval :: RetryInterval2 fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval} -userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p)) -userServers srvs = M.fromList [(1, srvs)] +userServers :: NonEmpty (ProtocolServer p) -> Map UserId (NonEmpty (ServerCfg p)) +userServers = userServers' . L.map noAuthSrv + +userServers' :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ServerCfg p)) +userServers' srvs = M.fromList [(1, L.map (presetServerCfg True) srvs)] + +noAuthSrvCfg :: ProtocolServer p -> ServerCfg p +noAuthSrvCfg = presetServerCfg True . noAuthSrv diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 6452d2677..625dfbda7 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -234,7 +234,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b where msgId = subtract baseId . fst aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} - servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} + servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers srvs} agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () agentDeliverMessagesViaProxyConc agentServers msgs = @@ -299,7 +299,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = logDebug "run finished" pqEnc = CR.PQEncOn aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} - servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} + servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers srvs} agentViaProxyVersionError :: IO () agentViaProxyVersionError = @@ -310,7 +310,7 @@ agentViaProxyVersionError = A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () where - servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers $ L.map noAuthSrv srvs} + servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs} agentViaProxyRetryOffline :: IO () agentViaProxyRetryOffline = do @@ -372,7 +372,7 @@ agentViaProxyRetryOffline = do aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} baseId = 1 msgId = subtract baseId . fst - servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers $ L.map noAuthSrv [srv]} + servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} testNoProxy :: IO () testNoProxy = do