From 6aebf479791ffa829569ea91df16a536adc0d888 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 16 Mar 2026 11:23:24 +0000
Subject: [PATCH 1/5] smp: allow websocket connections on the same port

---
 apps/smp-server/Main.hs                       |  4 +-
 simplexmq.cabal                               |  1 +
 src/Simplex/Messaging/Server.hs               | 57 ++++++++++---
 src/Simplex/Messaging/Server/Web.hs           | 84 ++++++++++++++++++-
 src/Simplex/Messaging/Transport/WebSockets.hs | 12 ++-
 tests/CLITests.hs                             |  4 +-
 tests/SMPClient.hs                            | 26 ++++--
 tests/ServerTests.hs                          | 62 ++++++++++++++
 8 files changed, 223 insertions(+), 27 deletions(-)

diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs
index 3a334d0d5..315eed4f2 100644
--- a/apps/smp-server/Main.hs
+++ b/apps/smp-server/Main.hs
@@ -3,7 +3,7 @@ module Main where
 import Control.Logger.Simple
 import Simplex.Messaging.Server.CLI (getEnvPath)
 import Simplex.Messaging.Server.Main (smpServerCLI_)
-import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFiles)
+import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFilesWithWS)
 import SMPWeb (smpGenerateSite)
 
 defaultCfgPath :: FilePath
@@ -19,4 +19,4 @@ main :: IO ()
 main = do
   cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
   logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
-  withGlobalLogging logCfg $ smpServerCLI_ smpGenerateSite serveStaticFiles attachStaticFiles cfgPath logPath
+  withGlobalLogging logCfg $ smpServerCLI_ smpGenerateSite serveStaticFiles attachStaticFilesWithWS cfgPath logPath
diff --git a/simplexmq.cabal b/simplexmq.cabal
index c13fe8f5f..8dabd9208 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -354,6 +354,7 @@ library
       , temporary ==1.3.*
       , wai >=3.2 && <3.3
       , wai-app-static >=3.1 && <3.2
+      , wai-websockets >=3.0.1 && <3.1
       , warp ==3.3.30
       , warp-tls ==3.4.7
       , websockets ==0.12.*
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index ec75a07d4..a9c19e20c 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -40,6 +40,7 @@ module Simplex.Messaging.Server
     dummyVerifyCmd,
     randomId,
     AttachHTTP,
+    WSHandler,
     MessageStats (..),
   )
 where
@@ -121,6 +122,7 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Server
+import Simplex.Messaging.Transport.WebSockets (WS (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Environment (lookupEnv)
@@ -160,7 +162,14 @@ runSMPServerBlocking :: MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe
 runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpServer started cfg attachHTTP_)
 
 type M s a = ReaderT (Env s) IO a
-type AttachHTTP = Socket -> TLS.Context -> IO ()
+
+-- | Callback to handle HTTP/WebSocket connections on TLS ports with SNI.
+-- When a client connects with SNI (browser), this handler is called.
+-- The WS handler is provided by the server for WebSocket upgrade support.
+type AttachHTTP = Socket -> TLS.Context -> Maybe WSHandler -> IO ()
+
+-- | Handler for WebSocket connections (SMP over WebSocket)
+type WSHandler = WS 'TServer -> IO ()
 
 -- actions used in serverThread to reduce STM transaction scope
 data ClientSubAction
@@ -207,16 +216,28 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
       srvSignKey <- either fail pure $ C.x509ToPrivate' srvKey
       env <- ask
-      liftIO $ case (httpCreds_, attachHTTP_) of
-        (Just httpCreds, Just attachHTTP) | addHTTP ->
-          runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
-            case cast h of
-              Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext
-              _ -> runClient srvCert srvSignKey t h `runReaderT` env
-          where
-            combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
-        _ ->
-          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
+      liftIO $ do
+        putStrLn $ "SERVER: httpCreds_=" ++ show (isJust httpCreds_) ++ " attachHTTP_=" ++ show (isJust attachHTTP_) ++ " addHTTP=" ++ show addHTTP
+        case (httpCreds_, attachHTTP_) of
+          (Just httpCreds, Just attachHTTP) | addHTTP -> do
+            putStrLn "SERVER: using combinedCreds branch"
+            runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
+              case cast h of
+                Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> do
+                  putStrLn "SERVER: SNI connection, handing to attachHTTP"
+                  labelMyThread "https client"
+                  let wsHandler = Just $ \ws -> do
+                        putStrLn "SERVER: wsHandler called"
+                        runClient srvCert srvSignKey (TProxy :: TProxy WS 'TServer) ws `runReaderT` env
+                  attachHTTP s tlsContext wsHandler
+                _ -> do
+                  putStrLn "SERVER: non-SNI connection, running SMP client"
+                  runClient srvCert srvSignKey t h `runReaderT` env
+            where
+              combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
+          _ -> do
+            putStrLn "SERVER: using smpCreds only branch"
+            runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
 
     sigIntHandlerThread :: M s ()
     sigIntHandlerThread = do
@@ -726,8 +747,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
       labelMyThread $ "smp handshake for " <> transportName tp
       liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange $ getClientService ms g idSize) >>= \case
-        Just (Right th) -> runClientTransport th
-        _ -> pure ()
+        Just (Right th) -> do
+          liftIO $ putStrLn "SERVER: SMP handshake completed, running client transport"
+          runClientTransport th
+        Just (Left e) -> liftIO $ putStrLn $ "SERVER: SMP handshake failed: " ++ show e
+        Nothing -> liftIO $ putStrLn "SERVER: SMP handshake timed out"
 
     getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId
     getClientService ms g idSize role cert fp = do
@@ -1132,13 +1156,17 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
   sa <- asks serverActive
   stats <- asks serverStats
   liftIO $ forever $ do
+    putStrLn "SERVER receive: waiting for command"
     ts <- tGetServer h
+    putStrLn "SERVER receive: got command"
     unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
     atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
     let (es, ts') = partitionEithers $ L.toList ts
         errs = map (second ERR) es
+    putStrLn $ "SERVER receive: errors=" ++ show (length es) ++ " commands=" ++ show (length ts')
     errs' <- case ts' of
       (_, _, (_, _, Cmd p cmd)) : rest -> do
+        putStrLn $ "SERVER receive: verifying command"
         let service = peerClientService =<< thAuth
         (errs', cmds) <- partitionEithers <$> case batchParty p of
           Just Dict | not (null rest) && all (sameParty p) ts'-> do
@@ -1201,8 +1229,11 @@ sendMsg th c@Client {msgQ, clientTHParams = THandleParams {sessionId}} = do
 
 tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
 tSend th Client {sndActiveAt} ts = do
+  tid <- myThreadId
+  putStrLn $ "SERVER tSend [" ++ show tid ++ "]: sending " ++ show (length ts) ++ " transmissions"
   withMVar th $ \h@THandle {params} ->
     void . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
+  putStrLn $ "SERVER tSend [" ++ show tid ++ "]: sent"
   atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
 
 disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
diff --git a/src/Simplex/Messaging/Server/Web.hs b/src/Simplex/Messaging/Server/Web.hs
index bd6563dc3..7ded65833 100644
--- a/src/Simplex/Messaging/Server/Web.hs
+++ b/src/Simplex/Messaging/Server/Web.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -9,6 +10,7 @@ module Simplex.Messaging.Server.Web
     EmbeddedContent (..),
     serveStaticFiles,
     attachStaticFiles,
+    attachStaticFilesWithWS,
     serveStaticPageH2,
     generateSite,
     serverInfoSubsts,
@@ -29,20 +31,27 @@ import Data.List (isPrefixOf, isSuffixOf)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import qualified Data.X509 as X
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket (getPeerName)
+import qualified Network.TLS as TLS
 import Network.Wai (Application, Request (..))
 import Network.Wai.Application.Static (StaticSettings (..))
 import qualified Network.Wai.Application.Static as S
 import qualified Network.Wai.Handler.Warp as W
 import qualified Network.Wai.Handler.Warp.Internal as WI
 import qualified Network.Wai.Handler.WarpTLS as WT
+import qualified Network.Wai.Handler.WebSockets as WaiWS
+import Network.WebSockets (acceptRequest, defaultConnectionOptions, ConnectionOptions(..), SizeLimit(..), PendingConnection)
+import Network.WebSockets.Stream (Stream)
+import qualified Network.WebSockets.Stream as WSS
 import Simplex.Messaging.Encoding.String (strEncode)
-import Simplex.Messaging.Server (AttachHTTP)
+import Simplex.Messaging.Server (AttachHTTP, WSHandler)
 import Simplex.Messaging.Server.CLI (simplexmqCommit)
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Transport (simplexMQVersion)
+import Simplex.Messaging.Transport (TransportConfig (..), smpBlockSize, simplexMQVersion)
+import Simplex.Messaging.Transport.WebSockets (WS (..))
 import Simplex.Messaging.Util (ifM, tshow)
 import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)
 import System.FilePath
@@ -82,11 +91,12 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
     mkSettings port = W.setPort port warpSettings
 
 -- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
-attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
+-- This version does not support WebSocket upgrade (passes Nothing for wsHandler).
+attachStaticFiles :: FilePath -> (AttachHTTP -> IO a) -> IO a
 attachStaticFiles path action =
   -- Initialize global internal state for http server.
   WI.withII warpSettings $ \ii -> do
-    action $ \socket cxt -> do
+    action $ \socket cxt _wsHandler -> do
       -- Initialize internal per-connection resources.
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->
@@ -105,6 +115,72 @@ attachStaticFiles path action =
     -- shared clean up
     terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
 
+-- | Like 'attachStaticFiles' but with WebSocket upgrade support for SMP.
+-- When wsHandler is provided via AttachHTTP, WebSocket connections are handed off to it.
+-- When wsHandler is Nothing, WebSocket upgrade requests are rejected (falls through to static files).
+attachStaticFilesWithWS :: FilePath -> (AttachHTTP -> IO a) -> IO a
+attachStaticFilesWithWS path action =
+  WI.withII warpSettings $ \ii -> do
+    action $ \socket cxt wsHandler_ -> do
+      -- Capture TLS info BEFORE Warp takes over
+      tlsUniq <- getTlsUnique cxt
+      wsALPN <- TLS.getNegotiatedProtocol cxt
+      let peerCert = X.CertificateChain [] -- Client certs not used for web widget
+
+      -- Create combined WAI app: WebSocket -> SMP (if handler provided), HTTP -> static files
+      let app = case wsHandler_ of
+            Just wsHandler -> WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) (staticFiles path)
+            Nothing -> staticFiles path
+
+      addr <- getPeerName socket
+      withConnection addr cxt $ \(conn, transport) ->
+        withTimeout ii conn $ \th ->
+          WI.serveConnection conn ii th addr transport warpSettings app
+  where
+    wsOpts = defaultConnectionOptions
+      { connectionFramePayloadSizeLimit = SizeLimit $ fromIntegral smpBlockSize,
+        connectionMessageDataSizeLimit = SizeLimit 65536
+      }
+
+    handleWebSocket :: WSHandler -> ByteString -> Maybe ByteString -> X.CertificateChain -> PendingConnection -> IO ()
+    handleWebSocket wsHandler tlsUniq wsALPN peerCert pending = do
+      wsConn <- acceptRequest pending
+      -- Create a dummy stream for the WS type. In wai-websockets context,
+      -- connection lifecycle is managed externally, so this stream just
+      -- provides the interface for closeConnection.
+      dummyStream <- makeDummyStream
+      let ws = WS
+            { tlsUniq = tlsUniq,
+              wsALPN = wsALPN,
+              wsStream = dummyStream,
+              wsConnection = wsConn,
+              wsTransportConfig = defaultTransportConfig,
+              wsCertSent = False,
+              wsPeerCert = peerCert
+            }
+      wsHandler ws
+
+    -- Create a minimal stream that just returns EOF on read and ignores writes.
+    -- Close is a no-op since wai-websockets manages the connection lifecycle.
+    makeDummyStream :: IO Stream
+    makeDummyStream = WSS.makeStream (pure Nothing) (\_ -> pure ())
+
+    defaultTransportConfig = TransportConfig {logTLSErrors = True, transportTimeout = Nothing}
+
+    -- Get TLS unique value (used for channel binding)
+    getTlsUnique :: TLS.Context -> IO ByteString
+    getTlsUnique cxt = TLS.getPeerFinished cxt >>= maybe (fail "TLS not finished") pure
+
+    -- from warp-tls (socket is actually SockAddr here, matching original pattern)
+    withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
+    -- from warp
+    withTimeout ii conn =
+      bracket
+        (WI.registerKillThread (WI.timeoutManager ii) (WI.connClose conn))
+        WI.cancel
+    -- shared clean up
+    terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
+
 warpSettings :: W.Settings
 warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
 
diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs
index 3ab213dcd..411880ba4 100644
--- a/src/Simplex/Messaging/Transport/WebSockets.hs
+++ b/src/Simplex/Messaging/Transport/WebSockets.hs
@@ -9,6 +9,7 @@
 
 module Simplex.Messaging.Transport.WebSockets (WS (..)) where
 
+import Control.Concurrent (myThreadId)
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -71,13 +72,19 @@ instance Transport WS where
 
   cGet :: WS p -> Int -> IO ByteString
   cGet c n = do
+    tid <- myThreadId
+    putStrLn $ "WS cGet [" ++ show tid ++ "]: expecting " ++ show n ++ " bytes"
     s <- receiveData (wsConnection c)
+    putStrLn $ "WS cGet [" ++ show tid ++ "]: received " ++ show (B.length s) ++ " bytes"
     if B.length s == n
       then pure s
       else E.throwIO TEBadBlock
 
   cPut :: WS p -> ByteString -> IO ()
-  cPut = sendBinaryData . wsConnection
+  cPut c s = do
+    tid <- myThreadId
+    putStrLn $ "WS cPut [" ++ show tid ++ "]: sending " ++ show (B.length s) ++ " bytes"
+    sendBinaryData (wsConnection c) s
 
   getLn :: WS p -> IO ByteString
   getLn c = do
@@ -90,8 +97,11 @@ getWS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateC
 getWS cfg wsCertSent wsPeerCert cxt = withTlsUnique @WS @p cxt connectWS
   where
     connectWS tlsUniq = do
+      putStrLn "getWS: creating stream"
       s <- makeTLSContextStream cxt
+      putStrLn "getWS: connecting peer"
       wsConnection <- connectPeer s
+      putStrLn "getWS: connected"
       wsALPN <- T.getNegotiatedProtocol cxt
       pure $ WS {tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsCertSent, wsPeerCert}
     connectPeer :: Stream -> IO Connection
diff --git a/tests/CLITests.hs b/tests/CLITests.hs
index 66af74ab8..661450391 100644
--- a/tests/CLITests.hs
+++ b/tests/CLITests.hs
@@ -31,7 +31,7 @@ import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
 import Simplex.Messaging.Transport.Server (loadFileFingerprint)
 import Simplex.Messaging.Util (catchAll_)
 import qualified SMPWeb
-import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFiles)
+import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFilesWithWS)
 import System.Directory (doesFileExist)
 import System.Environment (withArgs)
 import System.FilePath ((</>))
@@ -152,7 +152,7 @@ smpServerTestStatic = do
   Right ini_ <- readIniFile iniFile
   lookupValue "WEB" "https" ini_ `shouldBe` Right "5223"
 
-  let smpServerCLI' = smpServerCLI_ SMPWeb.smpGenerateSite serveStaticFiles attachStaticFiles
+  let smpServerCLI' = smpServerCLI_ SMPWeb.smpGenerateSite serveStaticFiles attachStaticFilesWithWS
   let server = capture_ (withArgs ["start"] $ smpServerCLI' cfgPath logPath `catchAny` print)
   bracket (async server) cancel $ \_t -> do
     threadDelay 1000000
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index c51079d5e..0a65944d2 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -26,13 +26,15 @@ import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClie
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server (runSMPServerBlocking)
+import Simplex.Messaging.Server (runSMPServerBlocking, AttachHTTP)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..))
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
+import Data.X509.Validation (Fingerprint (..))
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.Server
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFileFingerprint, loadFingerprint, loadServerCredential, mkTransportServerConfig)
+import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (ifM)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
@@ -155,7 +157,8 @@ testSMPClientVR vr client = do
 
 testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
 testSMPClient_ host port vr client = do
-  let tcConfig = defaultTransportClientConfig {clientALPN} :: TransportClientConfig
+  -- SMP clients use useSNI = False (matches defaultSMPClientConfig)
+  let tcConfig = defaultTransportClientConfig {clientALPN, useSNI = False} :: TransportClientConfig
   runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h ->
     runExceptT (smpClientHandshake h Nothing testKeyHash vr False Nothing) >>= \case
       Right th -> client th
@@ -283,6 +286,16 @@ serverStoreConfig_ useDbStoreLog = \case
     dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
     storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
 
+cfgWebOn :: AStoreType -> ServiceName -> AServerConfig
+cfgWebOn msType port' = updateCfg (cfgMS msType) $ \cfg' ->
+  cfg' { transports = [(port', transport @TLS, True)],
+         httpCredentials = Just ServerCredentials
+           { caCertificateFile = Nothing,
+             privateKeyFile = "tests/fixtures/web.key",
+             certificateFile = "tests/fixtures/web.crt"
+           }
+       }
+
 cfgV7 :: AServerConfig
 cfgV7 = updateCfg cfg $ \cfg' -> cfg' {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion}
 
@@ -333,9 +346,12 @@ withServerCfg :: AServerConfig -> (forall s. ServerConfig s -> a) -> a
 withServerCfg (ASrvCfg _ _ cfg') f = f cfg'
 
 withSmpServerConfigOn :: HasCallStack => ASrvTransport -> AServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerConfigOn t (ASrvCfg _ _ cfg') port' =
+withSmpServerConfigOn t cfg' port' = withSmpServerConfig (updateCfg cfg' $ \c -> c {transports = [(port', t, False)]}) Nothing
+
+withSmpServerConfig :: HasCallStack => AServerConfig -> Maybe AttachHTTP -> (HasCallStack => ThreadId -> IO a) -> IO a
+withSmpServerConfig (ASrvCfg _ _ cfg') attachHTTP_ =
   serverBracket
-    (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
+    (\started -> runSMPServerBlocking started cfg' attachHTTP_)
     (threadDelay 10000)
 
 withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs
index b2c2d997c..9e1662667 100644
--- a/tests/ServerTests.hs
+++ b/tests/ServerTests.hs
@@ -23,6 +23,7 @@ import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, throwIO, try)
 import Control.Monad
+import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Class
 import CoreTests.MsgStoreTests (testJournalStoreCfg)
 import Data.Bifunctor (first)
@@ -42,6 +43,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Server (exportMessages)
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration
@@ -50,6 +52,11 @@ import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..),
 import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
 import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient)
+import Simplex.Messaging.Transport.WebSockets (WS)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), loadFileFingerprint)
+import Simplex.Messaging.Server.Web (attachStaticFilesWithWS)
+import Data.X509.Validation (Fingerprint (..))
 import Simplex.Messaging.Util (whenM)
 import Simplex.Messaging.Version (mkVersionRange)
 import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile)
@@ -101,6 +108,7 @@ serverTests = do
   describe "Short links" $ do
     testInvQueueLinkData
     testContactQueueLinkData
+  describe "WebSocket and TLS on same port" testWebSocketAndTLS
 
 pattern Resp :: CorrId -> QueueId -> BrokerMsg -> Transmission (Either ErrorType BrokerMsg)
 pattern Resp corrId queueId command <- (corrId, queueId, Right command)
@@ -137,8 +145,11 @@ serviceSignSendRecv h pk serviceKey t = do
 
 signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
 signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
+  putStrLn "signSendRecv_: encoding"
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
+  putStrLn "signSendRecv_: sending"
   Right () <- tPut1 h (authorize tForAuth, tToSend)
+  putStrLn "signSendRecv_: receiving"
   liftIO $ tGetClient h
   where
     authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
@@ -1484,3 +1495,54 @@ serverSyntaxTests (ATransport t) = do
       (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) ->
       Expectation
     command >#> response = withFrozenCallStack $ smpServerTest t command `shouldReturn` response
+
+-- | Test that both native TLS and WebSocket clients can connect to the same port.
+-- Native TLS uses useSNI=False, WebSocket uses useSNI=True for routing.
+testWebSocketAndTLS :: SpecWith (ASrvTransport, AStoreType)
+testWebSocketAndTLS =
+  it "native TLS and WebSocket clients work on same port" $ \(_t, msType) -> do
+    Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
+    let httpKeyHash = C.KeyHash fpHTTP
+    attachStaticFilesWithWS "tests/fixtures" $ \attachHTTP ->
+      withSmpServerConfig (cfgWebOn msType testPort) (Just attachHTTP) $ \_ -> do
+      putStrLn "1 - server started"
+      g <- C.newRandom
+      (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+      (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+      putStrLn "2 - keys generated"
+
+      -- Connect via native TLS (useSNI=False, default) and create a queue
+      putStrLn "3 - before native TLS connect"
+      (sId, rId, srvDh) <- testSMPClient @TLS $ \rh -> do
+        Resp "1" _ (Ids rId sId srvDh) <- signSendRecv rh rKey ("1", NoEntity, New rPub dhPub)
+        Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, KEY sPub)
+        pure (sId, rId, srvDh)
+      let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
+      putStrLn "4 - after native TLS connect"
+
+      -- Connect via WebSocket (useSNI=True) and send a message
+      putStrLn "5 - before WebSocket connect"
+      Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
+      let wsTcConfig = defaultTransportClientConfig {useSNI = True} :: TransportClientConfig
+      runTLSTransportClient defaultSupportedParamsHTTPS Nothing wsTcConfig Nothing useHost testPort (Just httpKeyHash) $ \(h :: WS 'TClient) -> do
+        putStrLn "5a - got WS handle"
+        runExceptT (smpClientHandshake h Nothing testKeyHash supportedClientSMPRelayVRange False Nothing) >>= \case
+          Right sh -> do
+            putStrLn "5b - SMP handshake done"
+            let msg = "hello from websocket"
+            Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND msg)
+            putStrLn "5c - message sent"
+          Left e -> do
+            putStrLn $ "5b - SMP handshake failed: " ++ show e
+            error $ show e
+      putStrLn "6 - after WebSocket connect"
+
+      -- Verify message received via native TLS
+      putStrLn "7 - before verify"
+      testSMPClient @TLS $ \rh -> do
+        (Resp "4" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("4", rId, SUB)
+        dec mId msg `shouldBe` Right "hello from websocket"
+        Resp "5" _ OK <- signSendRecv rh rKey ("5", rId, ACK mId)
+        pure ()
+      putStrLn "8 - done"

From 8891372242079f6f57cc6468877a5ddcf463e53f Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 16 Mar 2026 22:34:21 +0000
Subject: [PATCH 2/5] remove logs

---
 src/Simplex/Messaging/Server.hs               | 49 ++++++-------------
 src/Simplex/Messaging/Transport/WebSockets.hs | 12 +----
 tests/ServerTests.hs                          | 24 ++-------
 3 files changed, 20 insertions(+), 65 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index a9c19e20c..2ad7a5066 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -216,28 +216,19 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
       srvSignKey <- either fail pure $ C.x509ToPrivate' srvKey
       env <- ask
-      liftIO $ do
-        putStrLn $ "SERVER: httpCreds_=" ++ show (isJust httpCreds_) ++ " attachHTTP_=" ++ show (isJust attachHTTP_) ++ " addHTTP=" ++ show addHTTP
-        case (httpCreds_, attachHTTP_) of
-          (Just httpCreds, Just attachHTTP) | addHTTP -> do
-            putStrLn "SERVER: using combinedCreds branch"
-            runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
-              case cast h of
-                Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> do
-                  putStrLn "SERVER: SNI connection, handing to attachHTTP"
-                  labelMyThread "https client"
-                  let wsHandler = Just $ \ws -> do
-                        putStrLn "SERVER: wsHandler called"
-                        runClient srvCert srvSignKey (TProxy :: TProxy WS 'TServer) ws `runReaderT` env
-                  attachHTTP s tlsContext wsHandler
-                _ -> do
-                  putStrLn "SERVER: non-SNI connection, running SMP client"
-                  runClient srvCert srvSignKey t h `runReaderT` env
-            where
-              combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
-          _ -> do
-            putStrLn "SERVER: using smpCreds only branch"
-            runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
+      liftIO $ case (httpCreds_, attachHTTP_) of
+        (Just httpCreds, Just attachHTTP) | addHTTP ->
+          runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
+            case cast h of
+              Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> do
+                labelMyThread "https client"
+                let wsHandler = Just $ \ws -> runClient srvCert srvSignKey (TProxy :: TProxy WS 'TServer) ws `runReaderT` env
+                attachHTTP s tlsContext wsHandler
+              _ -> runClient srvCert srvSignKey t h `runReaderT` env
+          where
+            combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
+        _ ->
+          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
 
     sigIntHandlerThread :: M s ()
     sigIntHandlerThread = do
@@ -747,11 +738,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
       labelMyThread $ "smp handshake for " <> transportName tp
       liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange $ getClientService ms g idSize) >>= \case
-        Just (Right th) -> do
-          liftIO $ putStrLn "SERVER: SMP handshake completed, running client transport"
-          runClientTransport th
-        Just (Left e) -> liftIO $ putStrLn $ "SERVER: SMP handshake failed: " ++ show e
-        Nothing -> liftIO $ putStrLn "SERVER: SMP handshake timed out"
+        Just (Right th) -> runClientTransport th
+        _ -> pure ()
 
     getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId
     getClientService ms g idSize role cert fp = do
@@ -1156,17 +1144,13 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
   sa <- asks serverActive
   stats <- asks serverStats
   liftIO $ forever $ do
-    putStrLn "SERVER receive: waiting for command"
     ts <- tGetServer h
-    putStrLn "SERVER receive: got command"
     unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
     atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
     let (es, ts') = partitionEithers $ L.toList ts
         errs = map (second ERR) es
-    putStrLn $ "SERVER receive: errors=" ++ show (length es) ++ " commands=" ++ show (length ts')
     errs' <- case ts' of
       (_, _, (_, _, Cmd p cmd)) : rest -> do
-        putStrLn $ "SERVER receive: verifying command"
         let service = peerClientService =<< thAuth
         (errs', cmds) <- partitionEithers <$> case batchParty p of
           Just Dict | not (null rest) && all (sameParty p) ts'-> do
@@ -1229,11 +1213,8 @@ sendMsg th c@Client {msgQ, clientTHParams = THandleParams {sessionId}} = do
 
 tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
 tSend th Client {sndActiveAt} ts = do
-  tid <- myThreadId
-  putStrLn $ "SERVER tSend [" ++ show tid ++ "]: sending " ++ show (length ts) ++ " transmissions"
   withMVar th $ \h@THandle {params} ->
     void . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
-  putStrLn $ "SERVER tSend [" ++ show tid ++ "]: sent"
   atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
 
 disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs
index 411880ba4..3ab213dcd 100644
--- a/src/Simplex/Messaging/Transport/WebSockets.hs
+++ b/src/Simplex/Messaging/Transport/WebSockets.hs
@@ -9,7 +9,6 @@
 
 module Simplex.Messaging.Transport.WebSockets (WS (..)) where
 
-import Control.Concurrent (myThreadId)
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -72,19 +71,13 @@ instance Transport WS where
 
   cGet :: WS p -> Int -> IO ByteString
   cGet c n = do
-    tid <- myThreadId
-    putStrLn $ "WS cGet [" ++ show tid ++ "]: expecting " ++ show n ++ " bytes"
     s <- receiveData (wsConnection c)
-    putStrLn $ "WS cGet [" ++ show tid ++ "]: received " ++ show (B.length s) ++ " bytes"
     if B.length s == n
       then pure s
       else E.throwIO TEBadBlock
 
   cPut :: WS p -> ByteString -> IO ()
-  cPut c s = do
-    tid <- myThreadId
-    putStrLn $ "WS cPut [" ++ show tid ++ "]: sending " ++ show (B.length s) ++ " bytes"
-    sendBinaryData (wsConnection c) s
+  cPut = sendBinaryData . wsConnection
 
   getLn :: WS p -> IO ByteString
   getLn c = do
@@ -97,11 +90,8 @@ getWS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateC
 getWS cfg wsCertSent wsPeerCert cxt = withTlsUnique @WS @p cxt connectWS
   where
     connectWS tlsUniq = do
-      putStrLn "getWS: creating stream"
       s <- makeTLSContextStream cxt
-      putStrLn "getWS: connecting peer"
       wsConnection <- connectPeer s
-      putStrLn "getWS: connected"
       wsALPN <- T.getNegotiatedProtocol cxt
       pure $ WS {tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsCertSent, wsPeerCert}
     connectPeer :: Stream -> IO Connection
diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs
index 9e1662667..30d0f359d 100644
--- a/tests/ServerTests.hs
+++ b/tests/ServerTests.hs
@@ -145,11 +145,8 @@ serviceSignSendRecv h pk serviceKey t = do
 
 signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
 signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
-  putStrLn "signSendRecv_: encoding"
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
-  putStrLn "signSendRecv_: sending"
   Right () <- tPut1 h (authorize tForAuth, tToSend)
-  putStrLn "signSendRecv_: receiving"
   liftIO $ tGetClient h
   where
     authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
@@ -1505,44 +1502,31 @@ testWebSocketAndTLS =
     let httpKeyHash = C.KeyHash fpHTTP
     attachStaticFilesWithWS "tests/fixtures" $ \attachHTTP ->
       withSmpServerConfig (cfgWebOn msType testPort) (Just attachHTTP) $ \_ -> do
-      putStrLn "1 - server started"
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      putStrLn "2 - keys generated"
 
       -- Connect via native TLS (useSNI=False, default) and create a queue
-      putStrLn "3 - before native TLS connect"
       (sId, rId, srvDh) <- testSMPClient @TLS $ \rh -> do
         Resp "1" _ (Ids rId sId srvDh) <- signSendRecv rh rKey ("1", NoEntity, New rPub dhPub)
         Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, KEY sPub)
         pure (sId, rId, srvDh)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      putStrLn "4 - after native TLS connect"
 
       -- Connect via WebSocket (useSNI=True) and send a message
-      putStrLn "5 - before WebSocket connect"
       Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
       let wsTcConfig = defaultTransportClientConfig {useSNI = True} :: TransportClientConfig
-      runTLSTransportClient defaultSupportedParamsHTTPS Nothing wsTcConfig Nothing useHost testPort (Just httpKeyHash) $ \(h :: WS 'TClient) -> do
-        putStrLn "5a - got WS handle"
+      runTLSTransportClient defaultSupportedParamsHTTPS Nothing wsTcConfig Nothing useHost testPort (Just httpKeyHash) $ \(h :: WS 'TClient) ->
         runExceptT (smpClientHandshake h Nothing testKeyHash supportedClientSMPRelayVRange False Nothing) >>= \case
           Right sh -> do
-            putStrLn "5b - SMP handshake done"
-            let msg = "hello from websocket"
-            Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND msg)
-            putStrLn "5c - message sent"
-          Left e -> do
-            putStrLn $ "5b - SMP handshake failed: " ++ show e
-            error $ show e
-      putStrLn "6 - after WebSocket connect"
+            Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND "hello from websocket")
+            pure ()
+          Left e -> error $ show e
 
       -- Verify message received via native TLS
-      putStrLn "7 - before verify"
       testSMPClient @TLS $ \rh -> do
         (Resp "4" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("4", rId, SUB)
         dec mId msg `shouldBe` Right "hello from websocket"
         Resp "5" _ OK <- signSendRecv rh rKey ("5", rId, ACK mId)
         pure ()
-      putStrLn "8 - done"

From cbec5a2608c5323286e6dbd39ea350a2484baaa8 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 16 Mar 2026 22:43:17 +0000
Subject: [PATCH 3/5] diff

---
 src/Simplex/Messaging/Server.hs | 12 ++----------
 1 file changed, 2 insertions(+), 10 deletions(-)

diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 2ad7a5066..5cc1eec1f 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -162,13 +162,7 @@ runSMPServerBlocking :: MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe
 runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpServer started cfg attachHTTP_)
 
 type M s a = ReaderT (Env s) IO a
-
--- | Callback to handle HTTP/WebSocket connections on TLS ports with SNI.
--- When a client connects with SNI (browser), this handler is called.
--- The WS handler is provided by the server for WebSocket upgrade support.
 type AttachHTTP = Socket -> TLS.Context -> Maybe WSHandler -> IO ()
-
--- | Handler for WebSocket connections (SMP over WebSocket)
 type WSHandler = WS 'TServer -> IO ()
 
 -- actions used in serverThread to reduce STM transaction scope
@@ -220,13 +214,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
         (Just httpCreds, Just attachHTTP) | addHTTP ->
           runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
             case cast h of
-              Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> do
-                labelMyThread "https client"
-                let wsHandler = Just $ \ws -> runClient srvCert srvSignKey (TProxy :: TProxy WS 'TServer) ws `runReaderT` env
-                attachHTTP s tlsContext wsHandler
+              Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext wsHandler
               _ -> runClient srvCert srvSignKey t h `runReaderT` env
           where
             combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
+            wsHandler = Just $ \ws -> runClient srvCert srvSignKey (TProxy :: TProxy WS 'TServer) ws `runReaderT` env
         _ ->
           runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
 

From edba6ece4a463ad08297bdcec57ee9704c52057f Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 16 Mar 2026 23:33:57 +0000
Subject: [PATCH 4/5] fix

---
 src/Simplex/Messaging/Server/Web.hs | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Server/Web.hs b/src/Simplex/Messaging/Server/Web.hs
index 8c8d1ae78..e915d903e 100644
--- a/src/Simplex/Messaging/Server/Web.hs
+++ b/src/Simplex/Messaging/Server/Web.hs
@@ -130,10 +130,9 @@ attachStaticFilesWithWS path action =
       wsALPN <- TLS.getNegotiatedProtocol cxt
       let peerCert = X.CertificateChain [] -- Client certs not used for web widget
 
-      -- Create combined WAI app: WebSocket -> SMP (if handler provided), HTTP -> static files
-      let app = case wsHandler_ of
-            Just wsHandler -> WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) (staticFiles path)
-            Nothing -> staticFiles path
+      app <- case wsHandler_ of
+        Just wsHandler -> WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) <$> staticFiles path
+        Nothing -> staticFiles path
 
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->

From 244ba3e5ec3bfd50d6dc720eb4353026b27048d1 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Mon, 16 Mar 2026 23:40:43 +0000
Subject: [PATCH 5/5] merge functions

---
 apps/smp-server/Main.hs              |  4 +-
 src/Simplex/Messaging/Server/Main.hs |  6 +--
 src/Simplex/Messaging/Server/Web.hs  | 69 ++++++----------------------
 tests/CLITests.hs                    |  4 +-
 tests/ServerTests.hs                 |  4 +-
 5 files changed, 22 insertions(+), 65 deletions(-)

diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs
index 315eed4f2..7be11d2dd 100644
--- a/apps/smp-server/Main.hs
+++ b/apps/smp-server/Main.hs
@@ -3,7 +3,7 @@ module Main where
 import Control.Logger.Simple
 import Simplex.Messaging.Server.CLI (getEnvPath)
 import Simplex.Messaging.Server.Main (smpServerCLI_)
-import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFilesWithWS)
+import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticAndWS)
 import SMPWeb (smpGenerateSite)
 
 defaultCfgPath :: FilePath
@@ -19,4 +19,4 @@ main :: IO ()
 main = do
   cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
   logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
-  withGlobalLogging logCfg $ smpServerCLI_ smpGenerateSite serveStaticFiles attachStaticFilesWithWS cfgPath logPath
+  withGlobalLogging logCfg $ smpServerCLI_ smpGenerateSite serveStaticFiles attachStaticAndWS cfgPath logPath
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index 92f0b0821..22c114ddd 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -106,7 +106,7 @@ import System.Directory (renameFile)
 #endif
 
 smpServerCLI :: FilePath -> FilePath -> IO ()
-smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")
+smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticAndWS not available")
 
 smpServerCLI_ ::
   (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
@@ -115,7 +115,7 @@ smpServerCLI_ ::
   FilePath ->
   FilePath ->
   IO ()
-smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
+smpServerCLI_ generateSite serveStaticFiles attachStaticAndWS cfgPath logPath =
   getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
     Init opts ->
       doesFileExist iniFile >>= \case
@@ -489,7 +489,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           case webStaticPath' of
             Just path | sharedHTTP -> do
               runWebServer path Nothing ServerInformation {config, information}
-              attachStaticFiles path $ \attachHTTP -> do
+              attachStaticAndWS path $ \attachHTTP -> do
                 logDebug "Allocated web server resources"
                 runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
             Just path -> do
diff --git a/src/Simplex/Messaging/Server/Web.hs b/src/Simplex/Messaging/Server/Web.hs
index e915d903e..94ad93ca5 100644
--- a/src/Simplex/Messaging/Server/Web.hs
+++ b/src/Simplex/Messaging/Server/Web.hs
@@ -9,8 +9,7 @@ module Simplex.Messaging.Server.Web
     WebHttpsParams (..),
     EmbeddedContent (..),
     serveStaticFiles,
-    attachStaticFiles,
-    attachStaticFilesWithWS,
+    attachStaticAndWS,
     serveStaticPageH2,
     generateSite,
     serverInfoSubsts,
@@ -93,47 +92,17 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
   where
     mkSettings port = W.setPort port warpSettings
 
--- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
--- This version does not support WebSocket upgrade (passes Nothing for wsHandler).
-attachStaticFiles :: FilePath -> (AttachHTTP -> IO a) -> IO a
-attachStaticFiles path action = do
-  app <- staticFiles path
-  -- Initialize global internal state for http server.
-  WI.withII warpSettings $ \ii -> do
-    action $ \socket cxt _wsHandler -> do
-      -- Initialize internal per-connection resources.
-      addr <- getPeerName socket
-      withConnection addr cxt $ \(conn, transport) ->
-        withTimeout ii conn $ \th ->
-          -- Run Warp connection handler to process HTTP requests for static files.
-          WI.serveConnection conn ii th addr transport warpSettings app
-  where
-    -- from warp-tls
-    withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
-    -- from warp
-    withTimeout ii conn =
-      bracket
-        (WI.registerKillThread (WI.timeoutManager ii) (WI.connClose conn))
-        WI.cancel
-    -- shared clean up
-    terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
-
--- | Like 'attachStaticFiles' but with WebSocket upgrade support for SMP.
--- When wsHandler is provided via AttachHTTP, WebSocket connections are handed off to it.
--- When wsHandler is Nothing, WebSocket upgrade requests are rejected (falls through to static files).
-attachStaticFilesWithWS :: FilePath -> (AttachHTTP -> IO a) -> IO a
-attachStaticFilesWithWS path action =
+attachStaticAndWS :: FilePath -> (AttachHTTP -> IO a) -> IO a
+attachStaticAndWS path action =
   WI.withII warpSettings $ \ii -> do
     action $ \socket cxt wsHandler_ -> do
-      -- Capture TLS info BEFORE Warp takes over
-      tlsUniq <- getTlsUnique cxt
-      wsALPN <- TLS.getNegotiatedProtocol cxt
-      let peerCert = X.CertificateChain [] -- Client certs not used for web widget
-
       app <- case wsHandler_ of
-        Just wsHandler -> WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) <$> staticFiles path
+        Just wsHandler -> do
+          tlsUniq <- getTlsUnique cxt
+          wsALPN <- TLS.getNegotiatedProtocol cxt
+          let peerCert = X.CertificateChain []
+          WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) <$> staticFiles path
         Nothing -> staticFiles path
-
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->
         withTimeout ii conn $ \th ->
@@ -147,40 +116,28 @@ attachStaticFilesWithWS path action =
     handleWebSocket :: WSHandler -> ByteString -> Maybe ByteString -> X.CertificateChain -> PendingConnection -> IO ()
     handleWebSocket wsHandler tlsUniq wsALPN peerCert pending = do
       wsConn <- acceptRequest pending
-      -- Create a dummy stream for the WS type. In wai-websockets context,
-      -- connection lifecycle is managed externally, so this stream just
-      -- provides the interface for closeConnection.
-      dummyStream <- makeDummyStream
+      dummyStream <- WSS.makeStream (pure Nothing) (\_ -> pure ())
       let ws = WS
-            { tlsUniq = tlsUniq,
-              wsALPN = wsALPN,
+            { tlsUniq,
+              wsALPN,
               wsStream = dummyStream,
               wsConnection = wsConn,
-              wsTransportConfig = defaultTransportConfig,
+              wsTransportConfig = TransportConfig {logTLSErrors = True, transportTimeout = Nothing},
               wsCertSent = False,
               wsPeerCert = peerCert
             }
       wsHandler ws
 
-    -- Create a minimal stream that just returns EOF on read and ignores writes.
-    -- Close is a no-op since wai-websockets manages the connection lifecycle.
-    makeDummyStream :: IO Stream
-    makeDummyStream = WSS.makeStream (pure Nothing) (\_ -> pure ())
-
-    defaultTransportConfig = TransportConfig {logTLSErrors = True, transportTimeout = Nothing}
-
-    -- Get TLS unique value (used for channel binding)
     getTlsUnique :: TLS.Context -> IO ByteString
     getTlsUnique cxt = TLS.getPeerFinished cxt >>= maybe (fail "TLS not finished") pure
 
-    -- from warp-tls (socket is actually SockAddr here, matching original pattern)
+    -- from warp-tls
     withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
     -- from warp
     withTimeout ii conn =
       bracket
         (WI.registerKillThread (WI.timeoutManager ii) (WI.connClose conn))
         WI.cancel
-    -- shared clean up
     terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
 
 warpSettings :: W.Settings
diff --git a/tests/CLITests.hs b/tests/CLITests.hs
index 661450391..5489877ad 100644
--- a/tests/CLITests.hs
+++ b/tests/CLITests.hs
@@ -31,7 +31,7 @@ import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
 import Simplex.Messaging.Transport.Server (loadFileFingerprint)
 import Simplex.Messaging.Util (catchAll_)
 import qualified SMPWeb
-import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFilesWithWS)
+import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticAndWS)
 import System.Directory (doesFileExist)
 import System.Environment (withArgs)
 import System.FilePath ((</>))
@@ -152,7 +152,7 @@ smpServerTestStatic = do
   Right ini_ <- readIniFile iniFile
   lookupValue "WEB" "https" ini_ `shouldBe` Right "5223"
 
-  let smpServerCLI' = smpServerCLI_ SMPWeb.smpGenerateSite serveStaticFiles attachStaticFilesWithWS
+  let smpServerCLI' = smpServerCLI_ SMPWeb.smpGenerateSite serveStaticFiles attachStaticAndWS
   let server = capture_ (withArgs ["start"] $ smpServerCLI' cfgPath logPath `catchAny` print)
   bracket (async server) cancel $ \_t -> do
     threadDelay 1000000
diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs
index 30d0f359d..22f4af798 100644
--- a/tests/ServerTests.hs
+++ b/tests/ServerTests.hs
@@ -55,7 +55,7 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), loadFileFingerprint)
-import Simplex.Messaging.Server.Web (attachStaticFilesWithWS)
+import Simplex.Messaging.Server.Web (attachStaticAndWS)
 import Data.X509.Validation (Fingerprint (..))
 import Simplex.Messaging.Util (whenM)
 import Simplex.Messaging.Version (mkVersionRange)
@@ -1500,7 +1500,7 @@ testWebSocketAndTLS =
   it "native TLS and WebSocket clients work on same port" $ \(_t, msType) -> do
     Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
     let httpKeyHash = C.KeyHash fpHTTP
-    attachStaticFilesWithWS "tests/fixtures" $ \attachHTTP ->
+    attachStaticAndWS "tests/fixtures" $ \attachHTTP ->
       withSmpServerConfig (cfgWebOn msType testPort) (Just attachHTTP) $ \_ -> do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g