diff --git a/contributing/CODE.md b/contributing/CODE.md index 5f4572555..ab5d7efcc 100644 --- a/contributing/CODE.md +++ b/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`. diff --git a/rfcs/2026-01-31-web-xftp-server-changes.md b/rfcs/2026-01-31-web-xftp-server-changes.md new file mode 100644 index 000000000..a1a2f47d5 --- /dev/null +++ b/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. diff --git a/simplexmq.cabal b/simplexmq.cabal index f1c01db84..8a79a1716 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -527,6 +527,7 @@ test-suite simplexmq-test , async , base64-bytestring , bytestring + , case-insensitive ==1.2.* , containers , crypton , crypton-x509 diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 25de49afc..b1160e582 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 206a5b375..389296a8f 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 944df1ca0..1c09762f8 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/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)" diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index 7152eb5a9..8ece9488b 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/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 diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 00b94ddc5..cdfc300b7 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/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) } } diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index bd62afa06..4a1c80cb9 100644 --- a/tests/XFTPClient.hs +++ b/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 diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index c1d34177f..5ab81e7cf 100644 --- a/tests/XFTPServerTests.hs +++ b/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