From 8e86c97a1334e0627640192e215865187ba2a263 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 3 Jun 2025 13:35:35 +0100 Subject: [PATCH] servers: include supported ALPNs in server transport config (#1557) --- src/Simplex/FileTransfer/Client.hs | 6 ++-- src/Simplex/FileTransfer/Server.hs | 14 ++++----- src/Simplex/FileTransfer/Server/Main.hs | 10 +++---- src/Simplex/FileTransfer/Transport.hs | 6 ++-- src/Simplex/Messaging/Client.hs | 10 +++---- src/Simplex/Messaging/Notifications/Client.hs | 4 +-- src/Simplex/Messaging/Notifications/Server.hs | 2 +- .../Messaging/Notifications/Server/Main.hs | 10 +++---- .../Messaging/Notifications/Transport.hs | 4 +-- src/Simplex/Messaging/Server.hs | 6 ++-- src/Simplex/Messaging/Server/Main.hs | 10 +++---- src/Simplex/Messaging/Transport.hs | 6 ++-- src/Simplex/Messaging/Transport/Client.hs | 6 ++-- .../Messaging/Transport/HTTP2/Client.hs | 2 +- .../Messaging/Transport/HTTP2/Server.hs | 12 ++++---- src/Simplex/Messaging/Transport/Server.hs | 30 ++++++++++--------- src/Simplex/RemoteControl/Discovery.hs | 4 +-- tests/AgentTests/FunctionalAPITests.hs | 4 +-- tests/CLITests.hs | 4 +-- tests/CoreTests/SOCKSSettings.hs | 2 +- tests/NtfClient.hs | 6 ++-- tests/SMPClient.hs | 8 ++--- tests/XFTPAgent.hs | 14 ++++----- tests/XFTPClient.hs | 15 +++++----- 24 files changed, 98 insertions(+), 97 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 5538da416..2aa7d4757 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -57,7 +57,7 @@ import Simplex.Messaging.Protocol pattern NoEntity, ) import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) -import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn) +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client import Simplex.Messaging.Transport.HTTP2.File @@ -99,7 +99,7 @@ defaultXFTPClientConfig = XFTPClientConfig { xftpNetworkConfig = defaultNetworkConfig, serverVRange = supportedFileServerVRange, - clientALPN = Just supportedXFTPhandshakes + clientALPN = Just alpnSupportedXFTPhandshakes } getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) @@ -107,7 +107,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession ProtocolServer _ host port keyHash = srv useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host - let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN} + let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN http2Config = xftpHTTP2Config tcConfig config clientVar <- newTVarIO Nothing let usePort = if null port then "443" else port diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 63f0b5440..b4e71ec19 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -61,7 +61,7 @@ import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatu import Simplex.Messaging.Server.Stats import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams) +import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) @@ -92,17 +92,17 @@ data XFTPTransportRequest = XFTPTransportRequest runXFTPServer :: XFTPServerConfig -> IO () runXFTPServer cfg = do started <- newEmptyTMVarIO - runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes + runXFTPServerBlocking started cfg -runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO () -runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_) +runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO () +runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) data Handshake = HandshakeSent C.PrivateKeyX25519 | HandshakeAccepted (THandleParams XFTPVersion 'TServer) -xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M () -xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do +xftpServer :: XFTPServerConfig -> TMVar Bool -> M () +xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do mapM_ (expireServerFiles Nothing) fileExpiration restoreServerStats raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer @@ -116,7 +116,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira env <- ask sessions <- liftIO TM.emptyIO let cleanup sessionId = atomically $ TM.delete sessionId sessions - liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do + liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do reqBody <- getHTTP2Body r xftpBlockSize let v = VersionXFTP 1 thServerVRange = versionToRange v diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 757d2fe24..e2abc55ac 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -21,7 +21,7 @@ import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration) -import Simplex.FileTransfer.Transport (supportedFileServerVRange) +import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) @@ -29,7 +29,7 @@ import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) @@ -189,9 +189,9 @@ xftpServerCLI cfgPath logPath = do serverStatsLogFile = combine logPath "file-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log", transportConfig = - defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini - }, + mkTransportServerConfig + (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) + (Just alpnSupportedXFTPhandshakes), responseDelay = 0 } diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index c49812fdb..ce0190f1f 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -13,7 +13,7 @@ module Simplex.FileTransfer.Transport authCmdsXFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub, - supportedXFTPhandshakes, + alpnSupportedXFTPhandshakes, XFTPClientHandshake (..), -- xftpClientHandshake, XFTPServerHandshake (..), @@ -104,8 +104,8 @@ supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient) xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion -supportedXFTPhandshakes :: [ALPN] -supportedXFTPhandshakes = ["xftp/1"] +alpnSupportedXFTPhandshakes :: [ALPN] +alpnSupportedXFTPhandshakes = ["xftp/1"] data XFTPServerHandshake = XFTPServerHandshake { xftpVersionRange :: VersionRangeXFTP, diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 270e6875e..fc818577a 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -393,9 +393,9 @@ defaultNetworkConfig = logTLSErrors = False } -transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig -transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI = - TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI} +transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig +transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN = + TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI} where socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy useSocksProxy SMAlways = socksProxy' @@ -455,7 +455,7 @@ defaultClientConfig clientALPN useSNI serverVRange = defaultSMPClientConfig :: ProtocolClientConfig SMPVersion defaultSMPClientConfig = - (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange) + (defaultClientConfig (Just alpnSupportedSMPHandshakes) False supportedClientSMPRelayVRange) { defaultTransport = (show defaultSMPPort, transport @TLS), agreeSecret = True } @@ -556,7 +556,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) runClient (port', ATransport t) useHost c = do cVar <- newEmptyTMVarIO - let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN} + let tcConfig = transportClientConfig networkConfig useHost useSNI clientALPN socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession tId <- runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar) diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index e6d456f0f..ecfe02c86 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -14,7 +14,7 @@ import Data.Word (Word16) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes) +import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, alpnSupportedNTFHandshakes) import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity) import Simplex.Messaging.Transport (TLS, Transport (..)) @@ -24,7 +24,7 @@ type NtfClientError = ProtocolClientError ErrorType defaultNTFClientConfig :: ProtocolClientConfig NTFVersion defaultNTFClientConfig = - (defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange) + (defaultClientConfig (Just alpnSupportedNTFHandshakes) False supportedClientNTFVRange) {defaultTransport = ("443", transport @TLS)} {-# INLINE defaultNTFClientConfig #-} diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 73360c529..cb5203341 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -125,7 +125,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions} srvCreds <- asks tlsServerCreds serverSignKey <- either fail pure $ C.x509ToPrivate' $ snd srvCreds env <- ask - liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env + liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds tCfg $ \h -> runClient serverSignKey t h `runReaderT` env runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M () runClient signKey _ h = do diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 3709b1b2d..45f76d002 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -37,7 +37,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientCo import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore) import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore) import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore) -import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) +import Simplex.Messaging.Notifications.Transport (alpnSupportedNTFHandshakes, supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM (StartOptions (..)) @@ -48,7 +48,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (.. import Simplex.Messaging.Server.StoreLog (closeStoreLog) import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) import System.Exit (exitFailure) @@ -274,9 +274,9 @@ ntfServerCLI cfgPath logPath = prometheusMetricsFile = combine logPath "ntf-server-metrics.txt", ntfServerVRange = supportedServerNTFVRange, transportConfig = - defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini - }, + mkTransportServerConfig + (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) + (Just alpnSupportedNTFHandshakes), startOptions } iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 307c3ab4e..fb5258933 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -62,8 +62,8 @@ legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion supportedServerNTFVRange :: VersionRangeNTF supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion -supportedNTFHandshakes :: [ALPN] -supportedNTFHandshakes = ["ntf/1"] +alpnSupportedNTFHandshakes :: [ALPN] +alpnSupportedNTFHandshakes = ["ntf/1"] type THandleNTF c p = THandle NTFVersion c p diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index d203d5466..735643969 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -188,17 +188,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt env <- ask liftIO $ case (httpCreds_, attachHTTP_) of (Just httpCreds, Just attachHTTP) | addHTTP -> - runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h -> + runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds tCfg {serverALPN = Just combinedALPNs} $ \s h -> case cast h of Just (TLS {tlsContext} :: TLS 'TServer) | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext _ -> runClient srvCert srvSignKey t h `runReaderT` env where chooseCreds = maybe smpCreds (\_host -> httpCreds) - combinedALPNs = supportedSMPHandshakes <> httpALPN + combinedALPNs = alpnSupportedSMPHandshakes <> httpALPN httpALPN :: [ALPN] httpALPN = ["h2", "http/1.1"] _ -> - runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env + runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env sigIntHandlerThread :: M s () sigIntHandlerThread = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index ab2313a81..25a9123bd 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -55,9 +55,9 @@ import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCf import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) -import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy) -import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) @@ -445,9 +445,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ntfDeliveryInterval = 3000000, -- 3 seconds smpServerVRange = supportedServerSMPRelayVRange, transportConfig = - defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini - }, + mkTransportServerConfig + (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) + (Just alpnSupportedSMPHandshakes), controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini, smpAgentCfg = defaultSMPClientAgentConfig diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 35279a81e..13384ce64 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -35,7 +35,7 @@ module Simplex.Messaging.Transport VersionSMP, VersionRangeSMP, THandleSMP, - supportedSMPHandshakes, + alpnSupportedSMPHandshakes, supportedClientSMPRelayVRange, supportedServerSMPRelayVRange, supportedProxyClientSMPRelayVRange, @@ -233,8 +233,8 @@ supportedProxyClientSMPRelayVRange = mkVersionRange minServerSMPRelayVersion cur proxiedSMPRelayVRange :: VersionRangeSMP proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion -supportedSMPHandshakes :: [ALPN] -supportedSMPHandshakes = ["smp/1"] +alpnSupportedSMPHandshakes :: [ALPN] +alpnSupportedSMPHandshakes = ["smp/1"] simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 6db1122eb..fa8975cb4 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -126,7 +126,7 @@ data TransportClientConfig = TransportClientConfig tcpKeepAlive :: Maybe KeepAliveOpts, logTLSErrors :: Bool, clientCredentials :: Maybe T.Credential, - alpn :: Maybe [ALPN], + clientALPN :: Maybe [ALPN], useSNI :: Bool } deriving (Eq, Show) @@ -147,10 +147,10 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredent runTransportClient = runTLSTransportClient defaultSupportedParams Nothing runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a -runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do +runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, clientALPN, useSNI} socksCreds host port keyHash client = do serverCert <- newEmptyTMVarIO let hostName = B.unpack $ strEncode host - clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn useSNI serverCert + clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials clientALPN useSNI serverCert connectTCP = case socksProxy of Just proxy -> connectSocksClient proxy socksCreds (hostAddr host) _ -> connectTCPClient hostName diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 4be91a00a..bb3c2b3ac 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -81,7 +81,7 @@ defaultHTTP2ClientConfig = tcpKeepAlive = Nothing, logTLSErrors = True, clientCredentials = Nothing, - alpn = Nothing, + clientALPN = Nothing, useSNI = False }, bufferSize = defaultHTTP2BufferSize, diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index 12234b775..7152eb5a9 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -48,13 +48,13 @@ data HTTP2Server = HTTP2Server } -- This server is for testing only, it processes all requests in a single queue. -getHTTP2Server :: HTTP2ServerConfig -> Maybe [ALPN] -> IO HTTP2Server -getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} alpn_ = do +getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server +getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} = do srvCreds <- loadServerCredential https2Credentials started <- newEmptyTMVarIO reqQ <- newTBQueueIO qSize action <- async $ - runHTTP2Server started http2Port bufferSize serverSupported srvCreds alpn_ transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do + runHTTP2Server started http2Port bufferSize serverSupported srvCreds transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do reqBody <- getHTTP2Body r bodyHeadSize atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse} void . atomically $ takeTMVar started @@ -63,10 +63,10 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se closeHTTP2Server :: HTTP2Server -> IO () closeHTTP2Server = uninterruptibleCancel . action -runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO () -runHTTP2Server started port bufferSize srvSupported srvCreds alpn_ transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup +runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO () +runHTTP2Server started port bufferSize srvSupported srvCreds transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup where - setup = runTransportServer started port srvSupported srvCreds alpn_ transportConfig + setup = runTransportServer started port srvSupported srvCreds transportConfig -- HTTP2 server can be run on both client and server TLS connections. runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 597f8e893..4e57dac5b 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -9,7 +9,7 @@ module Simplex.Messaging.Transport.Server ( TransportServerConfig (..), ServerCredentials (..), AddHTTP, - defaultTransportServerConfig, + mkTransportServerConfig, runTransportServerState, runTransportServerState_, SocketState, @@ -58,6 +58,7 @@ import UnliftIO.STM data TransportServerConfig = TransportServerConfig { logTLSErrors :: Bool, + serverALPN :: Maybe [ALPN], tlsSetupTimeout :: Int, transportTimeout :: Int } @@ -72,10 +73,11 @@ data ServerCredentials = ServerCredentials type AddHTTP = Bool -defaultTransportServerConfig :: TransportServerConfig -defaultTransportServerConfig = +mkTransportServerConfig :: Bool -> Maybe [ALPN] ->TransportServerConfig +mkTransportServerConfig logTLSErrors serverALPN = TransportServerConfig - { logTLSErrors = True, + { logTLSErrors, + serverALPN, tlsSetupTimeout = 60000000, transportTimeout = 40000000 } @@ -88,15 +90,15 @@ serverTransportConfig TransportServerConfig {logTLSErrors} = -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar. -- -- All accepted connections are passed to the passed function. -runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO () -runTransportServer started port srvSupported srvCreds alpn_ cfg server = do +runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO () +runTransportServer started port srvSupported srvCreds cfg server = do ss <- newSocketState - runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server + runTransportServerState ss started port srvSupported srvCreds cfg server -runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO () -runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) alpn_ cfg (const server) +runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO () +runTransportServerState ss started port srvSupported srvCreds cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) cfg (const server) -runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () +runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c 'TServer)) -- | Run a transport server with provided connection setup and handler. @@ -105,11 +107,11 @@ runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg se ss <- newSocketState runTransportServerSocketState_ ss started getSocket threadLabel (const srvCreds) srvParams cfg (const server) -runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () -runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ = - runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams +runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () +runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds cfg = + runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg where - srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_ + srvParams = supportedTLSServerParams_ srvSupported srvCreds $ serverALPN cfg -- | Run a transport server with provided connection setup and handler. runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> T.Credential) -> T.ServerParams -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index 108d79170..cd61b118b 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -26,7 +26,7 @@ import qualified Network.UDP as UDP import Simplex.Messaging.Transport (TransportPeer (..), defaultSupportedParams) import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) +import Simplex.Messaging.Transport.Server (mkTransportServerConfig, runTransportServerSocket, startTCPServer) import Simplex.Messaging.Util (ifM, tshow) import Simplex.RemoteControl.Discovery.Multicast (setMembership) import Simplex.RemoteControl.Types @@ -81,7 +81,7 @@ startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ d port <- N.socketPort socket logInfo $ "System-assigned port: " <> tshow port setPort $ Just port - runTransportServerSocket started (pure socket) "RCP TLS" credentials serverParams defaultTransportServerConfig server + runTransportServerSocket started (pure socket) "RCP TLS" credentials serverParams (mkTransportServerConfig True Nothing) server setPort = void . atomically . tryPutTMVar startedOnPort serverParams = def diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 31385e4aa..56a89e4c1 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -104,7 +104,7 @@ import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), Ser import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -3196,7 +3196,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do where getClient clientId (clntAuth, clntVersion) db = let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]} - alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing + alpn_ = if clntVersion >= authCmdsSMPVersion then Just alpnSupportedSMPHandshakes else Nothing smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange minClientSMPRelayVersion clntVersion sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 1e0fe105b..46a184df0 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -165,7 +165,7 @@ smpServerTestStatic = do threadDelay 2000000 - let cfgHttp = defaultTransportClientConfig {alpn = Just ["h2"], useSNI = True} + let cfgHttp = defaultTransportClientConfig {clientALPN = Just ["h2"], useSNI = True} runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfgHttp Nothing "localhost" "5223" (Just caHTTP) $ \tls -> do tlsALPN tls `shouldBe` Just "h2" case getCerts tls of @@ -183,7 +183,7 @@ smpServerTestStatic = do -- "local" CA signing SMP credentials Fingerprint fpSMP <- loadFileFingerprint (cfgPath <> "/ca.crt") let caSMP = C.KeyHash fpSMP - let cfgSmp = defaultTransportClientConfig {alpn = Just ["smp/1"], useSNI = False} + let cfgSmp = defaultTransportClientConfig {clientALPN = Just ["smp/1"], useSNI = False} runTLSTransportClient defaultSupportedParams Nothing cfgSmp Nothing "localhost" "5223" (Just caSMP) $ \tls -> do tlsALPN tls `shouldBe` Just "smp/1" case getCerts tls of diff --git a/tests/CoreTests/SOCKSSettings.hs b/tests/CoreTests/SOCKSSettings.hs index 931315cc7..2c8e4454c 100644 --- a/tests/CoreTests/SOCKSSettings.hs +++ b/tests/CoreTests/SOCKSSettings.hs @@ -91,7 +91,7 @@ testSocksMode = do where transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode} transportSocksCfg cfg host = - let TransportClientConfig {socksProxy} = transportClientConfig cfg host False + let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing in socksProxy testSocksProxyEncoding :: Spec diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 76cf8f9d8..bb5af9722 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -159,7 +159,7 @@ ntfServerCfg = prometheusInterval = Nothing, prometheusMetricsFile = ntfTestPrometheusMetricsFile, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig, + transportConfig = mkTransportServerConfig True $ Just alpnSupportedNTFHandshakes, startOptions = defaultStartOptions } @@ -242,7 +242,7 @@ apnsMockServerConfig = privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt" }, - transportConfig = defaultTransportServerConfig + transportConfig = mkTransportServerConfig True Nothing } withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO () @@ -273,7 +273,7 @@ deriving instance ToJSON APNSErrorResponse getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer getAPNSMockServer config@HTTP2ServerConfig {qSize} = do - http2Server <- getHTTP2Server config Nothing + http2Server <- getHTTP2Server config notifications <- TM.emptyIO action <- async $ runAPNSMockServer notifications http2Server pure APNSMockServer {action, notifications, http2Server} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 3cae010a1..276fe0388 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -11,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module SMPClient where @@ -31,7 +32,6 @@ import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client -import qualified Simplex.Messaging.Transport.Client as Client import Simplex.Messaging.Transport.Server import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal @@ -158,14 +158,14 @@ testSMPClientVR vr client = do testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a testSMPClient_ host port vr client = do - let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN} + let tcConfig = defaultTransportClientConfig {clientALPN} :: TransportClientConfig runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h -> runExceptT (smpClientHandshake h Nothing testKeyHash vr False) >>= \case Right th -> client th Left e -> error $ show e where clientALPN - | authCmdsSMPVersion `isCompatible` vr = Just supportedSMPHandshakes + | authCmdsSMPVersion `isCompatible` vr = Just alpnSupportedSMPHandshakes | otherwise = Nothing cfg :: AServerConfig @@ -226,7 +226,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> }, httpCredentials = Nothing, smpServerVRange = supportedServerSMPRelayVRange, - transportConfig = defaultTransportServerConfig, + transportConfig = mkTransportServerConfig True $ Just alpnSupportedSMPHandshakes, controlPort = Nothing, smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds allowSMPProxy = False, diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index ab8b9d6f6..53985715d 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module XFTPAgent where @@ -26,7 +27,7 @@ import Simplex.FileTransfer.Client (XFTPClientConfig (..)) import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription) import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) -import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH), supportedXFTPhandshakes) +import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) @@ -38,7 +39,6 @@ import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) -import Simplex.Messaging.Transport (ALPN) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) import System.FilePath (()) @@ -269,11 +269,11 @@ testXFTPAgentSendReceiveMatrix = do where oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}} newClient = agentCfg - oldServer = Nothing - newServer = Just supportedXFTPhandshakes - run :: HasCallStack => Maybe [ALPN] -> AgentConfig -> AgentConfig -> IO () - run alpn sender receiver = - withXFTPServerCfgALPN testXFTPServerConfig alpn $ \_t -> do + oldServer = withXFTPServerCfgNoALPN + newServer = withXFTPServerCfg + run :: HasCallStack => (HasCallStack => XFTPServerConfig -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO () + run withServer sender receiver = + withServer testXFTPServerConfig $ \_t -> do filePath <- createRandomFile_ (kb 319 :: Integer) "testfile" rfd <- withAgent 1 sender initAgentServers testDB $ \sndr -> do (sfId, _, rfd1, _) <- runRight $ testSendCF' sndr (CF.plain filePath) (kb 320) diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index be6558125..8533d5a69 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -15,9 +15,8 @@ import Simplex.FileTransfer.Client import Simplex.FileTransfer.Description import Simplex.FileTransfer.Server (runXFTPServerBlocking) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration) -import Simplex.FileTransfer.Transport (supportedFileServerVRange, supportedXFTPhandshakes) +import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes) import Simplex.Messaging.Protocol (XFTPServer) -import Simplex.Messaging.Transport (ALPN) import Simplex.Messaging.Transport.Server import Test.Hspec hiding (fit, it) @@ -52,13 +51,13 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients [] withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile} -withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a -withXFTPServerCfg cfg = withXFTPServerCfgALPN cfg $ Just supportedXFTPhandshakes +withXFTPServerCfgNoALPN :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}} -withXFTPServerCfgALPN :: HasCallStack => XFTPServerConfig -> Maybe [ALPN] -> (HasCallStack => ThreadId -> IO a) -> IO a -withXFTPServerCfgALPN cfg alpn_ = +withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerCfg cfg = serverBracket - (\started -> runXFTPServerBlocking started cfg alpn_) + (\started -> runXFTPServerBlocking started cfg) (threadDelay 10000) withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a @@ -128,7 +127,7 @@ testXFTPServerConfig = logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, - transportConfig = defaultTransportServerConfig, + transportConfig = mkTransportServerConfig True $ Just alpnSupportedXFTPhandshakes, responseDelay = 0 }