diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index b7f60c9af..414bfb4c4 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -13,12 +13,9 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.IO.Unlift import Crypto.Random -import Data.Default (def) import Data.Int (Int64) -import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) import Data.Time.Clock (getCurrentTime) import Data.Word (Word32) import Data.X509.Validation (Fingerprint (..)) @@ -103,7 +100,7 @@ supportedXFTPhandshakes :: [ALPN] supportedXFTPhandshakes = ["xftp/1"] newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv -newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do +newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do random <- liftIO C.newRandom store <- atomically newFileStore storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile @@ -112,17 +109,7 @@ 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' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile - let TransportServerConfig {alpn} = transportConfig config - let tlsServerParams = case alpn of - Nothing -> tlsServerParams' - Just supported -> - tlsServerParams' - { T.serverHooks = - def - { T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported) - } - } + tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs index 368c0a23d..da87fde11 100644 --- a/src/Simplex/Messaging/Agent/Server.hs +++ b/src/Simplex/Messaging/Agent/Server.hs @@ -49,7 +49,7 @@ runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO () smpAgent _ port env = do -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile + tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile Nothing clientId <- newTVarIO initClientId runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 38c36f9f2..176602f4b 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -260,6 +260,7 @@ data ProtocolClientConfig v = ProtocolClientConfig defaultTransport :: (ServiceName, ATransport), -- | network configuration networkConfig :: NetworkConfig, + clientALPN :: Maybe [ALPN], -- | client-server protocol version range serverVRange :: VersionRange v, -- | agree shared session secret (used in SMP proxy) @@ -267,19 +268,20 @@ data ProtocolClientConfig v = ProtocolClientConfig } -- | Default protocol client configuration. -defaultClientConfig :: VersionRange v -> ProtocolClientConfig v -defaultClientConfig serverVRange = +defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v +defaultClientConfig clientALPN serverVRange = ProtocolClientConfig { qSize = 64, defaultTransport = ("443", transport @TLS), networkConfig = defaultNetworkConfig, + clientALPN, serverVRange, agreeSecret = False } {-# INLINE defaultClientConfig #-} defaultSMPClientConfig :: ProtocolClientConfig SMPVersion -defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange +defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange {-# INLINE defaultSMPClientConfig #-} data Request err msg = Request @@ -332,7 +334,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, agreeSecret} msgQ disconnected = do +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost) @@ -370,7 +372,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize runClient :: (ServiceName, ATransport) -> 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 + let tcConfig = (transportClientConfig networkConfig) {alpn = clientALPN} username = proxyUsername transportSession action <- async $ diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index 72a92c278..cc698b344 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -10,7 +10,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) +import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes) import Simplex.Messaging.Protocol (ErrorType) import Simplex.Messaging.Util (bshow) @@ -19,7 +19,7 @@ type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse type NtfClientError = ProtocolClientError ErrorType defaultNTFClientConfig :: ProtocolClientConfig NTFVersion -defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange +defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) ntfRegisterToken c pKey newTkn = diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 5bcd72f3d..5ebd5230e 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -34,7 +34,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, loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -84,7 +84,7 @@ data NtfEnv = NtfEnv } newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do random <- liftIO C.newRandom store <- atomically newNtfStore logInfo "restoring subscriptions..." @@ -92,7 +92,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo logInfo "restored subscriptions" subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig - tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile + tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index a8d16d85d..0efb7d599 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -18,7 +18,7 @@ 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 (supportedServerNTFVRange) +import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration @@ -133,7 +133,8 @@ ntfServerCLI cfgPath logPath = ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, + alpn = Just supportedNTFHandshakes } } diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index e2c287437..342b42fc4 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -52,9 +52,15 @@ currentServerNTFVersion = VersionNTF 2 supportedClientNTFVRange :: VersionRangeNTF supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion +legacyServerNTFVRange :: VersionRangeNTF +legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion + supportedServerNTFVRange :: VersionRangeNTF supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion +supportedNTFHandshakes :: [ALPN] +supportedNTFHandshakes = ["ntf/1"] + type THandleNTF c p = THandle NTFVersion c p data NtfServerHandshake = NtfServerHandshake @@ -104,12 +110,13 @@ ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPa ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c let sk = C.signX509 serverSignKey $ C.publicToX509 k - sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk} + let ntfVersionRange = maybe legacyServerNTFVRange (const ntfVRange) $ getSessionALPN c + sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange, authPubKey = Just sk} getHandshake th >>= \case NtfClientHandshake {ntfVersion = v, keyHash} | keyHash /= kh -> throwError $ TEHandshake IDENTITY - | v `isCompatible` ntfVRange -> + | v `isCompatible` ntfVersionRange -> pure $ ntfThHandleServer th v pk | otherwise -> throwError $ TEHandshake VERSION diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index baadfc79b..6794ad979 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -33,8 +33,8 @@ import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport, VersionSMP, VersionRangeSMP) -import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState) +import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP) +import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -174,13 +174,13 @@ newSubscription subThread = do return Sub {subThread, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do +newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, transportConfig} = do server <- atomically newServer queueStore <- atomically newQueueStore msgStore <- atomically newMsgStore random <- liftIO C.newRandom storeLog <- restoreQueues queueStore `mapM` storeLogFile - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile + tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- loadFingerprint caCertificateFile let serverIdentity = KeyHash fp serverStats <- atomically . newServerStats =<< getCurrentTime diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index a7844cc95..d75d02812 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -25,7 +25,7 @@ import Simplex.Messaging.Server (runSMPServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (safeDecodeUtf8) @@ -211,7 +211,8 @@ smpServerCLI cfgPath logPath = smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, + alpn = Just supportedSMPHandshakes }, controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini } diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 8dfd15813..4b5098c39 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -33,9 +33,12 @@ module Simplex.Messaging.Transport VersionSMP, VersionRangeSMP, THandleSMP, + supportedSMPHandshakes, supportedClientSMPRelayVRange, supportedServerSMPRelayVRange, + legacyServerSMPRelayVRange, currentClientSMPRelayVersion, + legacyServerSMPRelayVersion, currentServerSMPRelayVersion, batchCmdsSMPVersion, basicAuthSMPVersion, @@ -152,6 +155,9 @@ authCmdsSMPVersion = VersionSMP 7 currentClientSMPRelayVersion :: VersionSMP currentClientSMPRelayVersion = VersionSMP 6 +legacyServerSMPRelayVersion :: VersionSMP +legacyServerSMPRelayVersion = VersionSMP 6 + currentServerSMPRelayVersion :: VersionSMP currentServerSMPRelayVersion = VersionSMP 7 @@ -160,9 +166,15 @@ currentServerSMPRelayVersion = VersionSMP 7 supportedClientSMPRelayVRange :: VersionRangeSMP supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion +legacyServerSMPRelayVRange :: VersionRangeSMP +legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion + supportedServerSMPRelayVRange :: VersionRangeSMP supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion +supportedSMPHandshakes :: [ALPN] +supportedSMPHandshakes = ["smp/1"] + simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version @@ -194,6 +206,9 @@ class Transport c where -- | tls-unique channel binding per RFC5929 tlsUnique :: c -> SessionId + -- | ALPN value negotiated for the session + getSessionALPN :: c -> Maybe ALPN + -- | Close connection closeConnection :: c -> IO () @@ -288,6 +303,7 @@ instance Transport TLS where getServerConnection = getTLS TServer getClientConnection = getTLS TClient getServerCerts = tlsServerCerts + getSessionALPN = tlsALPN tlsUnique = tlsUniq closeConnection tls = closeTLS $ tlsContext tls @@ -468,12 +484,13 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do let th@THandle {params = THandleParams {sessionId}} = smpTHandle c sk = C.signX509 serverSignKey $ C.publicToX509 k certChain = getServerCerts c - sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)} + smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c + sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)} getHandshake th >>= \case ClientHandshake {smpVersion = v, keyHash, authPubKey = k'} | keyHash /= kh -> throwE $ TEHandshake IDENTITY - | v `isCompatible` smpVRange -> + | v `isCompatible` smpVersionRange -> pure $ smpThHandleServer th v pk k' | otherwise -> throwE $ TEHandshake VERSION diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index c75d8fa31..f8ea1bd1d 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -51,7 +51,7 @@ 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 + tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig) started <- newEmptyTMVarIO reqQ <- newTBQueueIO qSize action <- async $ diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index e7360b21b..145b438e0 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -28,10 +28,10 @@ import Control.Logger.Simple import Control.Monad import qualified Crypto.Store.X509 as SX import Data.Default (def) -import Data.List (find) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM -import Data.Maybe (fromJust) +import Data.List (find) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) import qualified Data.X509.Validation as XV @@ -152,12 +152,13 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted pure sock setStarted sock = atomically (tryPutTMVar started True) >> pure sock -loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams +loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams loadTLSServerParams = loadSupportedTLSServerParams supportedParameters -loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams -loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile = - fromCredential <$> loadServerCredential +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 = @@ -172,6 +173,7 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p T.serverHooks = def, T.serverSupported = serverSupported } + alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)} loadFingerprint :: FilePath -> IO Fingerprint loadFingerprint certificateFile = do diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs index 062f4f0f0..0883fcc28 100644 --- a/src/Simplex/Messaging/Transport/WebSockets.hs +++ b/src/Simplex/Messaging/Transport/WebSockets.hs @@ -14,7 +14,8 @@ import Network.WebSockets import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as S import Simplex.Messaging.Transport - ( TProxy, + ( ALPN, + TProxy, Transport (..), TransportConfig (..), TransportError (..), @@ -28,6 +29,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR) data WS = WS { wsPeer :: TransportPeer, tlsUniq :: ByteString, + wsALPN :: Maybe ALPN, wsStream :: Stream, wsConnection :: Connection, wsTransportConfig :: TransportConfig, @@ -61,6 +63,9 @@ instance Transport WS where getServerCerts :: WS -> X.CertificateChain getServerCerts = wsServerCerts + getSessionALPN :: WS -> Maybe ALPN + getSessionALPN = wsALPN + tlsUnique :: WS -> ByteString tlsUnique = tlsUniq @@ -90,7 +95,8 @@ getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS connectWS tlsUniq = do s <- makeTLSContextStream cxt wsConnection <- connectPeer wsPeer s - pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts} + wsALPN <- T.getNegotiatedProtocol cxt + pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts} connectPeer :: TransportPeer -> Stream -> IO Connection connectPeer TServer = acceptClientRequest connectPeer TClient = sendClientRequest diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index d3e4e6924..cdcf5baed 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -80,7 +80,7 @@ import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -90,7 +90,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -175,13 +175,16 @@ pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}] smpCfgVPrev :: ProtocolClientConfig SMPVersion -smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} +smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} smpCfgV7 :: ProtocolClientConfig SMPVersion smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} +ntfCfgVPrev :: ProtocolClientConfig NTFVersion +ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} + ntfCfgV2 :: ProtocolClientConfig NTFVersion -ntfCfgV2 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion} +ntfCfgV2 = (ntfCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion} agentCfgVPrev :: AgentConfig agentCfgVPrev = @@ -190,7 +193,8 @@ agentCfgVPrev = smpAgentVRange = prevRange $ smpAgentVRange agentCfg, smpClientVRange = prevRange $ smpClientVRange agentCfg, e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg, - smpCfg = smpCfgVPrev + smpCfg = smpCfgVPrev, + ntfCfg = ntfCfgVPrev } -- agent config for the next client version @@ -2416,7 +2420,8 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do where getClient clientId (clntAuth, clntVersion) db = let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]} - smpCfg = (defaultSMPClientConfig :: ProtocolClientConfig SMPVersion) {serverVRange = V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion} + alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing + smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 46a199777..564523e0b 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -36,6 +36,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol (NtfResponse) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env +import qualified Simplex.Messaging.Notifications.Server.Env as Env import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport @@ -45,6 +46,7 @@ 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 Simplex.Messaging.Version (mkVersionRange) import Test.Hspec import UnliftIO.Async @@ -113,7 +115,8 @@ ntfServerCfgV2 :: NtfServerConfig ntfServerCfgV2 = ntfServerCfg { ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion, - smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}} + smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}, + Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} } withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index cf222c3b4..ae9baeb3c 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -24,8 +24,10 @@ import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM 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 (mkVersionRange) +import qualified Simplex.Messaging.Transport.Server as Server +import Simplex.Messaging.Version import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -73,10 +75,15 @@ testSMPClient = testSMPClientVR supportedClientSMPRelayVRange testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a testSMPClientVR vr client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> + let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN} + runTransportClient tcConfig Nothing useHost testPort (Just testKeyHash) $ \h -> runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case Right th -> client th Left e -> error $ show e + where + clientALPN + | authCmdsSMPVersion `isCompatible` vr = Just supportedSMPHandshakes + | otherwise = Nothing cfg :: ServerConfig cfg = @@ -104,7 +111,7 @@ cfg = privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", smpServerVRange = supportedServerSMPRelayVRange, - transportConfig = defaultTransportServerConfig, + transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes}, controlPort = Nothing }