From 08b84deba458407ae97d55debd98b872cb6c4d79 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 24 Apr 2025 17:11:52 +0100 Subject: [PATCH] agent: option to use web port by default for preset servers only (#1523) * agent: option to use web port by default for preset servers only * shorten/restore short links in agent, add encodings for SMP web port setting * decouple preset domains from preset servers for short links * refactor, rename --- src/Simplex/Messaging/Agent/Client.hs | 12 ++++--- src/Simplex/Messaging/Agent/Env/SQLite.hs | 3 +- src/Simplex/Messaging/Client.hs | 42 +++++++++++++++++++---- src/Simplex/Messaging/Client/Agent.hs | 2 +- tests/AgentTests/ServerChoice.hs | 3 +- tests/SMPAgentClient.hs | 3 +- tests/SMPProxyTests.hs | 6 ++-- 7 files changed, 52 insertions(+), 19 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 240b25f7e..ff0186f22 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -326,6 +326,7 @@ data AgentClient = AgentClient xftpServers :: TMap UserId (UserServers 'PXFTP), xftpClients :: TMap XFTPTransportSession XFTPClientVar, useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks + presetSMPDomains :: [HostName], userNetworkInfo :: TVar UserNetworkInfo, userNetworkUpdated :: TVar (Maybe UTCTime), subscrConns :: TVar (Set ConnId), @@ -478,7 +479,7 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient -newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do +newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomains} currentTs agentEnv = do let cfg = config agentEnv qSize = tbqSize cfg proxySessTs <- newTVarIO =<< getCurrentTime @@ -532,6 +533,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a xftpServers, xftpClients, useNetworkConfig, + presetSMPDomains = presetDomains, userNetworkInfo, userNetworkUpdated, subscrConns, @@ -690,7 +692,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) env <- ask liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do ts <- readTVarIO proxySessTs - smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs + smp <- ExceptT $ getProtocolClient g tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs} smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO () @@ -793,7 +795,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS g <- asks random ts <- readTVarIO proxySessTs liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $ - getProtocolClient g tSess cfg Nothing ts $ + getProtocolClient g tSess cfg [] Nothing ts $ clientDisconnected v clientDisconnected :: NtfClientVar -> NtfClient -> IO () @@ -1225,7 +1227,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case + getProtocolClient g tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case Right smp -> do rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g @@ -1302,7 +1304,7 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case + getProtocolClient g tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case Right ntf -> do (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, _) <- atomically $ C.generateKeyPair g diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 7b286d3d7..0c10d8cd4 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -96,7 +96,8 @@ data InitialAgentServers = InitialAgentServers { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)), ntf :: [NtfServer], xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)), - netCfg :: NetworkConfig + netCfg :: NetworkConfig, + presetDomains :: [HostName] } data ServerCfg p = ServerCfg diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7c18a0aa1..b56d875a4 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -84,6 +84,7 @@ module Simplex.Messaging.Client SocksMode (..), SMPProxyMode (..), SMPProxyFallback (..), + SMPWebPortServers (..), defaultClientConfig, defaultSMPClientConfig, defaultNetworkConfig, @@ -129,7 +130,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find) +import Data.List (find, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Maybe (catMaybes, fromMaybe) @@ -138,7 +139,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime) import qualified Data.X509 as X import qualified Data.X509.Validation as XV -import Network.Socket (ServiceName) +import Network.Socket (HostName, ServiceName) import Network.Socks5 (SocksCredentials (..)) import Numeric.Natural import qualified Simplex.Messaging.Crypto as C @@ -291,7 +292,7 @@ data NetworkConfig = NetworkConfig -- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions smpProxyFallback :: SMPProxyFallback, -- | use web port 443 for SMP protocol - smpWebPort :: Bool, + smpWebPortServers :: SMPWebPortServers, -- | timeout for the initial client TCP/TLS connection (microseconds) tcpConnectTimeout :: Int, -- | timeout of protocol commands (microseconds) @@ -327,6 +328,12 @@ data SMPProxyFallback | SPFProhibit -- prohibit direct connection to destination relay. deriving (Eq, Show) +data SMPWebPortServers + = SWPAll + | SWPPreset + | SWPOff + deriving (Eq, Show) + instance StrEncoding SMPProxyMode where strEncode = \case SPMAlways -> "always" @@ -353,6 +360,18 @@ instance StrEncoding SMPProxyFallback where "no" -> pure SPFProhibit _ -> fail "Invalid SMP proxy fallback mode" +instance StrEncoding SMPWebPortServers where + strEncode = \case + SWPAll -> "all" + SWPPreset -> "preset" + SWPOff -> "off" + strP = + A.takeTill (== ' ') >>= \case + "all" -> pure SWPAll + "preset" -> pure SWPPreset + "off" -> pure SWPOff + _ -> fail "Invalid SMP wep port setting" + defaultNetworkConfig :: NetworkConfig defaultNetworkConfig = NetworkConfig @@ -363,7 +382,7 @@ defaultNetworkConfig = sessionMode = TSMSession, smpProxyMode = SPMNever, smpProxyFallback = SPFAllow, - smpWebPort = False, + smpWebPortServers = SWPPreset, tcpConnectTimeout = defaultTcpConnectTimeout, tcpTimeout = 15_000_000, tcpTimeoutPerKb = 5_000, @@ -498,15 +517,15 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} msgQ proxySessTs disconnected = do +getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost) `catch` \(e :: IOException) -> pure . Left $ PCEIOError e Left e -> pure $ Left e where - NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig + NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg) mkProtocolClient transportHost ts = do connected <- newTVarIO False @@ -554,6 +573,13 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize SPSMP | smpWebPort -> ("443", transport @TLS) _ -> defaultTransport cfg p -> (p, transport @TLS) + where + smpWebPort = case smpWebPortServers of + SWPAll -> True + SWPPreset -> case srv of + ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains + _ -> False + SWPOff -> False client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO () client _ c cVar h = do @@ -1262,6 +1288,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode) $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback) +$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers) + $(J.deriveJSON defaultJSON ''NetworkConfig) $(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 1a7a67806..1eeb607b2 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -198,7 +198,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} = -- | Run an SMP client for SMPClientVar connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient) connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v = - getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected + getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected where clientDisconnected :: SMPClient -> IO () clientDisconnected smp = do diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index 0df995d08..12e690888 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -61,7 +61,8 @@ initServers = { smp = M.fromList [(1, testSMPServers)], ntf = [testNtfServer], xftp = userServers [testXFTPServer], - netCfg = defaultNetworkConfig + netCfg = defaultNetworkConfig, + presetDomains = [] } testChooseDifferentOperator :: IO () diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 2903de05c..5edf4cf0f 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -65,7 +65,8 @@ initAgentServers = { smp = userServers [testSMPServer], ntf = [testNtfServer], xftp = userServers [testXFTPServer], - netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000} + netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}, + presetDomains = [] } initAgentServers2 :: InitialAgentServers diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 7ef66544e..c26e97902 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -167,12 +167,12 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- set up relay msgQ <- newTBQueueIO 1024 - rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ()) + rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} [] (Just msgQ) ts (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g @@ -210,7 +210,7 @@ proxyConnectDeadRelay n d proxyServ = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- get proxy session