merge functions

Author: evgeny-simplex

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

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

src/Simplex/Messaging/Server/Web.hs

@@ -9,8 +9,7 @@ module Simplex.Messaging.Server.Web
     WebHttpsParams (..),
     EmbeddedContent (..),
     serveStaticFiles,
-    attachStaticFiles,
-    attachStaticFilesWithWS,
+    attachStaticAndWS,
     serveStaticPageH2,
     generateSite,
     serverInfoSubsts,
@@ -92,46 +91,17 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
 
 -- | 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 =
-  -- 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
-    app = staticFiles path
-    -- 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
-
-      -- 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 -> do
+          tlsUniq <- getTlsUnique cxt
+          wsALPN <- TLS.getNegotiatedProtocol cxt
+          let peerCert = X.CertificateChain []
+          pure $ WaiWS.websocketsOr wsOpts (handleWebSocket wsHandler tlsUniq wsALPN peerCert) (staticFiles path)
+        Nothing -> pure $ staticFiles path
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->
         withTimeout ii conn $ \th ->
@@ -145,33 +115,22 @@ 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 =

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

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