xftp server changes to support web slients: SNI-based certificate choice, CORS headers, OPTIONS request

contributing/CODE.md

@@ -8,6 +8,10 @@ When designing code and planning implementations:
 - Apply adversarial thinking, and consider what may happen if one of the communicating parties is malicious.
 - Formulate an explicit threat model for each change - who can do which undesirable things and under which circumstances.
 
+## Code Quality Standards
+
+Haskell client and server code serves as system specification, not just implementation — we use type-driven design to reflect the business domain in types. Quality, conciseness, and clarity of Haskell code are critical.
+
 ## Code Style, Formatting and Approaches
 
 The project uses **fourmolu** for Haskell code formatting. Configuration is in `fourmolu.yaml`.

rfcs/2026-01-31-web-xftp-server-changes.md

@@ -0,0 +1,154 @@
+# XFTP Server: SNI, CORS, and Web Support
+
+Implementation details for Phase 3 of `rfcs/2026-01-30-send-file-page.md` (sections 6.1-6.4).
+
+## 1. Overview
+
+The XFTP server is extended to support web browser clients by:
+
+1. **SNI-based TLS certificate switching** — Present a CA-issued web certificate (e.g., Let's Encrypt) to browsers, while continuing to present the self-signed XFTP identity certificate to native clients.
+2. **CORS headers** — Add CORS response headers on SNI connections so browsers allow cross-origin XFTP requests.
+3. **Configuration** — `[WEB]` INI section for HTTPS cert/key paths; opt-in (commented out by default).
+
+Web handshake (challenge-response identity proof, §6.3 of parent RFC) is not yet implemented and will be added separately.
+
+## 2. SNI Certificate Switching
+
+### 2.1 Reusing the SMP Pattern
+
+The SMP server already implements SNI-based certificate switching via `TLSServerCredential` and `runTransportServerState_` (see `rfcs/2024-09-15-shared-port.md`). The XFTP server applies the same pattern with one key difference: both native and web XFTP clients use HTTP/2 transport, whereas SMP switches between raw SMP protocol and HTTP entirely.
+
+### 2.2 Approach
+
+When `httpServerCreds` is configured, the XFTP server bypasses `runHTTP2Server` and uses `runTransportServerState_` directly to obtain the per-connection `sniUsed` flag. It then sets up HTTP/2 manually on each TLS connection using `withHTTP2` (same internals as `runHTTP2ServerWith_`). The `sniUsed` flag is captured in the closure and shared by all HTTP/2 requests on that connection.
+
+When `httpServerCreds` is absent, the existing `runHTTP2Server` path is unchanged.
+
+```
+Native client (no SNI)  ──TLS──> XFTP identity cert ──HTTP/2──> processRequest (no CORS)
+Browser client (SNI)    ──TLS──> Web CA cert        ──HTTP/2──> processRequest (+ CORS)
+```
+
+### 2.3 Certificate Chain
+
+The web certificate file (e.g., `web.crt`) must contain the full chain: leaf certificate followed by the signing CA certificate. `loadServerCredential` uses `T.credentialLoadX509Chain` which reads all PEM blocks from the file.
+
+The client validates the chain by comparing `idCert` fingerprint (the CA cert, second in the 2-cert chain) against the known `keyHash`. This is the same validation as for XFTP identity certificates — the CA that signed the web cert must match the XFTP server's identity.
+
+## 3. CORS Support
+
+### 3.1 Design
+
+CORS headers are only added when both conditions are true:
+- `addCORSHeaders` is `True` in `TransportServerConfig` (set in XFTP `Main.hs`)
+- `sniUsed` is `True` for the current TLS connection
+
+This ensures native clients never see CORS headers.
+
+### 3.2 Response Headers
+
+All POST responses on SNI connections include:
+```
+Access-Control-Allow-Origin: *
+Access-Control-Expose-Headers: *
+```
+
+### 3.3 OPTIONS Preflight
+
+OPTIONS requests are intercepted at the HTTP/2 dispatch level, before `processRequest`. This is necessary because `processRequest` rejects bodies that don't match `xftpBlockSize`.
+
+Preflight response:
+```
+HTTP/2 200
+Access-Control-Allow-Origin: *
+Access-Control-Allow-Methods: POST, OPTIONS
+Access-Control-Allow-Headers: *
+Access-Control-Max-Age: 86400
+```
+
+### 3.4 Security
+
+`Access-Control-Allow-Origin: *` is safe because:
+- All XFTP commands require Ed25519 authentication (per-chunk keys from file description).
+- No cookies or browser credentials are involved.
+- File content is end-to-end encrypted.
+
+## 4. Configuration
+
+### 4.1 INI Template
+
+```ini
+[WEB]
+# cert: /etc/opt/simplex-xftp/web.crt
+# key: /etc/opt/simplex-xftp/web.key
+```
+
+Commented out by default — web support is opt-in.
+
+### 4.2 Behavior
+
+- `[WEB]` section not configured: silently ignored, server operates normally for native clients only.
+- `[WEB]` section configured with valid cert/key paths: SNI + CORS enabled.
+- `[WEB]` section configured with missing cert files: warning + continue (non-fatal, unlike SMP where it is fatal).
+
+## 5. Files Modified
+
+### 5.1 `src/Simplex/Messaging/Transport/Server.hs`
+
+Added `addCORSHeaders :: Bool` field to `TransportServerConfig`. Updated `mkTransportServerConfig` to accept the new parameter. All existing SMP call sites pass `False`.
+
+### 5.2 `src/Simplex/Messaging/Transport/HTTP2/Server.hs`
+
+- Extracted `expireInactiveClient` from `runHTTP2ServerWith_`'s `where` clause to a module-level function.
+- Parameterized `runHTTP2ServerWith_`: setup type changed from `((TLS p -> IO ()) -> a)` to `(((Bool, TLS p) -> IO ()) -> a)`, callback from `HTTP2ServerFunc` to `Bool -> HTTP2ServerFunc`. The `Bool` is the per-connection `sniUsed` flag, threaded through `H.run` to the callback.
+- Extended `runHTTP2Server` with `Maybe T.Credential` parameter for SNI web certificate. Its setup uses `runTransportServerState_` with `TLSServerCredential`, which naturally provides `(sniUsed, tls)` pairs matching the new `runHTTP2ServerWith_` setup type.
+- Adapted `runHTTP2ServerWith` (client-side HTTP/2, no SNI): wraps its setup to inject `(False, tls)` and its callback with `const`.
+- Updated `getHTTP2Server` (test helper) to pass `Nothing` for httpCreds.
+
+### 5.3 `src/Simplex/FileTransfer/Server/Env.hs`
+
+- Added `httpCredentials :: Maybe ServerCredentials` to `XFTPServerConfig`.
+- Added `httpServerCreds :: Maybe T.Credential` to `XFTPEnv`.
+- `newXFTPServerEnv` loads HTTP credentials when configured.
+
+### 5.4 `src/Simplex/FileTransfer/Server/Main.hs`
+
+- Added `[WEB]` section to INI template.
+- Added `httpCredentials` parsing from INI `[WEB]` section (`cert` and `key` fields).
+- Set `addCORSHeaders = isJust httpCredentials_` in transport config (conditional on web cert presence).
+
+### 5.5 `src/Simplex/FileTransfer/Server.hs`
+
+Core server changes:
+
+- `runServer` calls `runHTTP2Server` with `httpCreds_` and a `\sniUsed -> handleRequest (sniUsed && addCORSHeaders transportConfig)` callback. TLS params are `defaultSupportedParamsHTTPS` when web creds present, `defaultSupportedParams` otherwise. SNI routing, HTTP/2 setup, and client expiration are handled inside `runHTTP2Server`.
+
+- `XFTPTransportRequest` carries `addCORS :: Bool` field, threaded through to `sendXFTPResponse`.
+
+- `sendXFTPResponse` conditionally includes CORS headers based on `addCORS`.
+
+- OPTIONS requests on SNI connections return CORS preflight headers before reaching `processRequest`.
+
+- Helper functions: `corsHeaders` (response headers), `corsPreflightHeaders` (preflight headers).
+
+### 5.6 `tests/XFTPClient.hs`
+
+- Added `httpCredentials = Nothing` to `testXFTPServerConfig`.
+- Added `testXFTPServerConfigSNI` with web cert config and `addCORSHeaders = True`.
+- Added `withXFTPServerSNI` helper.
+
+### 5.7 `tests/XFTPServerTests.hs`
+
+Added SNI and CORS tests as a subsection within `xftpServerTests` (6 tests):
+
+1. **SNI cert selection** — Connect with SNI + `h2` ALPN, verify RSA web certificate is presented.
+2. **Non-SNI cert selection** — Connect without SNI + `xftp/1` ALPN, verify Ed448 XFTP certificate is presented.
+3. **CORS headers** — SNI POST request includes `Access-Control-Allow-Origin: *` and `Access-Control-Expose-Headers: *`.
+4. **OPTIONS preflight** — SNI OPTIONS request returns all CORS preflight headers.
+5. **No CORS without SNI** — Non-SNI POST request has no CORS headers.
+6. **File chunk delivery** — Full XFTP file chunk upload/download through SNI-enabled server verifying no regression.
+
+## 6. Remaining Work
+
+- **Web handshake** (§6.3 of parent RFC): Challenge-response identity proof for SNI connections. The server detects web clients via the `sniUsed` flag and expects a 32-byte challenge in the first POST body (non-empty, unlike standard handshake). Response includes full cert chain + signature over `(challenge ++ sessionId)`.
+- **Static page serving** (§6.5 of parent RFC): Optional serving of the web page HTML/JS bundle on GET requests.

simplexmq.cabal

@@ -527,6 +527,7 @@ test-suite simplexmq-test
     , async
     , base64-bytestring
     , bytestring
+    , case-insensitive ==1.2.*
     , containers
     , crypton
     , crypton-x509

src/Simplex/FileTransfer/Server.hs

@@ -63,12 +63,12 @@ import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
-import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runLocalTCPServer)
+import Simplex.Messaging.Transport.HTTP2.Server (runHTTP2Server)
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..), runLocalTCPServer)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Environment (lookupEnv)
@@ -89,9 +89,23 @@ data XFTPTransportRequest = XFTPTransportRequest
   { thParams :: THandleParamsXFTP 'TServer,
     reqBody :: HTTP2Body,
     request :: H.Request,
-    sendResponse :: H.Response -> IO ()
+    sendResponse :: H.Response -> IO (),
+    addCORS :: Bool
   }
 
+corsHeaders :: Bool -> [N.Header]
+corsHeaders addCORS
+  | addCORS = [("Access-Control-Allow-Origin", "*"), ("Access-Control-Expose-Headers", "*")]
+  | otherwise = []
+
+corsPreflightHeaders :: [N.Header]
+corsPreflightHeaders =
+  [ ("Access-Control-Allow-Origin", "*"),
+    ("Access-Control-Allow-Methods", "POST, OPTIONS"),
+    ("Access-Control-Allow-Headers", "*"),
+    ("Access-Control-Max-Age", "86400")
+  ]
+
 runXFTPServer :: XFTPServerConfig -> IO ()
 runXFTPServer cfg = do
   started <- newEmptyTMVarIO
@@ -120,27 +134,33 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     runServer :: M ()
     runServer = do
       srvCreds@(chain, pk) <- asks tlsServerCreds
+      httpCreds_ <- asks httpServerCreds
       signKey <- liftIO $ case C.x509ToPrivate' pk of
         Right pk' -> pure pk'
         Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
       env <- ask
       sessions <- liftIO TM.emptyIO
       let cleanup sessionId = atomically $ TM.delete sessionId sessions
-      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
-        reqBody <- getHTTP2Body r xftpBlockSize
-        let v = VersionXFTP 1
-            thServerVRange = versionToRange v
-            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
-            req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
-        flip runReaderT env $ case sessionALPN of
-          Nothing -> processRequest req0
-          Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
-            xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
-              Nothing -> pure () -- handshake response sent
-              Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
-          _ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
+          srvParams = if isJust httpCreds_ then defaultSupportedParamsHTTPS else defaultSupportedParams
+      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize srvParams srvCreds httpCreds_ transportConfig inactiveClientExpiration cleanup $ \sniUsed sessionId sessionALPN r sendResponse -> do
+        let addCORS' = sniUsed && addCORSHeaders transportConfig
+        if addCORS' && H.requestMethod r == Just "OPTIONS"
+          then sendResponse $ H.responseNoBody N.ok200 corsPreflightHeaders
+          else do
+            reqBody <- getHTTP2Body r xftpBlockSize
+            let v = VersionXFTP 1
+                thServerVRange = versionToRange v
+                thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
+                req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, addCORS = addCORS'}
+            flip runReaderT env $ case sessionALPN of
+              Nothing -> processRequest req0
+              Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
+                xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
+                  Nothing -> pure ()
+                  Just thParams -> processRequest req0 {thParams}
+              _ -> liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS')
     xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer))
-    xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
+    xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse, addCORS} = do
       s <- atomically $ TM.lookup sessionId sessions
       r <- runExceptT $ case s of
         Nothing -> processHello
@@ -158,7 +178,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
 #ifdef slow_servers
           lift randomDelay
 #endif
-          liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs
+          liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs
           pure Nothing
         processClientHandshake pk = do
           unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE
@@ -174,13 +194,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
 #ifdef slow_servers
               lift randomDelay
 #endif
-              liftIO . sendResponse $ H.responseNoBody N.ok200 []
+              liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS)
               pure Nothing
             Nothing -> throwE HANDSHAKE
         sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
         sendError err = do
           runExceptT (encodeXftp err) >>= \case
-            Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs
+            Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) bs
             Left _ -> logError $ "Error encoding handshake error: " <> tshow err
           pure Nothing
         encodeXftp :: Encoding a => a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
@@ -346,7 +366,7 @@ data ServerFile = ServerFile
   }
 
 processRequest :: XFTPTransportRequest -> M ()
-processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
+processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse, addCORS}
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
   | otherwise =
       case xftpDecodeTServer thParams bodyHead of
@@ -365,7 +385,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
 #ifdef slow_servers
       randomDelay
 #endif
-      liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
+      liftIO $ sendResponse $ H.responseStreaming N.ok200 (corsHeaders addCORS) $ streamBody t_
       where
         streamBody t_ send done = do
           case t_ of

src/Simplex/FileTransfer/Server/Env.hs

@@ -57,6 +57,7 @@ data XFTPServerConfig = XFTPServerConfig
     -- | time after which inactive clients can be disconnected and check interval, seconds
     inactiveClientExpiration :: Maybe ExpirationConfig,
     xftpCredentials :: ServerCredentials,
+    httpCredentials :: Maybe ServerCredentials,
     -- | XFTP client-server protocol version range
     xftpServerVRange :: VersionRangeXFTP,
     -- stats config - see SMP server config
@@ -84,6 +85,7 @@ data XFTPEnv = XFTPEnv
     random :: TVar ChaChaDRG,
     serverIdentity :: C.KeyHash,
     tlsServerCreds :: T.Credential,
+    httpServerCreds :: Maybe T.Credential,
     serverStats :: FileServerStats
   }
 
@@ -98,7 +100,7 @@ defaultFileExpiration =
     }
 
 newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
-newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do
+newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials, httpCredentials} = do
   random <- C.newRandom
   store <- newFileStore
   storeLog <- mapM (`readWriteFileStore` store) storeLogFile
@@ -108,9 +110,10 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede
     logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
     when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!"
   tlsServerCreds <- loadServerCredential xftpCredentials
+  httpServerCreds <- mapM loadServerCredential httpCredentials
   Fingerprint fp <- loadFingerprint xftpCredentials
   serverStats <- newFileServerStats =<< getCurrentTime
-  pure XFTPEnv {config, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
+  pure XFTPEnv {config, store, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
 
 countUsedStorage :: M.Map k FileRec -> Int64
 countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0

src/Simplex/FileTransfer/Server/Main.hs

@@ -12,7 +12,7 @@ import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Ini (lookupValue, readIniFile)
 import Data.Int (Int64)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
@@ -21,7 +21,7 @@ import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Description (FileSize (..))
 import Simplex.FileTransfer.Server (runXFTPServer)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
-import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes)
+import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -29,7 +29,7 @@ import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.HTTP2 (httpALPN)
-import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
+import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath (combine)
@@ -124,6 +124,10 @@ xftpServerCLI cfgPath logPath = do
                \disconnect: off\n"
             <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
             <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
+            <> "\n\
+               \[WEB]\n\
+               \# cert: /etc/opt/simplex-xftp/web.crt\n\
+               \# key: /etc/opt/simplex-xftp/web.key\n"
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -155,6 +159,17 @@ xftpServerCLI cfgPath logPath = do
                 else "NOT allowed."
           putStrLn $ "Listening on port " <> xftpPort <> "..."
 
+        httpCredentials_ =
+          eitherToMaybe $ do
+            cert <- T.unpack <$> lookupValue "WEB" "cert" ini
+            key <- T.unpack <$> lookupValue "WEB" "key" ini
+            pure
+              ServerCredentials
+                { caCertificateFile = Nothing,
+                  certificateFile = cert,
+                  privateKeyFile = key
+                }
+
         serverConfig =
           XFTPServerConfig
             { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
@@ -186,6 +201,7 @@ xftpServerCLI cfgPath logPath = do
                     privateKeyFile = c serverKeyFile,
                     certificateFile = c serverCrtFile
                   },
+              httpCredentials = httpCredentials_,
               xftpServerVRange = supportedFileServerVRange,
               logStatsInterval = logStats $> 86400, -- seconds
               logStatsStartTime = 0, -- seconds from 00:00 UTC
@@ -194,10 +210,12 @@ xftpServerCLI cfgPath logPath = do
               prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
               prometheusMetricsFile = combine logPath "xftp-server-metrics.txt",
               transportConfig =
-                mkTransportServerConfig
-                  (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
-                  (Just $ alpnSupportedXFTPhandshakes <> httpALPN)
-                  False,
+                let cfg =
+                      mkTransportServerConfig
+                        (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
+                        (Just $ alpnSupportedXFTPhandshakes <> httpALPN)
+                        False
+                 in cfg {addCORSHeaders = isJust httpCredentials_},
               responseDelay = 0
             }
 
@@ -229,11 +247,14 @@ cliCommandP cfgPath logPath iniFile =
     initP :: Parser InitOptions
     initP = do
       enableStoreLog <-
-        flag' False
+        flag'
+          False
           ( long "disable-store-log"
               <> help "Disable store log for persistence (enabled by default)"
           )
-          <|> flag True True
+          <|> flag
+            True
+            True
             ( long "store-log"
                 <> short 'l'
                 <> help "Enable store log for persistence (DEPRECATED, enabled by default)"

src/Simplex/Messaging/Transport/HTTP2/Server.hs

@@ -16,7 +16,7 @@ import Numeric.Natural (Natural)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq)
 import Simplex.Messaging.Transport.HTTP2
-import Simplex.Messaging.Transport.Server (ServerCredentials, TransportServerConfig (..), loadServerCredential, runTransportServer)
+import Simplex.Messaging.Transport.Server (SNICredentialUsed, ServerCredentials, TLSServerCredential (..), TransportServerConfig (..), loadServerCredential, newSocketState, runTransportServerState_)
 import Simplex.Messaging.Util (threadDelay')
 import UnliftIO (finally)
 import UnliftIO.Concurrent (forkIO, killThread)
@@ -54,7 +54,7 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize serverSupported srvCreds transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize serverSupported srvCreds Nothing transportConfig Nothing (const $ pure ()) $ \_sniUsed sessionId sessionALPN r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -63,24 +63,33 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize srvSupported srvCreds transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> (SNICredentialUsed -> HTTP2ServerFunc) -> IO ()
+runHTTP2Server started port bufferSize srvSupported srvCreds httpCreds_ transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
   where
-    setup = runTransportServer started port srvSupported srvCreds transportConfig
+    setup handler = do
+      ss <- newSocketState
+      let combinedCreds = TLSServerCredential {credential = srvCreds, sniCredential = httpCreds_}
+      runTransportServerState_ ss started port srvSupported combinedCreds transportConfig $ \_ -> handler
 
 -- HTTP2 server can be run on both client and server TLS connections.
 runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ())
+runHTTP2ServerWith bufferSize tlsSetup http2Server =
+  runHTTP2ServerWith_
+    Nothing
+    (\_sessId -> pure ())
+    bufferSize
+    (\handler -> tlsSetup $ \tls -> handler (False, tls))
+    (const http2Server)
 
-runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \tls -> do
+runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> (((SNICredentialUsed, TLS p) -> IO ()) -> a) -> (SNICredentialUsed -> HTTP2ServerFunc) -> a
+runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \(sniUsed, tls) -> do
   activeAt <- newTVarIO =<< getSystemTime
   tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_
-  withHTTP2 bufferSize (run tls activeAt) (clientFinished $ tlsUniq tls) tls `finally` mapM_ killThread tid_
+  withHTTP2 bufferSize (run sniUsed tls activeAt) (clientFinished $ tlsUniq tls) tls `finally` mapM_ killThread tid_
   where
-    run tls activeAt cfg = H.run cfg $ \req _aux sendResp -> do
+    run sniUsed tls activeAt cfg = H.run cfg $ \req _aux sendResp -> do
       getSystemTime >>= atomically . writeTVar activeAt
-      http2Server (tlsUniq tls) (tlsALPN tls) req (`sendResp` [])
+      http2Server sniUsed (tlsUniq tls) (tlsALPN tls) req (`sendResp` [])
     expireInactiveClient tls activeAt expCfg = loop
       where
         loop = do

src/Simplex/Messaging/Transport/Server.hs

@@ -11,6 +11,7 @@ module Simplex.Messaging.Transport.Server
   ( TransportServerConfig (..),
     ServerCredentials (..),
     TLSServerCredential (..),
+    SNICredentialUsed,
     AddHTTP,
     mkTransportServerConfig,
     runTransportServerState,
@@ -62,6 +63,7 @@ data TransportServerConfig = TransportServerConfig
   { logTLSErrors :: Bool,
     serverALPN :: Maybe [ALPN],
     askClientCert :: Bool,
+    addCORSHeaders :: Bool,
     tlsSetupTimeout :: Int,
     transportTimeout :: Int
   }
@@ -91,6 +93,7 @@ mkTransportServerConfig logTLSErrors serverALPN askClientCert =
     { logTLSErrors,
       serverALPN,
       askClientCert,
+      addCORSHeaders = False,
       tlsSetupTimeout = 60000000,
       transportTimeout = 40000000
     }
@@ -274,9 +277,10 @@ paramsAskClientCert clientCert params =
     { T.serverWantClientCert = True,
       T.serverHooks =
         (T.serverHooks params)
-          { T.onClientCertificate = \cc -> validateClientCertificate cc >>= \case
-              Just reason -> T.CertificateUsageReject reason <$ atomically (tryPutTMVar clientCert Nothing)
-              Nothing -> T.CertificateUsageAccept <$ atomically (tryPutTMVar clientCert $ Just cc)
+          { T.onClientCertificate = \cc ->
+              validateClientCertificate cc >>= \case
+                Just reason -> T.CertificateUsageReject reason <$ atomically (tryPutTMVar clientCert Nothing)
+                Nothing -> T.CertificateUsageAccept <$ atomically (tryPutTMVar clientCert $ Just cc)
           }
     }
 

tests/XFTPClient.hs

@@ -17,6 +17,7 @@ import Simplex.FileTransfer.Server (runXFTPServerBlocking)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
 import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes)
 import Simplex.Messaging.Protocol (XFTPServer)
+import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server
 import Test.Hspec hiding (fit, it)
 
@@ -125,6 +126,7 @@ testXFTPServerConfig =
             privateKeyFile = "tests/fixtures/server.key",
             certificateFile = "tests/fixtures/server.crt"
           },
+      httpCredentials = Nothing,
       xftpServerVRange = supportedFileServerVRange,
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
@@ -148,3 +150,21 @@ testXFTPClientWith cfg client = do
   getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case
     Right c -> client c
     Left e -> error $ show e
+
+testXFTPServerConfigSNI :: XFTPServerConfig
+testXFTPServerConfigSNI =
+  testXFTPServerConfig
+    { httpCredentials =
+        Just
+          ServerCredentials
+            { caCertificateFile = Nothing,
+              privateKeyFile = "tests/fixtures/web.key",
+              certificateFile = "tests/fixtures/web.crt"
+            },
+      transportConfig =
+        (mkTransportServerConfig True (Just $ alpnSupportedXFTPhandshakes <> httpALPN) False)
+          {addCORSHeaders = True}
+    }
+
+withXFTPServerSNI :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
+withXFTPServerSNI = withXFTPServerCfg testXFTPServerConfigSNI

tests/XFTPServerTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -13,12 +14,18 @@ import Control.Exception (SomeException)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import qualified Crypto.PubKey.RSA as RSA
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.List (isInfixOf)
+import qualified Data.CaseInsensitive as CI
+import Data.List (find, isInfixOf)
 import Data.Time.Clock (getCurrentTime)
+import qualified Data.X509 as X
+import Data.X509.Validation (Fingerprint (..))
+import Network.HPACK.Token (tokenKey)
+import qualified Network.HTTP2.Client as H2
 import ServerTests (logSize)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description (kb)
@@ -30,6 +37,11 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
+import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
+import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient)
+import Simplex.Messaging.Transport.HTTP2 ()
+import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
+import Simplex.Messaging.Transport.Server (loadFileFingerprint)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
 import Test.Hspec hiding (fit, it)
@@ -39,10 +51,8 @@ import XFTPClient
 
 xftpServerTests :: Spec
 xftpServerTests =
-  before_ (createDirectoryIfMissing False xftpServerFiles)
-    . after_ (removeDirectoryRecursive xftpServerFiles)
-    . describe "XFTP file chunk delivery"
-    $ do
+  before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do
+    describe "XFTP file chunk delivery" $ do
       it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
       it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
       it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients
@@ -63,6 +73,13 @@ xftpServerTests =
         it "allowed with correct basic auth" $ testFileBasicAuth True (Just "pwd") (Just "pwd") True
         it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True
       it "should not change content for uploaded and committed files" testFileSkipCommitted
+    describe "XFTP SNI and CORS" $ do
+      it "should select web certificate when SNI is used" testSNICertSelection
+      it "should select XFTP certificate when SNI is not used" testNoSNICertSelection
+      it "should add CORS headers when SNI is used" testCORSHeaders
+      it "should respond to OPTIONS preflight with CORS headers" testCORSPreflight
+      it "should not add CORS headers without SNI" testNoCORSWithoutSNI
+      it "should upload and receive file chunk through SNI-enabled server" testFileChunkDeliverySNI
 
 chSize :: Integral a => a
 chSize = kb 128
@@ -395,3 +412,87 @@ testFileSkipCommitted =
         uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck
         downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
         liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored
+
+-- SNI and CORS tests
+
+lookupResponseHeader :: B.ByteString -> H2.Response -> Maybe B.ByteString
+lookupResponseHeader name resp =
+  snd <$> find (\(t, _) -> tokenKey t == CI.mk name) (fst $ H2.responseHeaders resp)
+
+getCerts :: TLS 'TClient -> [X.Certificate]
+getCerts tls =
+  let X.CertificateChain cc = tlsPeerCert tls
+   in map (X.signedObject . X.getSigned) cc
+
+testSNICertSelection :: Expectation
+testSNICertSelection =
+  withXFTPServerSNI $ \_ -> do
+    Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/ca.crt"
+    let caHTTP = C.KeyHash fpHTTP
+        cfg = defaultTransportClientConfig {clientALPN = Just ["h2"], useSNI = True}
+    runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfg Nothing "localhost" xftpTestPort (Just caHTTP) $ \(tls :: TLS 'TClient) -> do
+      tlsALPN tls `shouldBe` Just "h2"
+      case getCerts tls of
+        X.Certificate {X.certPubKey = X.PubKeyRSA rsa} : _ -> RSA.public_size rsa `shouldSatisfy` (> 0)
+        leaf : _ -> expectationFailure $ "Expected RSA cert, got: " <> show (X.certPubKey leaf)
+        [] -> expectationFailure "Empty certificate chain"
+
+testNoSNICertSelection :: Expectation
+testNoSNICertSelection =
+  withXFTPServerSNI $ \_ -> do
+    Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
+    let caXFTP = C.KeyHash fpXFTP
+        cfg = defaultTransportClientConfig {clientALPN = Just ["xftp/1"], useSNI = False}
+    runTLSTransportClient defaultSupportedParams Nothing cfg Nothing "localhost" xftpTestPort (Just caXFTP) $ \(tls :: TLS 'TClient) -> do
+      tlsALPN tls `shouldBe` Just "xftp/1"
+      case getCerts tls of
+        X.Certificate {X.certPubKey = X.PubKeyEd448 _} : _ -> pure ()
+        leaf : _ -> expectationFailure $ "Expected Ed448 cert, got: " <> show (X.certPubKey leaf)
+        [] -> expectationFailure "Empty certificate chain"
+
+testCORSHeaders :: Expectation
+testCORSHeaders =
+  withXFTPServerSNI $ \_ -> do
+    Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/ca.crt"
+    let caHTTP = C.KeyHash fpHTTP
+        cfg = defaultTransportClientConfig {clientALPN = Just ["h2"], useSNI = True}
+    runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfg Nothing "localhost" xftpTestPort (Just caHTTP) $ \(tls :: TLS 'TClient) -> do
+      let h2cfg = HC.defaultHTTP2ClientConfig {HC.bodyHeadSize = 65536}
+      h2 <- either (error . show) pure =<< HC.attachHTTP2Client h2cfg (THDomainName "localhost") xftpTestPort mempty 65536 tls
+      let req = H2.requestNoBody "POST" "/" []
+      HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000)
+      lookupResponseHeader "access-control-allow-origin" response `shouldBe` Just "*"
+      lookupResponseHeader "access-control-expose-headers" response `shouldBe` Just "*"
+
+testCORSPreflight :: Expectation
+testCORSPreflight =
+  withXFTPServerSNI $ \_ -> do
+    Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/ca.crt"
+    let caHTTP = C.KeyHash fpHTTP
+        cfg = defaultTransportClientConfig {clientALPN = Just ["h2"], useSNI = True}
+    runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfg Nothing "localhost" xftpTestPort (Just caHTTP) $ \(tls :: TLS 'TClient) -> do
+      let h2cfg = HC.defaultHTTP2ClientConfig {HC.bodyHeadSize = 65536}
+      h2 <- either (error . show) pure =<< HC.attachHTTP2Client h2cfg (THDomainName "localhost") xftpTestPort mempty 65536 tls
+      let req = H2.requestNoBody "OPTIONS" "/" []
+      HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000)
+      lookupResponseHeader "access-control-allow-origin" response `shouldBe` Just "*"
+      lookupResponseHeader "access-control-allow-methods" response `shouldBe` Just "POST, OPTIONS"
+      lookupResponseHeader "access-control-allow-headers" response `shouldBe` Just "*"
+      lookupResponseHeader "access-control-max-age" response `shouldBe` Just "86400"
+
+testNoCORSWithoutSNI :: Expectation
+testNoCORSWithoutSNI =
+  withXFTPServerSNI $ \_ -> do
+    Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
+    let caXFTP = C.KeyHash fpXFTP
+        cfg = defaultTransportClientConfig {clientALPN = Just ["xftp/1"], useSNI = False}
+    runTLSTransportClient defaultSupportedParams Nothing cfg Nothing "localhost" xftpTestPort (Just caXFTP) $ \(tls :: TLS 'TClient) -> do
+      let h2cfg = HC.defaultHTTP2ClientConfig {HC.bodyHeadSize = 65536}
+      h2 <- either (error . show) pure =<< HC.attachHTTP2Client h2cfg (THDomainName "localhost") xftpTestPort mempty 65536 tls
+      let req = H2.requestNoBody "POST" "/" []
+      HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000)
+      lookupResponseHeader "access-control-allow-origin" response `shouldBe` Nothing
+
+testFileChunkDeliverySNI :: Expectation
+testFileChunkDeliverySNI =
+  withXFTPServerSNI $ \_ -> testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelivery c c