cap proxy version for previous destination server

src/Simplex/FileTransfer/Transport.hs

@@ -102,8 +102,8 @@ supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
 
 -- XFTP protocol does not use this handshake method
-xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
-xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion
+xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
+xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
 
 supportedXFTPhandshakes :: [ALPN]
 supportedXFTPhandshakes = ["xftp/1"]

src/Simplex/Messaging/Client.hs

@@ -406,6 +406,8 @@ data ProtocolClientConfig v = ProtocolClientConfig
     serverVRange :: VersionRange v,
     -- | agree shared session secret (used in SMP proxy for additional encryption layer)
     agreeSecret :: Bool,
+    -- | Whether connecting client is a proxy server. See comment in ClientHandshake
+    proxyServer :: Bool,
     -- | send SNI to server, False for SMP
     useSNI :: Bool
   }
@@ -420,6 +422,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
       clientALPN,
       serverVRange,
       agreeSecret = False,
+      proxyServer = False,
       useSNI
     }
 {-# INLINE defaultClientConfig #-}
@@ -489,7 +492,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs disconnected = do
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -548,7 +551,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
     client _ c cVar h = do
       ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
-      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {params} -> do
           sessionTs <- getCurrentTime

src/Simplex/Messaging/Notifications/Transport.hs

@@ -123,8 +123,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
             Nothing -> throwE TEVersion
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
-ntfClientHandshake c keyHash ntfVRange = do
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
+ntfClientHandshake c keyHash ntfVRange _proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
   if sessionId /= sessId

src/Simplex/Messaging/Protocol.hs

@@ -1344,7 +1344,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
 class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
+  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
@@ -1492,7 +1492,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     INFO info -> e (INFO_, ' ', info)
     OK -> e OK_
     ERR err -> case err of
-      BLOCKED _ | v < blockedEntityErrorSMPVersion -> e (ERR_, ' ', AUTH)
+      BLOCKED _ | v < blockedEntitySMPVersion -> e (ERR_, ' ', AUTH)
       _ -> e (ERR_, ' ', err)
     PONG -> e PONG_
     where

src/Simplex/Messaging/Server/Main.hs

@@ -448,6 +448,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                       (smpCfg defaultSMPClientAgentConfig)
                         { serverVRange = supportedProxyClientSMPRelayVRange,
                           agreeSecret = True,
+                          proxyServer = True,
                           networkConfig =
                             defaultNetworkConfig
                               { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,

src/Simplex/Messaging/Transport.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
@@ -14,6 +15,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- |
 -- Module      : Simplex.Messaging.Transport
@@ -49,7 +51,7 @@ module Simplex.Messaging.Transport
     sndAuthKeySMPVersion,
     deletedEventSMPVersion,
     encryptedBlockSMPVersion,
-    blockedEntityErrorSMPVersion,
+    blockedEntitySMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -90,7 +92,7 @@ where
 
 import Control.Applicative (optional)
 import Control.Concurrent.STM
-import Control.Monad (forM, (<$!>))
+import Control.Monad (forM, when, (<$!>))
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except (throwE)
@@ -139,11 +141,11 @@ smpBlockSize = 16384
 -- 5 - basic auth for SMP servers (11/12/2022)
 -- 6 - allow creating queues without subscribing (9/10/2023)
 -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
--- 8 - SMP proxy for sender commands
--- 9 - faster handshake: SKEY command for sender to secure queue
--- 10 - DELD event to subscriber when queue is deleted via another connnection
--- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024)
--- 12 - BLOCKED error for blocked queues (1/11/2025)
+-- 8 - SMP proxy for sender commands (6/03/2024)
+-- 9 - faster handshake: SKEY command for sender to secure queue (6/30/2024)
+-- 10 - DELD event to subscriber when queue is deleted via another connnection (9/11/2024)
+-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024)
+-- 12 - BLOCKED error for blocked queues, handshake property to disable transport encryption between server and proxy (1/11/2025)
 
 data SMPVersion
 
@@ -174,8 +176,8 @@ deletedEventSMPVersion = VersionSMP 10
 encryptedBlockSMPVersion :: VersionSMP
 encryptedBlockSMPVersion = VersionSMP 11
 
-blockedEntityErrorSMPVersion :: VersionSMP
-blockedEntityErrorSMPVersion = VersionSMP 12
+blockedEntitySMPVersion :: VersionSMP
+blockedEntitySMPVersion = VersionSMP 12
 
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 6
@@ -200,7 +202,7 @@ currentServerSMPRelayVersion = VersionSMP 12
 proxiedSMPRelayVersion :: VersionSMP
 proxiedSMPRelayVersion = VersionSMP 12
 
--- minimal supported protocol version is 4
+-- minimal supported protocol version is 6
 -- TODO remove code that supports sending commands without batching
 supportedClientSMPRelayVRange :: VersionRangeSMP
 supportedClientSMPRelayVRange = mkVersionRange minClientSMPRelayVersion currentClientSMPRelayVersion
@@ -416,7 +418,7 @@ data THandleParams v p = THandleParams
     -- | do NOT send session ID in transmission, but include it into signed message
     -- based on protocol version
     implySessId :: Bool,
-    -- -- | additional block encryption
+    -- | keys for additional transport encryption
     encryptBlock :: Maybe TSbChainKeys,
     -- | send multiple transmissions in a single block
     -- based on protocol version
@@ -457,18 +459,28 @@ data ClientHandshake = ClientHandshake
     smpVersion :: VersionSMP,
     -- | server identity - CA certificate fingerprint
     keyHash :: C.KeyHash,
-    -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
-    authPubKey :: Maybe C.PublicKeyX25519
+    -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
+    authPubKey :: Maybe C.PublicKeyX25519,
+    -- | Whether connecting client is a proxy server (send from SMP v12).
+    -- This property, if True, disables additional transport encrytion inside TLS.
+    -- (Proxy server connection already has additional encryption, so this layer is not needed there).
+    proxyServer :: Bool
   }
 
 instance Encoding ClientHandshake where
-  smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} =
-    smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey
+  smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
+    smpEncode (v, keyHash)
+      <> encodeAuthEncryptCmds v authPubKey
+      <> ifHasProxy v (smpEncode proxyServer) ""
   smpP = do
-    (smpVersion, keyHash) <- smpP
+    (v, keyHash) <- smpP
     -- TODO drop SMP v6: remove special parser and make key non-optional
-    authPubKey <- authEncryptCmdsP smpVersion smpP
-    pure ClientHandshake {smpVersion, keyHash, authPubKey}
+    authPubKey <- authEncryptCmdsP v smpP
+    proxyServer <- ifHasProxy v smpP (pure False)
+    pure ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
+
+ifHasProxy :: VersionSMP -> a -> a -> a
+ifHasProxy v a b = if v >= blockedEntitySMPVersion then a else b
 
 instance Encoding ServerHandshake where
   smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
@@ -576,54 +588,57 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
       smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
   sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
   getHandshake th >>= \case
-    ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
+    ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
       | keyHash /= kh ->
           throwE $ TEHandshake IDENTITY
       | otherwise ->
           case compatibleVRange' smpVersionRange v of
-            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k'
+            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k' proxyServer
             Nothing -> throwE TEVersion
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient)
-smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
+smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
+smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
-  if sessionId /= sessId
-    then throwE TEBadSession
-    else case smpVersionRange `compatibleVRange` smpVRange of
-      Just (Compatible vr) -> do
-        ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
-          liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
-            case cert of
-              [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
-              _ -> throwError "bad certificate"
-            serverKey <- getServerVerifyKey c
-            pubKey <- C.verifyX509 serverKey exact
-            (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
-        let v = maxVersion vr
-        sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
-        liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_
-      Nothing -> throwE TEVersion
-
-smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer)
-smpTHandleServer th v vr pk k_ = do
+  when (sessionId /= sessId) $ throwE TEBadSession
+  let smpVRange =
+        if proxyServer && maxVersion smpVersionRange < blockedEntitySMPVersion
+          then vRange {maxVersion = max (minVersion vRange) deletedEventSMPVersion}
+          else vRange
+  case smpVersionRange `compatibleVRange` smpVRange of
+    Just (Compatible vr) -> do
+      ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
+        liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+          case cert of
+            [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
+            _ -> throwError "bad certificate"
+          serverKey <- getServerVerifyKey c
+          pubKey <- C.verifyX509 serverKey exact
+          (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
+      let v = maxVersion vr
+      sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
+      liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer
+    Nothing -> throwE TEVersion
+
+smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> IO (THandleSMP c 'TServer)
+smpTHandleServer th v vr pk k_ proxyServer = do
   let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
-  be <- blockEncryption th v thAuth
+  be <- blockEncryption th v proxyServer thAuth
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
 
-smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> IO (THandleSMP c 'TClient)
-smpTHandleClient th v vr pk_ ck_ = do
+smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> Bool -> IO (THandleSMP c 'TClient)
+smpTHandleClient th v vr pk_ ck_ proxyServer = do
   let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
-  be <- blockEncryption th v thAuth
+  be <- blockEncryption th v proxyServer thAuth
   -- swap is needed to use client's sndKey as server's rcvKey and vice versa
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
 
-blockEncryption :: THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
-blockEncryption THandle {params = THandleParams {sessionId}} v = \case
-  Just thAuth | v >= encryptedBlockSMPVersion -> case thAuth of
+blockEncryption :: THandleSMP c p -> VersionSMP -> Bool -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
+blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \case
+  Just thAuth | not proxyServer && v >= encryptedBlockSMPVersion -> case thAuth of
     THAuthClient {sessSecret} -> be sessSecret
     THAuthServer {sessSecret'} -> be sessSecret'
   _ -> pure Nothing

tests/CLITests.hs

@@ -174,7 +174,7 @@ smpServerTestStatic = do
         X.Certificate {X.certPubKey = X.PubKeyEd25519 _k} : _ca -> print _ca -- pure ()
         leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf
         [] -> error "Empty chain"
-      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange
+      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False
     logDebug "Combined SMP works"
   where
     getCerts :: TLS -> [X.Certificate]

tests/NtfClient.hs

@@ -82,7 +82,7 @@ testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
   runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
-    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange) >>= \case
+    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False) >>= \case
       Right th -> client th
       Left e -> error $ show e
 

tests/SMPClient.hs

@@ -105,7 +105,7 @@ testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP
 testSMPClient_ host port vr client = do
   let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN}
   runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h ->
-    runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case
+    runExceptT (smpClientHandshake h Nothing testKeyHash vr False) >>= \case
       Right th -> client th
       Left e -> error $ show e
   where
@@ -185,7 +185,7 @@ proxyCfg :: ServerConfig
 proxyCfg =
   cfg
     { allowSMPProxy = True,
-      smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, serverVRange = supportedProxyClientSMPRelayVRange}}
+      smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}}
     }
   where
     smpAgentCfg' = smpAgentCfg cfg