smp server: Allow serving HTTPS and transport on the same port (v2) (#1327)

* smp-server: Allow serving HTTPS and transport on the same port * update rfc * servers: refactor TLS credentials * provide server credentials in SNI hook * determine TLS server params dynamically, when starting the server * remove alpn from TransportServerConfig to decide it dynamically where server is started * diff * combine HTTP and SMP on the shared port * Update to SockAddr * Fix params and web.https parser * Switch fork urls * WIP: add smpServerTestStatic test * Update warp-tls repo * shared connection tests * cleanup * Add protocol tests * rename cert file, enable both ports and web by default * terminate with message on missing credentials * test cert file * client option to use port 443 as default SMP port * use SNI in non-SMP clients * supported * remove TODO * advice * fix test build * Add RSA-4096 check for web creds, fix test * Remove directory listing from static app * message * messages * update log tests --------- Co-authored-by: IC Rainbow <aenor.realm@gmail.com>
2026-08-29 01:18:40 +00:00 · 2024-09-28 23:15:17 +01:00
parent 3c18c4b66a
commit 2a120dfe57
29 changed files with 655 additions and 126 deletions
@@ -104,7 +104,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
  let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
      ProtocolServer _ host port keyHash = srv
  useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
+  let tcConfig = (transportClientConfig xftpNetworkConfig useHost True) {alpn = clientALPN}
      http2Config = xftpHTTP2Config tcConfig config
  clientVar <- newTVarIO Nothing
  let usePort = if null port then "443" else port
@@ -74,8 +74,7 @@ import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
-import Simplex.Messaging.Transport.Client (defaultSMPPort)
+import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
@@ -195,8 +194,8 @@ defaultAgentConfig =
      sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
      connIdBytes = 12,
      tbqSize = 128,
-      smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
-      ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
+      smpCfg = defaultSMPClientConfig,
+      ntfCfg = defaultNTFClientConfig,
      xftpCfg = defaultXFTPClientConfig,
      reconnectInterval = defaultReconnectInterval,
      messageRetryInterval = defaultMessageRetryInterval,
@@ -141,7 +141,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
@@ -281,6 +281,8 @@ data NetworkConfig = NetworkConfig
    smpProxyMode :: SMPProxyMode,
    -- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
    smpProxyFallback :: SMPProxyFallback,
+    -- | use web port 443 for SMP protocol
+    smpWebPort :: Bool,
    -- | timeout for the initial client TCP/TLS connection (microseconds)
    tcpConnectTimeout :: Int,
    -- | timeout of protocol commands (microseconds)
@@ -352,6 +354,7 @@ defaultNetworkConfig =
      sessionMode = TSMSession,
      smpProxyMode = SPMNever,
      smpProxyFallback = SPFAllow,
+      smpWebPort = False,
      tcpConnectTimeout = defaultTcpConnectTimeout,
      tcpTimeout = 15_000_000,
      tcpTimeoutPerKb = 5_000,
@@ -362,9 +365,9 @@ defaultNetworkConfig =
      logTLSErrors = False
    }

-transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
-transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
-  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
+transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI =
+  TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI}
  where
    socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
    useSocksProxy SMAlways = socksProxy'
@@ -400,24 +403,29 @@ data ProtocolClientConfig v = ProtocolClientConfig
    -- | client-server protocol version range
    serverVRange :: VersionRange v,
    -- | agree shared session secret (used in SMP proxy for additional encryption layer)
-    agreeSecret :: Bool
+    agreeSecret :: Bool,
+    -- | send SNI to server, False for SMP
+    useSNI :: Bool
  }

 -- | Default protocol client configuration.
-defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v
-defaultClientConfig clientALPN serverVRange =
+defaultClientConfig :: Maybe [ALPN] -> Bool -> VersionRange v -> ProtocolClientConfig v
+defaultClientConfig clientALPN useSNI serverVRange =
  ProtocolClientConfig
    { qSize = 64,
      defaultTransport = ("443", transport @TLS),
      networkConfig = defaultNetworkConfig,
      clientALPN,
      serverVRange,
-      agreeSecret = False
+      agreeSecret = False,
+      useSNI
    }
 {-# INLINE defaultClientConfig #-}

 defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
-defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange
+defaultSMPClientConfig =
+  (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
+    {defaultTransport = (show defaultSMPPort, transport @TLS)}
 {-# INLINE defaultSMPClientConfig #-}

 data Request err msg = Request
@@ -477,14 +485,14 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 -- 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 (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ proxySessTs disconnected = do
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs disconnected = do
  case chooseTransportHost networkConfig (host srv) of
    Right useHost ->
      (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
    Left e -> pure $ Left e
  where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
    mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
    mkProtocolClient transportHost ts = do
      connected <- newTVarIO False
@@ -515,7 +523,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 useHost) {alpn = clientALPN}
+      let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
          socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
      tId <-
        runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
@@ -528,7 +536,9 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize

    useTransport :: (ServiceName, ATransport)
    useTransport = case port srv of
-      "" -> defaultTransport cfg
+      "" -> case protocolTypeI @(ProtoType msg) of
+        SPSMP | smpWebPort -> ("443", transport @TLS)
+        _ -> defaultTransport cfg
      "80" -> ("80", transport @WS)
      p -> (p, transport @TLS)

@@ -76,7 +76,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
 defaultSMPClientAgentConfig :: SMPClientAgentConfig
 defaultSMPClientAgentConfig =
  SMPClientAgentConfig
-    { smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
+    { smpCfg = defaultSMPClientConfig,
      reconnectInterval =
        RetryInterval
          { initialInterval = second,
@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}

 module Simplex.Messaging.Notifications.Client where

@@ -13,13 +14,17 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
 import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
+import Simplex.Messaging.Transport (TLS, Transport (..))

 type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse

 type NtfClientError = ProtocolClientError ErrorType

 defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
-defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
+defaultNTFClientConfig =
+  (defaultClientConfig (Just supportedNTFHandshakes) True supportedClientNTFVRange)
+    {defaultTransport = ("443", transport @TLS)}
+{-# INLINE defaultNTFClientConfig #-}

 ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
 ntfRegisterToken c pKey newTkn =
@@ -51,7 +51,7 @@ 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 (..), defaultSupportedParams)
-import Simplex.Messaging.Transport.Server (runTransportServer)
+import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
 import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
@@ -80,8 +80,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
  resubscribe s
  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
  where
-    runServer :: (ServiceName, ATransport) -> M ()
-    runServer (tcpPort, ATransport t) = do
+    runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
+    runServer (tcpPort, ATransport t, _addHTTP) = do
      srvCreds <- asks tlsServerCreds
      serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
      env <- ask
@@ -33,13 +33,13 @@ 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 (ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
+import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM

 data NtfServerConfig = NtfServerConfig
-  { transports :: [(ServiceName, ATransport)],
+  { transports :: [(ServiceName, ATransport, AddHTTP)],
    subIdBytes :: Int,
    regCodeBytes :: Int,
    clientQSize :: Natural,
@@ -34,6 +34,7 @@ module Simplex.Messaging.Server
    verifyCmdAuthorization,
    dummyVerifyCmd,
    randomId,
+    AttachHTTP,
  )
 where

@@ -68,10 +69,12 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
+import Data.Typeable (cast)
 import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName, Socket, socketToHandle)
+import qualified Network.TLS as TLS
 import Numeric.Natural (Natural)
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError)
@@ -115,22 +118,23 @@ import GHC.Conc.Sync (threadLabel)
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
-runSMPServer :: ServerConfig -> IO ()
-runSMPServer cfg = do
+runSMPServer :: ServerConfig -> Maybe AttachHTTP -> IO ()
+runSMPServer cfg attachHTTP_ = do
  started <- newEmptyTMVarIO
-  runSMPServerBlocking started cfg
+  runSMPServerBlocking started cfg attachHTTP_

 -- | Runs an SMP server using passed configuration with signalling.
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)
+runSMPServerBlocking :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> IO ()
+runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpServer started cfg attachHTTP_)

 type M a = ReaderT Env IO a
+type AttachHTTP = Socket -> TLS.Context -> IO ()

-smpServer :: TMVar Bool -> ServerConfig -> M ()
-smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
+smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M ()
+smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do
  s <- asks server
  pa <- asks proxyAgent
  expired <- restoreServerMessages
@@ -144,13 +148,26 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
    )
    `finally` withLock' (savingLock s) "final" (saveServer False >> closeServer)
  where
-    runServer :: (ServiceName, ATransport) -> M ()
-    runServer (tcpPort, ATransport t) = do
-      srvCreds <- asks tlsServerCreds
+    runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
+    runServer (tcpPort, ATransport t, addHTTP) = do
+      smpCreds <- asks tlsServerCreds
+      httpCreds_ <- asks httpServerCreds
      ss <- asks sockets
-      serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
+      serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
      env <- ask
-      liftIO $ runTransportServerState ss started tcpPort defaultSupportedParams srvCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
+      liftIO $ case (httpCreds_, attachHTTP_) of
+        (Just httpCreds, Just attachHTTP) | addHTTP ->
+          runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h ->
+            case cast h of
+              Just TLS {tlsContext} | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
+              _ -> runClient serverSignKey t h `runReaderT` env
+          where
+            chooseCreds = maybe smpCreds (\_host -> httpCreds)
+            combinedALPNs = supportedSMPHandshakes <> httpALPN
+            httpALPN :: [ALPN]
+            httpALPN = ["h2", "http/1.1"]
+        _ ->
+          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
    fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey

    saveServer :: Bool -> M ()
@@ -803,7 +820,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do
          -- replace MSG response with OK, accumulating MSG in a separate list.
          MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
          _ -> (msgs, t)
-        
+
 sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
 sendMsg th c@Client {msgQ, sessionId} = do
  labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg"
@@ -1211,7 +1228,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
          when (Just t /= updatedAt) $ do
            withLog $ \s -> logUpdateQueueTime s rId t
            st <- asks queueStore
-            liftIO $ updateQueueTime st rId t 
+            liftIO $ updateQueueTime st rId t

        subscribeNotifications :: M (Transmission BrokerMsg)
        subscribeNotifications = do
@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}

@@ -29,7 +30,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 (loadFileFingerprint)
+import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
 import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
@@ -275,7 +276,7 @@ checkSavedFingerprint cfgPath x509cfg = do
  where
    c = combine cfgPath . ($ x509cfg)

-iniTransports :: Ini -> [(String, ATransport)]
+iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
 iniTransports ini =
  let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
      ws = strictIni "TRANSPORT" "websockets" ini
@@ -283,17 +284,22 @@ iniTransports ini =
        | ws == "off" = []
        | ws == "on" = ["80"]
        | otherwise = ports ws \\ smpPorts
-   in map (,transport @TLS) smpPorts <> map (,transport @WS) wsPorts
+   in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
  where
+    ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
+    ts t = map (\port -> (port, t, webPort == Just port))
+    webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
    ports = map T.unpack . T.splitOn ","

-printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
+printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
 printServerConfig transports logFile = do
  putStrLn $ case logFile of
    Just f -> "Store log: " <> f
    _ -> "Store log disabled."
-  forM_ transports $ \(p, ATransport t) ->
-    putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
+  forM_ transports $ \(p, ATransport t, addHTTP) -> do
+    let descr = p <> " (" <> transportName t <> ")..."
+    putStrLn $ "Serving SMP protocol on port " <> descr
+    when addHTTP $ putStrLn $ "Serving static site on port " <> descr

 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -10,11 +11,13 @@ module Simplex.Messaging.Server.Env.STM where
 import Control.Concurrent (ThreadId)
 import Control.Logger.Simple
 import Control.Monad
+import qualified Crypto.PubKey.RSA as RSA
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
+import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -22,6 +25,7 @@ import Data.Maybe (isJust, isNothing)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
+import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
@@ -41,13 +45,15 @@ 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 (ServerCredentials, SocketState, TransportServerConfig, loadFingerprint, loadServerCredential, newSocketState)
+import Simplex.Messaging.Transport.Server
+import System.Directory (doesFileExist)
+import System.Exit (exitFailure)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM

 data ServerConfig = ServerConfig
-  { transports :: [(ServiceName, ATransport)],
+  { transports :: [(ServiceName, ATransport, AddHTTP)],
    smpHandshakeTimeout :: Int,
    tbqSize :: Natural,
    msgQueueQuota :: Int,
@@ -79,6 +85,7 @@ data ServerConfig = ServerConfig
    -- | interval between sending pending END events to unsubscribed clients, seconds
    pendingENDInterval :: Int,
    smpCredentials :: ServerCredentials,
+    httpCredentials :: Maybe ServerCredentials,
    -- | SMP client-server protocol version range
    smpServerVRange :: VersionRangeSMP,
    -- | TCP transport config
@@ -123,6 +130,7 @@ data Env = Env
    random :: TVar ChaChaDRG,
    storeLog :: Maybe (StoreLog 'WriteMode),
    tlsServerCreds :: T.Credential,
+    httpServerCreds :: Maybe T.Credential,
    serverStats :: ServerStats,
    sockets :: SocketState,
    clientSeq :: TVar ClientId,
@@ -217,7 +225,7 @@ newProhibitedSub = do
  return Sub {subThread = ProhibitSub, delivered}

 newEnv :: ServerConfig -> IO Env
-newEnv config@ServerConfig {smpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
+newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
  server <- newServer
  queueStore <- newQueueStore
  msgStore <- newMsgStore
@@ -226,7 +234,9 @@ newEnv config@ServerConfig {smpCredentials, storeLogFile, smpAgentCfg, informati
    forM storeLogFile $ \f -> do
      logInfo $ "restoring queues from file " <> T.pack f
      restoreQueues queueStore f
-  tlsServerCreds <- loadServerCredential smpCredentials
+  tlsServerCreds <- getCredentials "SMP" smpCredentials
+  httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
+  mapM_ checkHTTPSCredentials httpServerCreds
  Fingerprint fp <- loadFingerprint smpCredentials
  let serverIdentity = KeyHash fp
  serverStats <- newServerStats =<< getCurrentTime
@@ -234,8 +244,28 @@ newEnv config@ServerConfig {smpCredentials, storeLogFile, smpAgentCfg, informati
  clientSeq <- newTVarIO 0
  clients <- newTVarIO mempty
  proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
  where
+    getCredentials protocol creds = do
+      files <- missingCreds
+      unless (null files) $ do
+        putStrLn $ "Error: no " <> protocol <> " credentials: " <> intercalate ", " files
+        when (protocol == "HTTPS") $ putStrLn letsEncrypt
+        exitFailure
+      loadServerCredential creds
+      where
+        missingfile f = (\y -> [f | not y]) <$> doesFileExist f
+        missingCreds = do
+          let files = maybe id (:) (caCertificateFile creds) [certificateFile creds, privateKeyFile creds]
+           in concat <$> mapM missingfile files
+    checkHTTPSCredentials (X.CertificateChain cc, _k) =
+      -- LetsEncrypt provides ECDSA with insecure curve p256 (https://safecurves.cr.yp.to)
+      case map (X.signedObject . X.getSigned) cc of
+        X.Certificate {X.certPubKey = X.PubKeyRSA rsa} : _ca | RSA.public_size rsa >= 512 -> pure ()
+        _ -> do
+          putStrLn $ "Error: unsupported HTTPS credentials, required 4096-bit RSA\n" <> letsEncrypt
+          exitFailure
+    letsEncrypt = "Use Let's Encrypt to generate: certbot certonly --standalone -d yourdomainname --key-type rsa --rsa-key-size 4096"
    restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
    restoreQueues QueueStore {queues, senders, notifiers} f = do
      (qs, s) <- readWriteStoreLog f
@@ -36,7 +36,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
-import Simplex.Messaging.Server (runSMPServer)
+import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency)
 import Simplex.Messaging.Server.Expiration
@@ -52,10 +52,16 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)

 smpServerCLI :: FilePath -> FilePath -> IO ()
-smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ())
+smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")

-smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> IO ()
-smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
+smpServerCLI_ ::
+  (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
+  (EmbeddedWebParams -> IO ()) ->
+  (FilePath -> (AttachHTTP -> IO ()) -> IO ()) ->
+  FilePath ->
+  FilePath ->
+  IO ()
+smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
    Init opts ->
      doesFileExist iniFile >>= \case
@@ -77,10 +83,10 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
  where
    iniFile = combine cfgPath "smp-server.ini"
    serverVersion = "SMP server v" <> simplexMQVersion
-    defaultServerPort = "5223"
+    defaultServerPorts = "5223,443"
    executableName = "smp-server"
    storeLogFilePath = combine logPath "smp-server-store.log"
-    httpsCertFile = combine cfgPath "web.cert"
+    httpsCertFile = combine cfgPath "web.crt"
    httpsKeyFile = combine cfgPath "web.key"
    defaultStaticPath = combine logPath "www"
    initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted}
@@ -96,7 +102,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
          host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
          sourceCode' <- withPrompt ("Enter server source code URI (" <> maybe simplexmqSource T.unpack src' <> "): ") getServerSourceCode
          staticPath' <- withPrompt ("Enter path to store generated static site with server information (" <> fromMaybe defaultStaticPath sp' <> "): ") getLine
-          enableWeb <- onOffPrompt "Enable built-in web server for static site" (not noWeb')
          initialize
            opts
              { enableStoreLog,
@@ -105,7 +110,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                password,
                sourceCode = (T.pack <$> sourceCode') <|> src',
                webStaticPath = if null staticPath' then sp' else Just staticPath',
-                disableWeb = not enableWeb
+                disableWeb = noWeb'
              }
      where
        serverPassword =
@@ -172,7 +177,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                   \# Host is only used to print server address on start.\n\
                   \# You can specify multiple server ports.\n"
                <> ("host: " <> T.pack host <> "\n")
-                <> ("port: " <> T.pack defaultServerPort <> "\n")
+                <> ("port: " <> T.pack defaultServerPorts <> "\n")
                <> "log_tls_errors: off\n\n\
                   \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
                   \websockets: off\n\
@@ -205,19 +210,21 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                <> "# Run an embedded server on this port\n\
                   \# Onion sites can use any port and register it in the hidden service config.\n\
                   \# Running on a port 80 may require setting process capabilities.\n"
-                <> ((if disableWeb then "# " else "") <> "http: 8000\n\n")
+                <> (webDisabled <> "http: 8000\n\n")
                <> "# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
-                   \# Not required for running relay on onion address.\n\
-                   \# https: 443\n"
-                <> ("# cert: " <> T.pack httpsCertFile <> "\n")
-                <> ("# key: " <> T.pack httpsKeyFile <> "\n")
+                   \# Not required for running relay on onion address.\n"
+                <> (webDisabled <> "https: 443\n")
+                <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
+                <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
+              where
+                webDisabled = if disableWeb then "# " else ""
    runServer ini = do
      hSetBuffering stdout LineBuffering
      hSetBuffering stderr LineBuffering
      fp <- checkSavedFingerprint cfgPath defaultX509Config
      let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
          port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {information, transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
+          cfg@ServerConfig {information, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
          sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
          srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
      printServiceInfo serverVersion srv
@@ -247,15 +254,25 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                newQueuesAllowed = allowNewQueues cfg,
                basicAuthEnabled = isJust newQueueBasicAuth
              }
-      runWebServer ini ServerInformation {config, information}
-      runSMPServer cfg
+      case webStaticPath' of
+        Just path | sharedHTTP -> do
+          runWebServer path Nothing ServerInformation {config, information}
+          attachStaticFiles path $ \attachHTTP -> runSMPServer cfg $ Just attachHTTP
+        Just path -> do
+          runWebServer path webHttpsParams' ServerInformation {config, information}
+          runSMPServer cfg Nothing
+        Nothing -> do
+          logWarn "No server static path set"
+          runSMPServer cfg Nothing
      where
        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
        logStats = settingIsOn "STORE_LOG" "log_stats" ini
        c = combine cfgPath . ($ defaultX509Config)
+        transports = iniTransports ini
+        sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
        serverConfig =
          ServerConfig
-            { transports = iniTransports ini,
+            { transports,
              smpHandshakeTimeout = 120000000,
              tbqSize = 128,
              msgQueueQuota = 128,
@@ -267,6 +284,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                    privateKeyFile = c serverKeyFile,
                    certificateFile = c serverCrtFile
                  },
+              httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
              storeLogFile = enableStoreLog $> storeLogFilePath,
              storeMsgsFile =
                let messagesPath = combine logPath "smp-server-messages.log"
@@ -325,26 +343,23 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
            }
        textToOwnServers :: Text -> [ByteString]
        textToOwnServers = map encodeUtf8 . T.words
-
-    runWebServer ini si =
-      case eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini of
-        Nothing -> logWarn "No server static path set"
-        Just webStaticPath -> do
+        runWebServer webStaticPath webHttpsParams si = do
          let onionHost =
                either (const Nothing) (find isOnion) $
                  strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini
              webHttpPort = eitherToMaybe $ read . T.unpack <$> lookupValue "WEB" "http" ini
-              webHttpsParams =
-                eitherToMaybe $ do
-                  port <- read . T.unpack <$> lookupValue "WEB" "https" ini
-                  cert <- T.unpack <$> lookupValue "WEB" "cert" ini
-                  key <- T.unpack <$> lookupValue "WEB" "key" ini
-                  pure WebHttpsParams {port, cert, key}
          generateSite si onionHost webStaticPath
          when (isJust webHttpPort || isJust webHttpsParams) $
            serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
          where
            isOnion = \case THOnionHost _ -> True; _ -> False
+        webHttpsParams' =
+          eitherToMaybe $ do
+            port <- read . T.unpack <$> lookupValue "WEB" "https" ini
+            cert <- T.unpack <$> lookupValue "WEB" "cert" ini
+            key <- T.unpack <$> lookupValue "WEB" "key" ini
+            pure WebHttpsParams {port, cert, key}
+        webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini

 data EmbeddedWebParams = EmbeddedWebParams
  { webStaticPath :: FilePath,
@@ -66,6 +66,7 @@ module Simplex.Messaging.Transport
    connectTLS,
    closeTLS,
    defaultSupportedParams,
+    defaultSupportedParamsHTTPS,
    withTlsUnique,

    -- * SMP transport
@@ -100,6 +101,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
+import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Data.Word (Word16)
 import qualified Data.X509 as X
@@ -214,7 +216,7 @@ data TransportConfig = TransportConfig
    transportTimeout :: Maybe Int
  }

-class Transport c where
+class Typeable c => Transport c where
  transport :: ATransport
  transport = ATransport (TProxy @c)

@@ -321,8 +323,29 @@ defaultSupportedParams =
          TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- for TLS12
        ],
      T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
-      T.supportedSecureRenegotiation = False,
-      T.supportedGroups = [T.X448, T.X25519]
+      T.supportedGroups = [T.X448, T.X25519],
+      T.supportedSecureRenegotiation = False
+    }
+
+-- | A selection of extra parameters to accomodate browser chains
+defaultSupportedParamsHTTPS :: T.Supported
+defaultSupportedParamsHTTPS =
+  defaultSupportedParams
+    { T.supportedCiphers = TE.ciphersuite_strong,
+      T.supportedGroups = [T.X25519, T.X448, T.FFDHE4096, T.FFDHE6144, T.FFDHE8192, T.P521],
+      T.supportedHashSignatures =
+        [ (T.HashIntrinsic, T.SignatureEd448),
+          (T.HashIntrinsic, T.SignatureEd25519),
+          (T.HashSHA256, T.SignatureECDSA),
+          (T.HashSHA384, T.SignatureECDSA),
+          (T.HashSHA512, T.SignatureECDSA),
+          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA512),
+          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA384),
+          (T.HashIntrinsic, T.SignatureRSApssRSAeSHA256),
+          (T.HashSHA512, T.SignatureRSA),
+          (T.HashSHA384, T.SignatureRSA),
+          (T.HashSHA256, T.SignatureRSA)
+        ]
    }

 instance Transport TLS where
@@ -125,7 +125,8 @@ data TransportClientConfig = TransportClientConfig
    tcpKeepAlive :: Maybe KeepAliveOpts,
    logTLSErrors :: Bool,
    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
-    alpn :: Maybe [ALPN]
+    alpn :: Maybe [ALPN],
+    useSNI :: Bool
  }
  deriving (Eq, Show)

@@ -134,7 +135,7 @@ defaultTcpConnectTimeout :: Int
 defaultTcpConnectTimeout = 25_000_000

 defaultTransportClientConfig :: TransportClientConfig
-defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing
+defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing True

 clientTransportConfig :: TransportClientConfig -> TransportConfig
 clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -145,10 +146,10 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredent
 runTransportClient = runTLSTransportClient defaultSupportedParams Nothing

 runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
-runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} socksCreds host port keyHash client = do
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do
  serverCert <- newEmptyTMVarIO
  let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn useSNI serverCert
      connectTCP = case socksProxy of
        Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
        _ -> connectTCPClient hostName
@@ -238,7 +239,7 @@ instance StrEncoding SocksProxy where
      socksAddr port = \case
        THIPv4 addr -> pure $ SockAddrInet port $ tupleToHostAddress addr
        THIPv6 addr -> pure $ SockAddrInet6 port 0 addr 0
-        _ -> fail "SOCKS5 host should be IPv4 or IPv6 address"          
+        _ -> fail "SOCKS5 host should be IPv4 or IPv6 address"

 instance StrEncoding SocksProxyWithAuth where
  strEncode (SocksProxyWithAuth auth proxy) = strEncode auth <> strEncode proxy
@@ -263,10 +264,11 @@ instance StrEncoding SocksAuth where
        password <- A.takeTill (== '@') <* A.char '@'
        pure SocksAuthUsername {username, password}

-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams
-mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
+mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ sni serverCerts =
  (T.defaultParamsClient host p)
-    { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
+    { T.clientUseServerNameIndication = sni,
+      T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
      T.clientHooks =
        def
          { T.onServerCertificate = onServerCert,
@@ -78,7 +78,8 @@ defaultHTTP2ClientConfig =
            tcpKeepAlive = Nothing,
            logTLSErrors = True,
            clientCredentials = Nothing,
-            alpn = Nothing
+            alpn = Nothing,
+            useSNI = True
          },
      bufferSize = defaultHTTP2BufferSize,
      bodyHeadSize = 16384,
@@ -7,8 +7,10 @@
 module Simplex.Messaging.Transport.Server
  ( TransportServerConfig (..),
    ServerCredentials (..),
+    AddHTTP,
    defaultTransportServerConfig,
    runTransportServerState,
+    runTransportServerState_,
    SocketState,
    newSocketState,
    runTransportServer,
@@ -65,6 +67,8 @@ data ServerCredentials = ServerCredentials
  }
  deriving (Show)

+type AddHTTP = Bool
+
 defaultTransportServerConfig :: TransportServerConfig
 defaultTransportServerConfig =
  TransportServerConfig
@@ -87,32 +91,35 @@ runTransportServer started port srvSupported srvCreds alpn_ cfg server = do
  runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server

 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))
+runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) alpn_ cfg (const server)
+
+runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> 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.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
 runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg server = do
  ss <- newSocketState
-  runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server
+  runTransportServerSocketState_ ss started getSocket threadLabel (const srvCreds) srvParams cfg (const server)

-runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (X.CertificateChain, X.PrivKey) -> Maybe [ALPN] -> TransportServerConfig -> (a -> IO ()) -> IO ()
+runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> 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 -> (X.CertificateChain, X.PrivKey) -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
+runTransportServerSocketState_ :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> 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
+    E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection (server conn)
  where
    tCfg = serverTransportConfig cfg
    setup conn = timeout (tlsSetupTimeout cfg) $ do
      labelMyThread $ threadLabel <> "/setup"
      tls <- connectTLS Nothing tCfg srvParams conn
-      getServerConnection tCfg (fst srvCreds) tls
+      getServerConnection tCfg (fst $ srvCreds Nothing) tls

 -- | Run TCP server without TLS
 runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
@@ -191,15 +198,15 @@ loadServerCredential ServerCredentials {caCertificateFile, certificateFile, priv
    Left _ -> putStrLn "invalid credential" >> exitFailure

 supportedTLSServerParams :: T.Credential -> Maybe [ALPN] -> T.ServerParams
-supportedTLSServerParams = supportedTLSServerParams_ defaultSupportedParams
+supportedTLSServerParams = supportedTLSServerParams_ defaultSupportedParams . const

-supportedTLSServerParams_ :: T.Supported -> T.Credential -> Maybe [ALPN] -> T.ServerParams
-supportedTLSServerParams_ serverSupported credential alpn_ =
+supportedTLSServerParams_ :: T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> T.ServerParams
+supportedTLSServerParams_ serverSupported creds alpn_ =
  def
    { T.serverWantClientCert = False,
      T.serverHooks =
        def
-          { T.onServerNameIndication = \_ -> pure $ T.Credentials [credential],
+          { T.onServerNameIndication = \host_ -> pure $ T.Credentials [creds host_],
            T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_
          },
      T.serverSupported = serverSupported