diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 344456251..e5b085a7c 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -27,7 +27,7 @@ import Options.Applicative import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) -import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) +import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol (NtfTokenId) @@ -246,6 +246,7 @@ ntfServerCLI cfgPath logPath = socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini, hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini, requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini, + smpWebPortServers = SWPOff, smpPingInterval = 60_000_000 -- 1 minute } }, diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5c05e9984..f3044f7a4 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -200,12 +200,12 @@ 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 tCfg {serverALPN = Just combinedALPNs} $ \s h -> + runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg {serverALPN = Just combinedALPNs} $ \s (sniUsed, h) -> case cast h of - Just (TLS {tlsContext} :: TLS 'TServer) | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext + Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext _ -> runClient srvCert srvSignKey t h `runReaderT` env where - chooseCreds = maybe smpCreds (\_host -> httpCreds) + combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds} combinedALPNs = alpnSupportedSMPHandshakes <> httpALPN httpALPN :: [ALPN] httpALPN = ["h2", "http/1.1"] diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 8ffc7c9e2..b2d16d904 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -40,7 +40,7 @@ import Options.Applicative import Simplex.Messaging.Agent.Protocol (connReqUriP') import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) -import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) +import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -464,7 +464,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini, socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini, hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini, - requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini + requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini, + smpWebPortServers = SWPOff } }, ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini, diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 0b0c440e4..2b47bf569 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -44,9 +44,7 @@ module Simplex.Messaging.Transport proxiedSMPRelayVRange, minClientSMPRelayVersion, minServerSMPRelayVersion, - legacyServerSMPRelayVRange, currentClientSMPRelayVersion, - legacyServerSMPRelayVersion, currentServerSMPRelayVersion, authCmdsSMPVersion, sendingProxySMPVersion, diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index edb599803..89a3bf063 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -5,10 +5,12 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Transport.Server ( TransportServerConfig (..), ServerCredentials (..), + TLSServerCredential (..), AddHTTP, mkTransportServerConfig, runTransportServerState, @@ -74,6 +76,15 @@ data ServerCredentials = ServerCredentials type AddHTTP = Bool +data TLSServerCredential = TLSServerCredential + { credential :: T.Credential, + -- `sniCredential` is used when SNI is sent by the client. + -- It is needed to provide different credential when the server is accessed from the browser. + sniCredential :: Maybe T.Credential + } + +type SNICredentialUsed = Bool + mkTransportServerConfig :: Bool -> Maybe [ALPN] -> Bool -> TransportServerConfig mkTransportServerConfig logTLSErrors serverALPN askClientCert = TransportServerConfig @@ -98,47 +109,55 @@ runTransportServer started port srvSupported srvCreds cfg server = do runTransportServerState ss started port srvSupported srvCreds cfg server runTransportServerState :: 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 ss started port srvSupported credential cfg server = runTransportServerState_ ss started port srvSupported srvCreds cfg (\_ -> server . snd) + where + srvCreds = TLSServerCredential {credential, sniCredential = Nothing} -runTransportServerState_ :: forall c. Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () +runTransportServerState_ :: forall c. Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> TLSServerCredential -> TransportServerConfig -> (Socket -> (SNICredentialUsed, 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. runTransportServerSocket :: Transport c => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO () runTransportServerSocket started getSocket threadLabel srvParams cfg server = do ss <- newSocketState - runTransportServerSocketState_ ss started getSocket threadLabel (tlsSetupTimeout cfg) setupTLS (const server) + runTransportServerSocketState_ ss started getSocket threadLabel (tlsSetupTimeout cfg) setupTLS (\_ -> server . snd) where tCfg = serverTransportConfig cfg setupTLS conn = do tls <- connectTLS Nothing tCfg srvParams conn - getTransportConnection tCfg True (X.CertificateChain []) tls + (False,) <$> getTransportConnection tCfg True (X.CertificateChain []) tls -runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO () +runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> TLSServerCredential -> TransportServerConfig -> (Socket -> (SNICredentialUsed, c 'TServer) -> IO ()) -> IO () runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds cfg server = runTransportServerSocketState_ ss started getSocket threadLabel (tlsSetupTimeout cfg) setupTLS server where tCfg = serverTransportConfig cfg - srvParams = supportedTLSServerParams srvSupported srvCreds $ serverALPN cfg - setupTLS conn - | askClientCert cfg = do - clientCert <- newEmptyTMVarIO - tls <- connectTLS Nothing tCfg (paramsAskClientCert clientCert srvParams) conn - chain <- takePeerCertChain clientCert `E.onException` closeTLS tls - getTransportConnection tCfg True chain tls - | otherwise = do - tls <- connectTLS Nothing tCfg srvParams conn - getTransportConnection tCfg True (X.CertificateChain []) tls + setupTLS conn = do + sniUsed <- newTVarIO False + let srvParams = supportedTLSServerParams srvSupported srvCreds sniUsed $ serverALPN cfg + h <- setupTLS_ srvParams + sni <- readTVarIO sniUsed + pure (sni, h) + where + setupTLS_ srvParams + | askClientCert cfg = do + clientCert <- newEmptyTMVarIO + tls <- connectTLS Nothing tCfg (paramsAskClientCert clientCert srvParams) conn + chain <- takePeerCertChain clientCert `E.onException` closeTLS tls + getTransportConnection tCfg True chain tls + | otherwise = do + tls <- connectTLS Nothing tCfg srvParams conn + getTransportConnection tCfg True (X.CertificateChain []) tls -- | Run a transport server with provided connection setup and handler. -runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> Int -> (Socket -> IO (c 'TServer)) -> (Socket -> c 'TServer -> IO ()) -> IO () +runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> Int -> (Socket -> IO (SNICredentialUsed, c 'TServer)) -> (Socket -> (SNICredentialUsed, c 'TServer) -> IO ()) -> IO () runTransportServerSocketState_ ss started getSocket threadLabel tlsSetupTimeout setupTLS server = do labelMyThread $ "transport server for " <> threadLabel runTCPServerSocket ss started getSocket $ \conn -> do labelMyThread $ threadLabel <> "/setup" E.bracket (timeout tlsSetupTimeout (setupTLS conn) >>= maybe (fail "tls setup timeout") pure) - closeConnection + (closeConnection . snd) (server conn) -- | Run TCP server without TLS @@ -232,13 +251,17 @@ loadServerCredential ServerCredentials {caCertificateFile, certificateFile, priv Right credential -> pure credential Left _ -> putStrLn "invalid credential" >> exitFailure -supportedTLSServerParams :: T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> T.ServerParams -supportedTLSServerParams serverSupported creds alpn_ = +supportedTLSServerParams :: T.Supported -> TLSServerCredential -> TVar SNICredentialUsed -> Maybe [ALPN] -> T.ServerParams +supportedTLSServerParams serverSupported TLSServerCredential {credential, sniCredential} sniCredUsed alpn_ = def { T.serverWantClientCert = False, T.serverHooks = def - { T.onServerNameIndication = \host_ -> pure $ T.Credentials [creds host_], + { T.onServerNameIndication = case sniCredential of + Nothing -> \_ -> pure $ T.Credentials [credential] + Just sniCred -> \case + Nothing -> pure $ T.Credentials [credential] + Just _host -> T.Credentials [sniCred] <$ atomically (writeTVar sniCredUsed True), T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_ }, T.serverSupported = serverSupported