mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-23 19:32:26 +00:00
servers: include supported ALPNs in server transport config (#1557)
This commit is contained in:
Evgeny authored and GitHub committed
1 parent
90e8c3adf6
commit
8e86c97a13
24 files changed
+98
-97
No files matched your search
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 #-}
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -81,7 +81,7 @@ defaultHTTP2ClientConfig =
|
||||
tcpKeepAlive = Nothing,
|
||||
logTLSErrors = True,
|
||||
clientCredentials = Nothing,
|
||||
alpn = Nothing,
|
||||
clientALPN = Nothing,
|
||||
useSNI = False
|
||||
},
|
||||
bufferSize = defaultHTTP2BufferSize,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+2
-2
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+3
-3
@@ -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}
|
||||
|
||||
+4
-4
@@ -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,
|
||||
|
||||
+7
-7
@@ -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)
|
||||
|
||||
+7
-8
@@ -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
|
||||
}
|
||||
|
||||
|
||||
Reference in new issue
Block a user