smp server: do not require ALPN for HTTP to fix Android asset links, do not use port 443 in server-server SMP connections

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
                               }
                         },

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"]

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,

src/Simplex/Messaging/Transport.hs

@@ -44,9 +44,7 @@ module Simplex.Messaging.Transport
     proxiedSMPRelayVRange,
     minClientSMPRelayVersion,
     minServerSMPRelayVersion,
-    legacyServerSMPRelayVRange,
     currentClientSMPRelayVersion,
-    legacyServerSMPRelayVersion,
     currentServerSMPRelayVersion,
     authCmdsSMPVersion,
     sendingProxySMPVersion,

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