diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index fde24f8be..f2240ec50 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -53,7 +53,7 @@ import Simplex.Messaging.Protocol SenderId, pattern NoEntity, ) -import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) +import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client @@ -173,7 +173,7 @@ xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfi xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = defaultHTTP2ClientConfig { bodyHeadSize = xftpBlockSize, - suportedTLSParams = supportedParameters, + suportedTLSParams = defaultSupportedParams, connTimeout = tcpConnectTimeout, transportConfig } diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 434fcde4d..24ad4815e 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -60,12 +60,12 @@ import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemT import Simplex.Messaging.Server.Stats import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..)) +import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) import Simplex.Messaging.Transport.HTTP2.Server -import Simplex.Messaging.Transport.Server (runLocalTCPServer, tlsServerCredentials) +import Simplex.Messaging.Transport.Server (runLocalTCPServer) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Exit (exitFailure) @@ -91,32 +91,31 @@ data XFTPTransportRequest = XFTPTransportRequest runXFTPServer :: XFTPServerConfig -> IO () runXFTPServer cfg = do started <- newEmptyTMVarIO - runXFTPServerBlocking started cfg + runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes -runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO () -runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) +runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO () +runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_) data Handshake = HandshakeSent C.PrivateKeyX25519 | HandshakeAccepted (THandleParams XFTPVersion 'TServer) -xftpServer :: XFTPServerConfig -> TMVar Bool -> M () -xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do +xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M () +xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do mapM_ (expireServerFiles Nothing) fileExpiration restoreServerStats raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer where runServer :: M () runServer = do - serverParams <- asks tlsServerParams - let (chain, pk) = tlsServerCredentials serverParams + srvCreds@(chain, pk) <- asks tlsServerCreds signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of Right pk' -> pure pk' Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure env <- ask sessions <- liftIO TM.emptyIO let cleanup sessionId = atomically $ TM.delete sessionId sessions - liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do + liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ 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/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 1fa399a2a..c967d834c 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -29,7 +29,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (ALPN) -import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential) import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) import UnliftIO.STM @@ -57,10 +57,7 @@ data XFTPServerConfig = XFTPServerConfig fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds inactiveClientExpiration :: Maybe ExpirationConfig, - -- CA certificate private key is not needed for initialization - caCertificateFile :: FilePath, - privateKeyFile :: FilePath, - certificateFile :: FilePath, + xftpCredentials :: ServerCredentials, -- | XFTP client-server protocol version range xftpServerVRange :: VersionRangeXFTP, -- stats config - see SMP server config @@ -85,7 +82,7 @@ data XFTPEnv = XFTPEnv storeLog :: Maybe (StoreLog 'WriteMode), random :: TVar ChaChaDRG, serverIdentity :: C.KeyHash, - tlsServerParams :: T.ServerParams, + tlsServerCreds :: T.Credential, serverStats :: FileServerStats } @@ -103,7 +100,7 @@ supportedXFTPhandshakes :: [ALPN] supportedXFTPhandshakes = ["xftp/1"] newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv -newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do +newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do random <- C.newRandom store <- newFileStore storeLog <- mapM (`readWriteFileStore` store) storeLogFile @@ -112,10 +109,10 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi forM_ fileSizeQuota $ \quota -> do logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used) when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!" - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) - Fingerprint fp <- loadFingerprint caCertificateFile + tlsServerCreds <- loadServerCredential xftpCredentials + Fingerprint fp <- loadFingerprint xftpCredentials serverStats <- newFileServerStats =<< getCurrentTime - pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} + pure XFTPEnv {config, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} countUsedStorage :: M.Map k FileRec -> Int64 countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0 diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 76b1f157a..1f9246b1c 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -19,7 +19,7 @@ import Options.Applicative import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration) import Simplex.FileTransfer.Transport (supportedFileServerVRange) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -28,7 +28,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 (TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) @@ -173,9 +173,12 @@ xftpServerCLI cfgPath logPath = do { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini, checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini }, - caCertificateFile = c caCrtFile, - privateKeyFile = c serverKeyFile, - certificateFile = c serverCrtFile, + xftpCredentials = + ServerCredentials + { caCertificateFile = Just $ c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile + }, xftpServerVRange = supportedFileServerVRange, logStatsInterval = logStats $> 86400, -- seconds logStatsStartTime = 0, -- seconds from 00:00 UTC @@ -183,8 +186,7 @@ xftpServerCLI cfgPath logPath = do serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log", transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, - alpn = Just supportedXFTPhandshakes + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini }, responseDelay = 0 } diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 2c964f9bf..8b5f2274b 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -50,8 +50,8 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..)) -import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials) +import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) +import Simplex.Messaging.Transport.Server (runTransportServer) import Simplex.Messaging.Util import System.Exit (exitFailure) import System.IO (BufferMode (..), hPutStrLn, hSetBuffering) @@ -82,10 +82,10 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do where runServer :: (ServiceName, ATransport) -> M () runServer (tcpPort, ATransport t) = do - serverParams <- asks tlsServerParams - serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams + srvCreds <- asks tlsServerCreds + serverSignKey <- either fail pure $ fromTLSCredentials srvCreds env <- ask - liftIO $ runTransportServer started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env + liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index dc0cb0a73..e99adc884 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -33,7 +33,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..)) -import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Transport.Server (ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -50,10 +50,7 @@ data NtfServerConfig = NtfServerConfig subsBatchSize :: Int, inactiveClientExpiration :: Maybe ExpirationConfig, storeLogFile :: Maybe FilePath, - -- CA certificate private key is not needed for initialization - caCertificateFile :: FilePath, - privateKeyFile :: FilePath, - certificateFile :: FilePath, + ntfCredentials :: ServerCredentials, -- stats config - see SMP server config logStatsInterval :: Maybe Int64, logStatsStartTime :: Int64, @@ -77,13 +74,13 @@ data NtfEnv = NtfEnv store :: NtfStore, storeLog :: Maybe (StoreLog 'WriteMode), random :: TVar ChaChaDRG, - tlsServerParams :: T.ServerParams, + tlsServerCreds :: T.Credential, serverIdentity :: C.KeyHash, serverStats :: NtfServerStats } newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do random <- C.newRandom store <- newNtfStore logInfo "restoring subscriptions..." @@ -91,10 +88,10 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo logInfo "restored subscriptions" subscriber <- newNtfSubscriber subQSize smpAgentCfg random pushServer <- newNtfPushServer pushQSize apnsConfig - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) - Fingerprint fp <- loadFingerprint caCertificateFile + tlsServerCreds <- loadServerCredential ntfCredentials + Fingerprint fp <- loadFingerprint ntfCredentials serverStats <- newNtfServerStats =<< getCurrentTime - pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} + pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} data NtfSubscriber = NtfSubscriber { smpSubscribers :: TMap SMPServer SMPSubscriber, diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index d29c88c1e..16f8e430f 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Notifications.Server.Main where @@ -22,13 +23,13 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) -import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange) +import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) 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 (TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) @@ -156,9 +157,12 @@ ntfServerCLI cfgPath logPath = checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini }, storeLogFile = enableStoreLog $> storeLogFilePath, - caCertificateFile = c caCrtFile, - privateKeyFile = c serverKeyFile, - certificateFile = c serverCrtFile, + ntfCredentials = + ServerCredentials + { caCertificateFile = Just $ c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile + }, logStatsInterval = logStats $> 86400, -- seconds logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", @@ -166,8 +170,7 @@ ntfServerCLI cfgPath logPath = ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, - alpn = Just supportedNTFHandshakes + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini } } diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 599938ab6..5a5ae12fd 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -146,11 +146,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do where runServer :: (ServiceName, ATransport) -> M () runServer (tcpPort, ATransport t) = do - serverParams <- asks tlsServerParams + srvCreds <- asks tlsServerCreds ss <- asks sockets - serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams + serverSignKey <- either fail pure $ fromTLSCredentials srvCreds env <- ask - liftIO $ runTransportServerState ss started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env + liftIO $ runTransportServerState ss started tcpPort defaultSupportedParams srvCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey saveServer :: Bool -> M () diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 0ae228496..f02612274 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -29,7 +29,7 @@ import Options.Applicative import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) -import Simplex.Messaging.Transport.Server (loadFingerprint) +import Simplex.Messaging.Transport.Server (loadFileFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) import Simplex.Messaging.Util (eitherToMaybe, whenM) import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly) @@ -139,7 +139,7 @@ createServerX509_ createCA cfgPath x509cfg = do ) saveFingerprint = do - Fingerprint fp <- loadFingerprint $ c caCrtFile + Fingerprint fp <- loadFileFingerprint $ c caCrtFile withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp) pure fp @@ -268,7 +268,7 @@ settingIsOn section name ini checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString checkSavedFingerprint cfgPath x509cfg = do savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine - Fingerprint fp <- loadFingerprint (c caCrtFile) + Fingerprint fp <- loadFileFingerprint (c caCrtFile) when (B.pack savedFingerprint /= strEncode fp) $ exitError "Stored fingerprint is invalid." pure fp diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 9413ef24e..214cecd19 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -41,7 +41,7 @@ import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP) -import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState) +import Simplex.Messaging.Transport.Server (ServerCredentials, SocketState, TransportServerConfig, loadFingerprint, loadServerCredential, newSocketState) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -78,10 +78,7 @@ data ServerConfig = ServerConfig serverStatsBackupFile :: Maybe FilePath, -- | interval between sending pending END events to unsubscribed clients, seconds pendingENDInterval :: Int, - -- | CA certificate private key is not needed for initialization - caCertificateFile :: FilePath, - privateKeyFile :: FilePath, - certificateFile :: FilePath, + smpCredentials :: ServerCredentials, -- | SMP client-server protocol version range smpServerVRange :: VersionRangeSMP, -- | TCP transport config @@ -125,7 +122,7 @@ data Env = Env msgStore :: STMMsgStore, random :: TVar ChaChaDRG, storeLog :: Maybe (StoreLog 'WriteMode), - tlsServerParams :: T.ServerParams, + tlsServerCreds :: T.Credential, serverStats :: ServerStats, sockets :: SocketState, clientSeq :: TVar ClientId, @@ -220,7 +217,7 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do +newEnv config@ServerConfig {smpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do server <- newServer queueStore <- newQueueStore msgStore <- newMsgStore @@ -229,15 +226,15 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, forM storeLogFile $ \f -> do logInfo $ "restoring queues from file " <> T.pack f restoreQueues queueStore f - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) - Fingerprint fp <- loadFingerprint caCertificateFile + tlsServerCreds <- loadServerCredential smpCredentials + Fingerprint fp <- loadFingerprint smpCredentials let serverIdentity = KeyHash fp serverStats <- newServerStats =<< getCurrentTime sockets <- newSocketState clientSeq <- newTVarIO 0 clients <- newTVarIO mempty proxyAgent <- newSMPProxyAgent smpAgentCfg random - pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent} + pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent} where restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode) restoreQueues QueueStore {queues, senders, notifiers} f = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index a5106c125..6cee2abd1 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Server.Main where @@ -40,9 +41,9 @@ import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information -import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow) import Simplex.Messaging.Version (mkVersionRange) import System.Directory (createDirectoryIfMissing, doesFileExist) @@ -260,9 +261,12 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = msgQueueQuota = 128, queueIdBytes = 24, msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 - caCertificateFile = c caCrtFile, - privateKeyFile = c serverKeyFile, - certificateFile = c serverCrtFile, + smpCredentials = + ServerCredentials + { caCertificateFile = Just $ c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile + }, storeLogFile = enableStoreLog $> storeLogFilePath, storeMsgsFile = let messagesPath = combine logPath "smp-server-messages.log" @@ -295,8 +299,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, - alpn = Just supportedSMPHandshakes + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini }, controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini, smpAgentCfg = diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index bc7cc85dd..0a005f046 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -65,7 +65,7 @@ module Simplex.Messaging.Transport ALPN, connectTLS, closeTLS, - supportedParameters, + defaultSupportedParams, withTlsUnique, -- * SMP transport @@ -312,8 +312,8 @@ closeTLS ctx = `E.finally` T.contextClose ctx `catchAll_` pure () -supportedParameters :: T.Supported -supportedParameters = +defaultSupportedParams :: T.Supported +defaultSupportedParams = def { T.supportedVersions = [T.TLS13, T.TLS12], T.supportedCiphers = diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index a23c68dd7..3b80b7f73 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -142,7 +142,7 @@ clientTransportConfig TransportClientConfig {logTLSErrors} = -- | Connect to passed TCP host:port and pass handle to the client. runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a -runTransportClient = runTLSTransportClient supportedParameters Nothing +runTransportClient = runTLSTransportClient defaultSupportedParams Nothing runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} socksCreds host port keyHash client = do diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs index 90089f9ef..3c82b2f78 100644 --- a/src/Simplex/Messaging/Transport/Credentials.hs +++ b/src/Simplex/Messaging/Transport/Credentials.hs @@ -32,8 +32,8 @@ import qualified Time.System as Hourglass -- leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert -- pure $ tlsCredentials (leaf :| [ca]) -- @ -tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials) -tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)]) +tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential) +tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey)) where Fingerprint rootFP = getFingerprint root X509.HashSHA256 leafKey = fst $ L.head credentials diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index f8ea1bd1d..7dbed97ef 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -15,7 +15,7 @@ import Numeric.Natural (Natural) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq) import Simplex.Messaging.Transport.HTTP2 -import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer) +import Simplex.Messaging.Transport.Server (ServerCredentials, TransportServerConfig (..), loadServerCredential, runTransportServer) import Simplex.Messaging.Util (threadDelay') import UnliftIO (finally) import UnliftIO.Concurrent (forkIO, killThread) @@ -28,9 +28,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig bufferSize :: BufferSize, bodyHeadSize :: Int, serverSupported :: T.Supported, - caCertificateFile :: FilePath, - privateKeyFile :: FilePath, - certificateFile :: FilePath, + https2Credentials :: ServerCredentials, transportConfig :: TransportServerConfig } deriving (Show) @@ -49,13 +47,13 @@ data HTTP2Server = HTTP2Server } -- This server is for testing only, it processes all requests in a single queue. -getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server -getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do - tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig) +getHTTP2Server :: HTTP2ServerConfig -> Maybe [ALPN] -> IO HTTP2Server +getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} alpn_ = do + srvCreds <- loadServerCredential https2Credentials started <- newEmptyTMVarIO reqQ <- newTBQueueIO qSize action <- async $ - runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do + runHTTP2Server started http2Port bufferSize serverSupported srvCreds alpn_ 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 @@ -64,10 +62,10 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se closeHTTP2Server :: HTTP2Server -> IO () closeHTTP2Server = uninterruptibleCancel . action -runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO () -runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup +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 where - setup = runTransportServer started port serverParams transportConfig + setup = runTransportServer started port srvSupported srvCreds alpn_ transportConfig runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ()) diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 28d4d354d..5c3be519c 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -6,6 +6,7 @@ module Simplex.Messaging.Transport.Server ( TransportServerConfig (..), + ServerCredentials (..), defaultTransportServerConfig, runTransportServerState, SocketState, @@ -15,11 +16,12 @@ module Simplex.Messaging.Transport.Server runLocalTCPServer, runTCPServerSocket, startTCPServer, - loadSupportedTLSServerParams, - loadTLSServerParams, + loadServerCredential, + supportedTLSServerParams, + supportedTLSServerParams_, loadFingerprint, + loadFileFingerprint, smpServerHandshake, - tlsServerCredentials, ) where @@ -31,7 +33,7 @@ import Data.Default (def) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM import Data.List (find) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, maybeToList) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) import qualified Data.X509.Validation as XV @@ -52,18 +54,23 @@ import UnliftIO.STM data TransportServerConfig = TransportServerConfig { logTLSErrors :: Bool, tlsSetupTimeout :: Int, - transportTimeout :: Int, - alpn :: Maybe [ALPN] + transportTimeout :: Int } deriving (Eq, Show) +data ServerCredentials = ServerCredentials + { caCertificateFile :: Maybe FilePath, -- CA certificate private key is not needed for initialization + privateKeyFile :: FilePath, + certificateFile :: FilePath + } + deriving (Show) + defaultTransportServerConfig :: TransportServerConfig defaultTransportServerConfig = TransportServerConfig { logTLSErrors = True, tlsSetupTimeout = 60000000, - transportTimeout = 40000000, - alpn = Nothing + transportTimeout = 40000000 } serverTransportConfig :: TransportServerConfig -> TransportConfig @@ -74,23 +81,29 @@ 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.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO () -runTransportServer started port params cfg server = do +runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO () +runTransportServer started port srvSupported srvCreds alpn_ cfg server = do ss <- newSocketState - runTransportServerState ss started port params cfg server + runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server -runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO () +runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO () runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c)) -- | Run a transport server with provided connection setup and handler. -runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO () -runTransportServerSocket started getSocket threadLabel serverParams cfg server = do +runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO () +runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg server = do ss <- newSocketState - runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server + runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server + +runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (X.CertificateChain, X.PrivKey) -> Maybe [ALPN] -> TransportServerConfig -> (a -> IO ()) -> IO () +runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ = + runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams + where + srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_ -- | Run a transport server with provided connection setup and handler. -runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO () -runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do +runTransportServerSocketState_ :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> (X.CertificateChain, X.PrivKey) -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO () +runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do labelMyThread $ "transport server for " <> threadLabel runTCPServerSocket ss started getSocket $ \conn -> E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection server @@ -98,13 +111,8 @@ runTransportServerSocketState ss started getSocket threadLabel serverParams cfg tCfg = serverTransportConfig cfg setup conn = timeout (tlsSetupTimeout cfg) $ do labelMyThread $ threadLabel <> "/setup" - tls <- connectTLS Nothing tCfg serverParams conn - getServerConnection tCfg (fst $ tlsServerCredentials serverParams) tls - -tlsServerCredentials :: T.ServerParams -> (X.CertificateChain, X.PrivKey) -tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared serverParams of - T.Credentials [creds] -> creds - _ -> error "server has more than one key" + tls <- connectTLS Nothing tCfg srvParams conn + getServerConnection tCfg (fst srvCreds) tls -- | Run TCP server without TLS runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO () @@ -176,30 +184,33 @@ startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStart pure sock setStarted sock = atomically (tryPutTMVar started True) >> pure sock -loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams -loadTLSServerParams = loadSupportedTLSServerParams supportedParameters +loadServerCredential :: ServerCredentials -> IO T.Credential +loadServerCredential ServerCredentials {caCertificateFile, certificateFile, privateKeyFile} = + T.credentialLoadX509Chain certificateFile (maybeToList caCertificateFile) privateKeyFile >>= \case + Right credential -> pure credential + Left _ -> putStrLn "invalid credential" >> exitFailure -loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams -loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile alpn_ = do - tlsServerParams <- fromCredential <$> loadServerCredential - pure tlsServerParams {T.serverHooks = maybe def alpnHooks alpn_} - where - loadServerCredential :: IO T.Credential - loadServerCredential = - T.credentialLoadX509Chain certificateFile [caCertificateFile] privateKeyFile >>= \case - Right credential -> pure credential - Left _ -> putStrLn "invalid credential" >> exitFailure - fromCredential :: T.Credential -> T.ServerParams - fromCredential credential = - def - { T.serverWantClientCert = False, - T.serverShared = def {T.sharedCredentials = T.Credentials [credential]}, - T.serverHooks = def, - T.serverSupported = serverSupported - } - alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)} +supportedTLSServerParams :: T.Credential -> Maybe [ALPN] -> T.ServerParams +supportedTLSServerParams = supportedTLSServerParams_ defaultSupportedParams -loadFingerprint :: FilePath -> IO Fingerprint -loadFingerprint certificateFile = do +supportedTLSServerParams_ :: T.Supported -> T.Credential -> Maybe [ALPN] -> T.ServerParams +supportedTLSServerParams_ serverSupported credential alpn_ = + def + { T.serverWantClientCert = False, + T.serverHooks = + def + { T.onServerNameIndication = \_ -> pure $ T.Credentials [credential], + T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_ + }, + T.serverSupported = serverSupported + } + +loadFingerprint :: ServerCredentials -> IO Fingerprint +loadFingerprint ServerCredentials {caCertificateFile} = case caCertificateFile of + Just certificateFile -> loadFileFingerprint certificateFile + Nothing -> error "CA file must be used in protocol credentials" + +loadFileFingerprint :: FilePath -> IO Fingerprint +loadFileFingerprint certificateFile = do (cert : _) <- SX.readSignedObject certificateFile pure $ XV.getFingerprint (cert :: X.SignedExact X.Certificate) X.HashSHA256 diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 1c0ef94cc..acb86602c 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -190,7 +190,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct } pure $ signInvitation (snd sessKeys) idPrivKey inv -genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials +genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credential genTLSCredentials drg caKey caCert = do let caCreds = (C.signatureKeyPair caKey, caCert) leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert @@ -282,10 +282,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, pure RCCClient_ {confirmSession, endSession} runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () runClient RCCClient_ {confirmSession, endSession} r = do - clientCredentials <- - liftIO (genTLSCredentials drg caKey caCert) >>= \case - TLS.Credentials (creds : _) -> pure $ Just creds - _ -> throwE $ RCEInternal "genTLSCredentials must generate credentials" + clientCredentials <- liftIO $ Just <$> genTLSCredentials drg caKey caCert let clientConfig = defaultTransportClientConfig {clientCredentials} ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do -- pump socket to detect connection problems diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index 8ee76c651..d0a326bba 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -23,7 +23,7 @@ import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces) import qualified Network.Socket as N import qualified Network.TLS as TLS import qualified Network.UDP as UDP -import Simplex.Messaging.Transport (supportedParameters) +import Simplex.Messaging.Transport (defaultSupportedParams) import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) @@ -68,7 +68,7 @@ preferAddress RCCtrlAddress {address, interface} addrs = matchAddr RCCtrlAddress {address = a} = a == address matchIface RCCtrlAddress {interface = i} = i == interface -startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ()) +startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ()) startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do started <- newEmptyTMVarIO bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket -> @@ -81,14 +81,14 @@ 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" serverParams defaultTransportServerConfig server + runTransportServerSocket started (pure socket) "RCP TLS" credentials serverParams defaultTransportServerConfig server setPort = void . atomically . tryPutTMVar startedOnPort serverParams = def { TLS.serverWantClientCert = True, - TLS.serverShared = def {TLS.sharedCredentials = credentials}, + TLS.serverShared = def {TLS.sharedCredentials = TLS.Credentials [credentials]}, TLS.serverHooks = hooks, - TLS.serverSupported = supportedParameters + TLS.serverSupported = defaultSupportedParams } withSender :: (UDP.UDPSocket -> IO a) -> IO a diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index c263bc016..accaa4d37 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -45,7 +45,6 @@ import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server -import qualified Simplex.Messaging.Transport.Server as Server import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -96,17 +95,19 @@ ntfServerCfg = subsBatchSize = 900, inactiveClientExpiration = Just defaultInactiveClientExpiration, storeLogFile = Nothing, - -- CA certificate private key is not needed for initialization - caCertificateFile = "tests/fixtures/ca.crt", - privateKeyFile = "tests/fixtures/server.key", - certificateFile = "tests/fixtures/server.crt", + ntfCredentials = + ServerCredentials + { caCertificateFile = Just "tests/fixtures/ca.crt", + privateKeyFile = "tests/fixtures/server.key", + certificateFile = "tests/fixtures/server.crt" + }, -- stats config logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} + transportConfig = defaultTransportServerConfig } ntfServerCfgVPrev :: NtfServerConfig @@ -185,9 +186,12 @@ apnsMockServerConfig = bufferSize = 16384, bodyHeadSize = 16384, serverSupported = http2TLSParams, - caCertificateFile = "tests/fixtures/ca.crt", - privateKeyFile = "tests/fixtures/server.key", - certificateFile = "tests/fixtures/server.crt", + https2Credentials = + ServerCredentials + { caCertificateFile = Just "tests/fixtures/ca.crt", + privateKeyFile = "tests/fixtures/server.key", + certificateFile = "tests/fixtures/server.crt" + }, transportConfig = defaultTransportServerConfig } @@ -219,7 +223,7 @@ deriving instance ToJSON APNSErrorResponse getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer getAPNSMockServer config@HTTP2ServerConfig {qSize} = do - http2Server <- getHTTP2Server config + http2Server <- getHTTP2Server config Nothing apnsQ <- newTBQueueIO qSize action <- async $ runAPNSMockServer apnsQ http2Server pure APNSMockServer {action, apnsQ, http2Server} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 472f9b6b4..2cf92640f 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -27,7 +27,6 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client import Simplex.Messaging.Transport.Server -import qualified Simplex.Messaging.Transport.Server as Server import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import System.Environment (lookupEnv) @@ -116,11 +115,14 @@ cfg = serverStatsLogFile = "tests/smp-server-stats.daily.log", serverStatsBackupFile = Nothing, pendingENDInterval = 500000, - caCertificateFile = "tests/fixtures/ca.crt", - privateKeyFile = "tests/fixtures/server.key", - certificateFile = "tests/fixtures/server.crt", + smpCredentials = + ServerCredentials + { caCertificateFile = Just "tests/fixtures/ca.crt", + privateKeyFile = "tests/fixtures/server.key", + certificateFile = "tests/fixtures/server.crt" + }, smpServerVRange = supportedServerSMPRelayVRange, - transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes}, + transportConfig = defaultTransportServerConfig, controlPort = Nothing, smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds allowSMPProxy = False, diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 9803cb8b9..a425e1bdb 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -24,7 +24,7 @@ import SMPClient (xit'') 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.Server.Env (XFTPServerConfig (..), 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) @@ -37,6 +37,7 @@ 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 (()) @@ -257,11 +258,11 @@ testXFTPAgentSendReceiveMatrix = do where oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}} newClient = agentCfg - oldServer = testXFTPServerConfig_ Nothing - newServer = testXFTPServerConfig - run :: HasCallStack => XFTPServerConfig -> AgentConfig -> AgentConfig -> IO () - run server sender receiver = - withXFTPServerCfg server $ \_t -> do + oldServer = Nothing + newServer = Just supportedXFTPhandshakes + run :: HasCallStack => Maybe [ALPN] -> AgentConfig -> AgentConfig -> IO () + run alpn sender receiver = + withXFTPServerCfgALPN testXFTPServerConfig alpn $ \_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 398b6cd9f..bd7b23568 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -53,9 +53,12 @@ withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) - withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile} withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a -withXFTPServerCfg cfg = +withXFTPServerCfg cfg = withXFTPServerCfgALPN cfg $ Just supportedXFTPhandshakes + +withXFTPServerCfgALPN :: HasCallStack => XFTPServerConfig -> Maybe [ALPN] -> (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerCfgALPN cfg alpn_ = serverBracket - (`runXFTPServerBlocking` cfg) + (\started -> runXFTPServerBlocking started cfg alpn_) (threadDelay 10000) withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a @@ -98,10 +101,7 @@ testXFTPStatsBackupFile :: FilePath testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log" testXFTPServerConfig :: XFTPServerConfig -testXFTPServerConfig = testXFTPServerConfig_ (Just supportedXFTPhandshakes) - -testXFTPServerConfig_ :: Maybe [ALPN] -> XFTPServerConfig -testXFTPServerConfig_ alpn = +testXFTPServerConfig = XFTPServerConfig { xftpPort = xftpTestPort, controlPort = Nothing, @@ -117,15 +117,18 @@ testXFTPServerConfig_ alpn = fileExpiration = Just defaultFileExpiration, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, - caCertificateFile = "tests/fixtures/ca.crt", - privateKeyFile = "tests/fixtures/server.key", - certificateFile = "tests/fixtures/server.crt", + xftpCredentials = + ServerCredentials + { caCertificateFile = Just "tests/fixtures/ca.crt", + privateKeyFile = "tests/fixtures/server.key", + certificateFile = "tests/fixtures/server.crt" + }, xftpServerVRange = supportedFileServerVRange, logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, - transportConfig = defaultTransportServerConfig {alpn}, + transportConfig = defaultTransportServerConfig, responseDelay = 0 }