web handshake

src/Simplex/FileTransfer/Client.hs

@@ -40,11 +40,11 @@ import Simplex.Messaging.Client
     NetworkRequestMode (..),
     ProtocolClientError (..),
     TransportSession,
-    netTimeoutInt,
     chooseTransportHost,
-    defaultNetworkConfig,
-    transportClientConfig,
     clientSocksCredentials,
+    defaultNetworkConfig,
+    netTimeoutInt,
+    transportClientConfig,
     unexpectedResponse,
     useWebPort,
   )
@@ -54,13 +54,13 @@ import Simplex.Messaging.Encoding (smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( BasicAuth,
+    NetworkError (..),
     Protocol (..),
     ProtocolServer (..),
     RecipientId,
     SenderId,
-    pattern NoEntity,
-    NetworkError (..),
     toNetworkError,
+    pattern NoEntity,
   )
 import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
@@ -126,8 +126,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
       thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
-    Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
-      xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
+    Just alpn
+      | alpn == xftpALPNv1 || alpn == httpALPN11 ->
+          xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
     _ -> pure thParams0
   logDebug $ "Client negotiated protocol: " <> tshow thVersion
   let c = XFTPClient {http2Client, thParams, transportSession, config}
@@ -212,7 +213,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
   HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
   when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK
   -- TODO validate that the file ID is the same as in the request?
-  (_, _fId, respOrErr) <-liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
+  (_, _fId, respOrErr) <- liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
   case respOrErr of
     Right r -> case protocolError r of
       Just e -> throwE $ PCEProtocolError e

src/Simplex/FileTransfer/Server.hs

@@ -68,7 +68,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server (runHTTP2Server)
-import Simplex.Messaging.Transport.Server (TransportServerConfig (..), runLocalTCPServer)
+import Simplex.Messaging.Transport.Server (SNICredentialUsed, TransportServerConfig (..), runLocalTCPServer)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Environment (lookupEnv)
@@ -90,6 +90,7 @@ data XFTPTransportRequest = XFTPTransportRequest
     reqBody :: HTTP2Body,
     request :: H.Request,
     sendResponse :: H.Response -> IO (),
+    sniUsed :: SNICredentialUsed,
     addCORS :: Bool
   }
 
@@ -151,16 +152,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
             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'}
+                req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, 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')
+              Just alpn
+                | alpn == xftpALPNv1 || alpn == httpALPN11 || (sniUsed && alpn == "h2") ->
+                    xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
+                      Nothing -> pure ()
+                      Just thParams -> processRequest req0 {thParams}
+                | otherwise -> 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, addCORS} = do
+    xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse, sniUsed, addCORS} = do
       s <- atomically $ TM.lookup sessionId sessions
       r <- runExceptT $ case s of
         Nothing -> processHello
@@ -169,11 +171,18 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       either sendError pure r
       where
         processHello = do
-          unless (B.null bodyHead) $ throwE HANDSHAKE
+          challenge_ <-
+            if
+              | B.null bodyHead -> pure Nothing
+              | sniUsed -> do
+                  XFTPClientHello {webChallenge} <- liftHS $ smpDecode bodyHead
+                  pure webChallenge
+              | otherwise -> throwE HANDSHAKE
           (k, pk) <- atomically . C.generateKeyPair =<< asks random
           atomically $ TM.insert sessionId (HandshakeSent pk) sessions
           let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
-          let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
+              webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_
+          let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof}
           shs <- encodeXftp hs
 #ifdef slow_servers
           lift randomDelay

src/Simplex/FileTransfer/Transport.hs

@@ -19,6 +19,7 @@ module Simplex.FileTransfer.Transport
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
     -- xftpServerHandshake,
+    XFTPClientHello (..),
     THandleXFTP,
     THandleParamsXFTP,
     VersionXFTP,
@@ -60,7 +61,7 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
 import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
-import Simplex.Messaging.Util (bshow, tshow)
+import Simplex.Messaging.Util (bshow, tshow, (<$?>))
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
 import System.IO (Handle, IOMode (..), withFile)
@@ -111,11 +112,18 @@ alpnSupportedXFTPhandshakes = [xftpALPNv1]
 xftpALPNv1 :: ALPN
 xftpALPNv1 = "xftp/1"
 
+data XFTPClientHello = XFTPClientHello
+  { -- | a random string sent by the client to the server to prove that server has identity certificate
+    webChallenge :: Maybe ByteString
+  }
+
 data XFTPServerHandshake = XFTPServerHandshake
   { xftpVersionRange :: VersionRangeXFTP,
     sessionId :: SessionId,
     -- | pub key to agree shared secrets for command authorization and entity ID encryption.
-    authPubKey :: CertChainPubKey
+    authPubKey :: CertChainPubKey,
+    -- | signed identity challenge from  XFTPClientHello
+    webIdentityProof :: Maybe C.ASignature
   }
 
 data XFTPClientHandshake = XFTPClientHandshake
@@ -125,6 +133,14 @@ data XFTPClientHandshake = XFTPClientHandshake
     keyHash :: C.KeyHash
   }
 
+instance Encoding XFTPClientHello where
+  smpEncode XFTPClientHello {webChallenge} = smpEncode webChallenge
+  smpP = do
+    webChallenge <- smpP
+    forM_ webChallenge $ \challenge -> unless (B.length challenge == 32) $ fail "bad XFTPClientHello webChallenge"
+    Tail _compat <- smpP
+    pure XFTPClientHello {webChallenge}
+
 instance Encoding XFTPClientHandshake where
   smpEncode XFTPClientHandshake {xftpVersion, keyHash} =
     smpEncode (xftpVersion, keyHash)
@@ -134,13 +150,13 @@ instance Encoding XFTPClientHandshake where
     pure XFTPClientHandshake {xftpVersion, keyHash}
 
 instance Encoding XFTPServerHandshake where
-  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
-    smpEncode (xftpVersionRange, sessionId, authPubKey)
+  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} =
+    smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof)
   smpP = do
-    (xftpVersionRange, sessionId) <- smpP
-    authPubKey <- smpP
+    (xftpVersionRange, sessionId, authPubKey) <- smpP
+    webIdentityProof <- C.decodeSignature <$?> smpP
     Tail _compat <- smpP
-    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey}
+    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof}
 
 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go