smp: transport block encryption

src/Simplex/FileTransfer/Client.hs

@@ -113,7 +113,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let HTTP2Client {sessionId, sessionALPN} = http2Client
       v = VersionXFTP 1
       thServerVRange = versionToRange v
-      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
   logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
   thParams@THandleParams {thVersion} <- case sessionALPN of
     Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0

src/Simplex/FileTransfer/Server.hs

@@ -120,7 +120,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         reqBody <- getHTTP2Body r xftpBlockSize
         let v = VersionXFTP 1
             thServerVRange = versionToRange v
-            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
+            thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
             req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
         flip runReaderT env $ case sessionALPN of
           Nothing -> processRequest req0

src/Simplex/Messaging/Client.hs

@@ -199,6 +199,7 @@ smpClientStub g sessionId thVersion thAuth = do
               thAuth,
               blockSize = smpBlockSize,
               implySessId = thVersion >= authCmdsSMPVersion,
+              encryptBlock = Nothing,
               batch = True
             },
         sessionTs = ts,
@@ -427,7 +428,9 @@ defaultClientConfig clientALPN useSNI serverVRange =
 defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
 defaultSMPClientConfig =
   (defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
-    {defaultTransport = (show defaultSMPPort, transport @TLS)}
+    { defaultTransport = (show defaultSMPPort, transport @TLS),
+      agreeSecret = True
+    }
 {-# INLINE defaultSMPClientConfig #-}
 
 data Request err msg = Request

src/Simplex/Messaging/Notifications/Transport.hs

@@ -169,5 +169,6 @@ ntfTHandle c = THandle {connection = c, params}
           thServerVRange = versionToRange v,
           thAuth = Nothing,
           implySessId = False,
+          encryptBlock = Nothing,
           batch = False
         }

src/Simplex/Messaging/Protocol.hs

@@ -258,24 +258,25 @@ supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClie
 -- TODO v6.0 remove dependency on version
 maxMessageLength :: VersionSMP -> Int
 maxMessageLength v
+  | v >= encryptedBlockSMPVersion = 16048 -- max 16051
   | v >= sendingProxySMPVersion = 16064 -- max 16067
-  | otherwise = 16088 -- 16064 - always use this size to determine allowed ranges
+  | otherwise = 16088 -- 16048 - always use this size to determine allowed ranges
 
 paddedProxiedTLength :: Int
-paddedProxiedTLength = 16242 -- 16241 .. 16243
+paddedProxiedTLength = 16226 -- 16225 .. 16227
 
--- TODO v6.0 change to 16064
+-- TODO v7.0 change to 16048
 type MaxMessageLen = 16088
 
 -- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
 type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
 
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
-e2eEncConfirmationLength = 15920 -- 15881 .. 15976
+e2eEncConfirmationLength = 15904 -- 15865 .. 15960
 
 e2eEncMessageLength :: Int
-e2eEncMessageLength = 16016 -- 16004 .. 16021
+e2eEncMessageLength = 16000 -- 15988 .. 16005
 
 -- | SMP protocol clients
 data Party = Recipient | Sender | Notifier | ProxiedClient
@@ -1663,8 +1664,8 @@ batchTransmissions' batch bSize ts
 batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
 batchTransmissions_ bSize = addBatch . foldr addTransmission ([], 0, 0, [], [])
   where
-    -- 3 = 2 bytes reserved for pad size + 1 for transmission count
-    bSize' = bSize - 3
+    -- 19 = 2 bytes reserved for pad size + 1 for transmission count + 16 auth tag from block encryption
+    bSize' = bSize - 19
     addTransmission :: (Either TransportError ByteString, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
     addTransmission (t_, r) acc@(bs, !len, !n, ss, rs) = case t_ of
       Left e -> (TBError e r : addBatch acc, 0, 0, [], [])

src/Simplex/Messaging/Transport.hs

@@ -48,6 +48,7 @@ module Simplex.Messaging.Transport
     sendingProxySMPVersion,
     sndAuthKeySMPVersion,
     deletedEventSMPVersion,
+    encryptedBlockSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -90,6 +91,7 @@ import Control.Applicative (optional)
 import Control.Concurrent.STM
 import Control.Monad (forM, (<$!>))
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Except (throwE)
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -101,6 +103,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
+import Data.Tuple (swap)
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Data.Word (Word16)
@@ -138,6 +141,7 @@ smpBlockSize = 16384
 -- 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)
 
 data SMPVersion
 
@@ -171,14 +175,17 @@ sndAuthKeySMPVersion = VersionSMP 9
 deletedEventSMPVersion :: VersionSMP
 deletedEventSMPVersion = VersionSMP 10
 
+encryptedBlockSMPVersion :: VersionSMP
+encryptedBlockSMPVersion = VersionSMP 11
+
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 10
+currentClientSMPRelayVersion = VersionSMP 11
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 10
+currentServerSMPRelayVersion = VersionSMP 11
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -400,6 +407,8 @@ 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
+    encryptBlock :: Maybe TSbChainKeys,
     -- | send multiple transmissions in a single block
     -- based on protocol version
     batch :: Bool
@@ -525,16 +534,26 @@ instance Encoding TransportError where
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
-tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
-  bimapM (const $ pure TELargeMsg) (cPut c) $
-    C.pad block blockSize
+tPutBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} block = do
+  block_ <- case encryptBlock of
+    Just TSbChainKeys {sndKey} -> do
+      (sk, nonce) <- atomically $ stateTVar sndKey C.sbcHkdf
+      pure $ C.sbEncrypt sk nonce block (blockSize - 16)
+    Nothing -> pure $ C.pad block blockSize
+  bimapM (const $ pure TELargeMsg) (cPut c) block_
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
+tGetBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} = do
   msg <- cGet c blockSize
   if B.length msg == blockSize
-    then pure . first (const TELargeMsg) $ C.unPad msg
+    then
+      first (const TELargeMsg) <$>
+        case encryptBlock of
+          Just TSbChainKeys {rcvKey} -> do
+            (sk, nonce) <- atomically $ stateTVar rcvKey C.sbcHkdf
+            pure $ C.sbDecrypt sk nonce msg
+          Nothing -> pure $ C.unPad msg
     else ioe_EOF
 
 -- | Server SMP transport handshake.
@@ -553,7 +572,7 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
           throwE $ TEHandshake IDENTITY
       | otherwise ->
           case compatibleVRange' smpVersionRange v of
-            Just (Compatible vr) -> pure $ smpTHandleServer th v vr pk k'
+            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k'
             Nothing -> throwE TEVersion
 
 -- | Client SMP transport handshake.
@@ -577,23 +596,36 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
             (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
         let v = maxVersion vr
         sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
-        pure $ smpTHandleClient th v vr (snd <$> ks_) ck_
+        liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_
       Nothing -> throwE TEVersion
 
-smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
-smpTHandleServer th v vr pk k_ =
-  let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
-   in smpTHandle_ th v vr (Just thAuth)
+smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer)
+smpTHandleServer th v vr pk k_ = do
+  let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
+  be <- blockEncryption th v 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)) -> THandleSMP c 'TClient
-smpTHandleClient th v vr pk_ ck_ =
+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
   let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
-   in smpTHandle_ th v vr thAuth
+  be <- blockEncryption th v 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
+    THAuthClient {sessSecret} -> be sessSecret
+    THAuthServer {sessSecret'} -> be sessSecret'
+  _ -> pure Nothing
+  where
+    be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
+    be = mapM $ \(C.DhSecretX25519 secret) -> bimapM newTVarIO newTVarIO $ C.sbcInit sessionId secret
 
-smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p
-smpTHandle_ th@THandle {params} v vr thAuth =
+smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
+smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
   -- TODO drop SMP v6: make thAuth non-optional
-  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
+  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion, encryptBlock}
    in (th :: THandleSMP c p) {params = params'}
 
 {-# INLINE forceCertChain #-}
@@ -625,6 +657,7 @@ smpTHandle c = THandle {connection = c, params}
           thVersion = v,
           thAuth = Nothing,
           implySessId = False,
+          encryptBlock = Nothing,
           batch = True
         }
 

tests/CoreTests/BatchingTests.hs

@@ -30,7 +30,7 @@ batchingTests :: Spec
 batchingTests = do
   describe "batchTransmissions" $ do
     describe "SMP v6 (previous)" $ do
-      it "should batch with 107 subscriptions per batch" testBatchSubscriptionsV6
+      it "should batch with 106 subscriptions per batch" testBatchSubscriptionsV6
       it "should break on message that does not fit" testBatchWithMessageV6
       it "should break on large message" testBatchWithLargeMessageV6
     describe "SMP current" $ do
@@ -39,7 +39,7 @@ batchingTests = do
       it "should break on large message" testBatchWithLargeMessage
   describe "batchTransmissions'" $ do
     describe "SMP v6 (previous)" $ do
-      it "should batch with 107 subscriptions per batch" testClientBatchSubscriptionsV6
+      it "should batch with 106 subscriptions per batch" testClientBatchSubscriptionsV6
       it "should break on message that does not fit" testClientBatchWithMessageV6
       it "should break on large message" testClientBatchWithLargeMessageV6
     describe "SMP current" $ do
@@ -59,7 +59,7 @@ testBatchSubscriptionsV6 = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (36, 107, 107)
+  (n1, n2, n3) `shouldBe` (38, 106, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchSubscriptions :: IO ()
@@ -123,7 +123,7 @@ testBatchWithLargeMessageV6 = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 43, 107)
+  (n1, n2, n3) `shouldBe` (50, 44, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchWithLargeMessage :: IO ()
@@ -154,8 +154,8 @@ testClientBatchSubscriptionsV6 = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (36, 107, 107)
-  (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107)
+  (n1, n2, n3) `shouldBe` (38, 106, 106)
+  (length rs1, length rs2, length rs3) `shouldBe` (38, 106, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchSubscriptions :: IO ()
@@ -251,16 +251,16 @@ testClientBatchWithLargeMessageV6 = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
   [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (50, 43, 107)
-  (length rs1, length rs2, length rs3) `shouldBe` (50, 43, 107)
+  (n1, n2, n3) `shouldBe` (50, 44, 106)
+  (length rs1, length rs2, length rs3) `shouldBe` (50, 44, 106)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
   let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
   length batches' `shouldBe` 3
   [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (93, 107)
-  (length rs1', length rs2') `shouldBe` (93, 107)
+  (n1', n2') `shouldBe` (94, 106)
+  (length rs1', length rs2') `shouldBe` (94, 106)
   all lenOk [s1', s2'] `shouldBe` True
 
 testClientBatchWithLargeMessage :: IO ()
@@ -380,6 +380,7 @@ testTHandleParams v sessionId =
       thServerVRange = supportedServerSMPRelayVRange,
       thAuth = Nothing,
       implySessId = v >= authCmdsSMPVersion,
+      encryptBlock = Nothing,
       batch = True
     }
 

tests/SMPProxyTests.hs

@@ -63,7 +63,7 @@ smpProxyTests = do
     let srv1 = SMPServer testHost testPort testKeyHash
         srv2 = SMPServer testHost testPort2 testKeyHash
     describe "client API" $ do
-      let maxLen = maxMessageLength sendingProxySMPVersion
+      let maxLen = maxMessageLength encryptedBlockSMPVersion
       describe "one server" $ do
         it "deliver via proxy" . oneServer $ do
           deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"