mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-17 01:35:12 +00:00
agent: add known servers (#1225)
* agent: add known servers * test delays * ServerCfg * json encoding * enabledServerCfg * checkUserServers
This commit is contained in:
Evgeny Poberezkin
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
+13
-6
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user