agent: reject low-order DH keys in double ratchet

src/Simplex/Messaging/Agent.hs

@@ -1561,7 +1561,7 @@ createRatchet_ db g connId maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetPar
   (_, rcDHRs) <- atomically $ C.generateKeyPair g
   rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pks e2eRcvParams
   let rcVs = CR.RatchetVersions {current = v, maxSupported}
-      rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
+  rc <- liftEitherWith (SEAgentError . cryptoError) $ CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
   liftIO $ createSndRatchet db connId rc e2eSndParams
   pure (rc, e2eSndParams)
 
@@ -4345,7 +4345,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                 | otherwise = do
                     (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random
                     rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd (pk1, pk2, CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams
-                    recreateRatchet replyKey_ (Just $ EREADY lastExternalSndId) $ CR.initSndRatchet rcVs k2Rcv rcDHRs rcParams
+                    recreateRatchet replyKey_ (Just $ EREADY lastExternalSndId) =<< liftEitherWith cryptoError (CR.initSndRatchet rcVs k2Rcv rcDHRs rcParams)
 
           checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
           checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -84,13 +84,16 @@ module Simplex.Messaging.Crypto.Ratchet
     RatchetKEM (..),
     RatchetKEMAccepted (..),
     RatchetKey (..),
+    EncMessageHeader (..),
+    EncRatchetMessage (..),
+    paddedHeaderLen,
     fullHeaderLen,
     applySMDiff,
   )
 where
 
 import Control.Applicative ((<|>))
-import Control.Monad (unless)
+import Control.Monad (unless, when)
 import Control.Monad.Except
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
@@ -469,7 +472,7 @@ pqX3dhSnd :: DhAlgorithm a => AE2EPrivRatchetParams a -> E2ERatchetParams 'RKSPr
 --        3. replied       2. received
 pqX3dhSnd (spk1, spk2, spKem_) (E2ERatchetParams _ rk1 rk2 rKem_) = do
   (ks_, kem_) <- sndPq
-  let initParams = pqX3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2) kem_
+  initParams <- pqX3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2) kem_
   pure (initParams, ks_)
   where
     sndPq :: Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
@@ -485,7 +488,7 @@ pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => RcvE2EPrivRatche
 --        1. sent          4. received in reply
 pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams _ sk1 sk2 sKem_) = do
   kem_ <- rcvPq
-  let initParams = pqX3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2) (snd <$> kem_)
+  initParams <- liftEither $ pqX3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2) (snd <$> kem_)
   pure (initParams, fst <$> kem_)
   where
     rcvPq :: ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
@@ -497,9 +500,10 @@ pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams _ sk1 sk2 sKem_) = do
         Nothing -> throwE CERatchetKEMState
       _ -> pure Nothing -- both parties can send "proposal" in case of ratchet renegotiation
 
-pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> RatchetInitParams
+pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> Either CryptoError RatchetInitParams
 pqX3dh (sk1, rk1) dh1 dh2 dh3 kemAccepted =
-  RatchetInitParams {assocData, rcVerifyCodePQ = Str vcPQ, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
+  mapM_ checkDhSecret [dh1, dh2, dh3]
+    $> RatchetInitParams {assocData, rcVerifyCodePQ = Str vcPQ, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
   where
     assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
     dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3 <> pq
@@ -644,30 +648,31 @@ instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
 -- // above added for KEM
 -- @
 initSndRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Ratchet a
+  forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Either CryptoError (Ratchet a)
 initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do
   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss)
-  let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs (rcPQRss <$> kemAccepted)
-      pqOn = isJust rcPQRs_
-   in Ratchet
-        { rcVersion,
-          rcAD = assocData,
-          rcVCPQ = Just rcVerifyCodePQ,
-          rcDHRs,
-          rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
-          rcSupportKEM = PQSupport pqOn,
-          rcEnableKEM = PQEncryption pqOn,
-          rcSndKEM = PQEncryption $ isJust kemAccepted,
-          rcRcvKEM = PQEncOff,
-          rcRK,
-          rcSnd = Just SndRatchet {rcDHRr, rcCKs, rcHKs = sndHK},
-          rcRcv = Nothing,
-          rcPN = 0,
-          rcNs = 0,
-          rcNr = 0,
-          rcNHKs,
-          rcNHKr = rcvNextHK
-        }
+  (rcRK, rcCKs, rcNHKs) <- rootKdf ratchetKey rcDHRr rcDHRs (rcPQRss <$> kemAccepted)
+  let pqOn = isJust rcPQRs_
+  pure
+    Ratchet
+      { rcVersion,
+        rcAD = assocData,
+        rcVCPQ = Just rcVerifyCodePQ,
+        rcDHRs,
+        rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
+        rcSupportKEM = PQSupport pqOn,
+        rcEnableKEM = PQEncryption pqOn,
+        rcSndKEM = PQEncryption $ isJust kemAccepted,
+        rcRcvKEM = PQEncOff,
+        rcRK,
+        rcSnd = Just SndRatchet {rcDHRr, rcCKs, rcHKs = sndHK},
+        rcRcv = Nothing,
+        rcPN = 0,
+        rcNs = 0,
+        rcNr = 0,
+        rcNHKs,
+        rcNHKr = rcvNextHK
+      }
 
 -- | Receiving ratchet initialization, equivalent to RatchetInitBobPQ2HE in double ratchet spec
 --
@@ -1025,10 +1030,10 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
           -- state.DHRs = GENERATE_DH()
           (_, rcDHRs') <- atomically $ generateKeyPair @a g
           -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss)
-          let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs kemSS
-              -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss)
-              (rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs' kemSS'
-              sndKEM = isJust kemSS'
+          (rcRK', rcCKr', rcNHKr') <- liftEither $ rootKdf rcRK msgDHRs rcDHRs kemSS
+          -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss)
+          (rcRK'', rcCKs', rcNHKs') <- liftEither $ rootKdf rcRK' msgDHRs rcDHRs' kemSS'
+          let sndKEM = isJust kemSS'
               rcvKEM = isJust kemSS
               rcEnableKEM' = PQEncryption $ sndKEM || rcvKEM || isJust rcKEM'
           pure
@@ -1135,14 +1140,21 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
       -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
       tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
 
-rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> Maybe KEMSharedKey -> (RatchetKey, RatchetKey, Key)
+rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> Maybe KEMSharedKey -> Either CryptoError (RatchetKey, RatchetKey, Key)
 rootKdf (RatchetKey rk) k pk kemSecret_ =
-  let dhOut = dhBytes' (dh' k pk)
+  let dhSecret = dh' k pk
+      dhOut = dhBytes' dhSecret
       ss = case kemSecret_ of
         Just (KEMSharedKey s) -> dhOut <> BA.convert s
         Nothing -> dhOut
       (rk', ck, nhk) = hkdf3 rk ss "SimpleXRootRatchet"
-   in (RatchetKey rk', RatchetKey ck, Key nhk)
+   in checkDhSecret dhSecret $> (RatchetKey rk', RatchetKey ck, Key nhk)
+
+-- RFC 7748 section 6.2: X25519 and X448 produce the all-zero secret for low-order public keys
+checkDhSecret :: DhSecret a -> Either CryptoError ()
+checkDhSecret s = when (BA.constEq dhOut $ B.replicate (B.length dhOut) '\0') $ Left $ CryptoHeaderError "all-zero DH secret"
+  where
+    dhOut = dhBytes' s
 
 chainKdf :: RatchetKey -> (RatchetKey, Key, IV, IV)
 chainKdf (RatchetKey ck) =

tests/AgentTests/DoubleRatchetTests.hs

@@ -10,16 +10,23 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+-- DhAlgorithm makes non-DH key constructors unreachable in lowOrderKeys, but GHC reports it as redundant
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module AgentTests.DoubleRatchetTests where
 
 import Control.Concurrent.STM
-import Control.Monad (when)
+import Control.Monad (forM_, when)
 import Control.Monad.Except
 import Control.Monad.IO.Class
+import Crypto.Cipher.AES (AES256)
+import qualified Crypto.Error as CE
+import qualified Crypto.PubKey.Curve25519 as X25519
+import qualified Crypto.PubKey.Curve448 as X448
 import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON, ToJSON, (.=))
 import qualified Data.Aeson as J
+import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Map.Strict as M
@@ -29,6 +36,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String (Str (..))
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$$>))
 import Simplex.Messaging.Version
@@ -48,6 +56,8 @@ doubleRatchetTests = do
     it "should decode v2 Ratchet with default field values" $ testDecodeV2RatchetJSON
     it "should agree the same ratchet parameters" $ testAlgs testX3dh
     it "should agree the same ratchet parameters with version 1" $ testAlgs testX3dhV1
+    it "should reject low-order DH keys in key agreement" $ testAlgs testX3dhLowOrderKeys
+    it "should reject low-order DH key in message header" $ testAlgs testRatchetStepLowOrderKey
   describe "post-quantum hybrid KEM double-ratchet algorithm" $ do
     describe "hybrid KEM key agreement" $ do
       it "should propose KEM during agreement, but no shared secret" $ testAlgs testPqX3dhProposeInReply
@@ -394,6 +404,51 @@ testX3dhV1 _ = do
   paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   paramsAlice `shouldBe` paramsBob
 
+testX3dhLowOrderKeys :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testX3dhLowOrderKeys _ = do
+  g <- C.newRandom
+  let v = currentE2EEncryptVersion
+  (pksBob, AE2ERatchetParams _ e2eBob@(E2ERatchetParams _ bk1 bk2 _)) <- liftIO $ generateSndE2EParams @a g v Nothing
+  (pksAlice, e2eAlice@(E2ERatchetParams _ ak1 ak2 _)) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
+  Right _ <- pure $ pqX3dhSnd pksBob e2eAlice
+  Right _ <- runExceptT $ pqX3dhRcv pksAlice e2eBob
+  let params k1 k2 = E2ERatchetParams v k1 k2 Nothing :: E2ERatchetParams 'RKSProposed a
+  forM_ (lowOrderKeys ak1) $ \k -> do
+    pqX3dhSnd pksBob (params k ak2) `shouldBe` Left allZeroDhError
+    pqX3dhSnd pksBob (params ak1 k) `shouldBe` Left allZeroDhError
+    runExceptT (pqX3dhRcv pksAlice $ params k bk2) `shouldReturn` Left allZeroDhError
+    runExceptT (pqX3dhRcv pksAlice $ params bk1 k) `shouldReturn` Left allZeroDhError
+
+testRatchetStepLowOrderKey :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testRatchetStepLowOrderKey _ = do
+  g <- C.newRandom
+  (alice, Ratchet {rcSnd = Just SndRatchet {rcHKs}, rcAD = Str ad}, _, _, _) <- initRatchets @a
+  let decryptWithKey k = do
+        let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgKEM = Nothing, msgPN = 0, msgNs = 0}
+            ehIV = C.IV $ B.replicate (C.ivSize @AES256) '\0'
+        Right (ehAuthTag, ehBody) <- runExceptT $ C.encryptAEAD rcHKs ehIV (paddedHeaderLen PQSupportOff) ad (smpEncode hdr)
+        let emHeader = smpEncode EncMessageHeader {ehVersion = currentE2EEncryptVersion, ehIV, ehAuthTag, ehBody}
+        runExceptT $ rcDecrypt g alice M.empty $ smpEncode EncRatchetMessage {emHeader, emAuthTag = ehAuthTag, emBody = "message"}
+  (validKey, _) <- atomically $ C.generateKeyPair @a g
+  decryptWithKey validKey >>= \case
+    Right (Left C.AESDecryptError, _, _) -> pure ()
+    _ -> expectationFailure "header with valid key should be decrypted and ratchet advanced"
+  forM_ (lowOrderKeys validKey) $ \k ->
+    decryptWithKey k >>= \case
+      Left e -> e `shouldBe` allZeroDhError
+      Right _ -> expectationFailure "ratchet should not advance with low-order key"
+
+-- RFC 7748 section 6.2: u = 0 and u = 1 are low-order points on both curves and their twists
+lowOrderKeys :: DhAlgorithm a => C.PublicKey a -> [C.PublicKey a]
+lowOrderKeys = \case
+  C.PublicKeyX25519 k -> C.PublicKeyX25519 . CE.throwCryptoError . X25519.publicKey <$> lowOrderPoints (BA.length k)
+  C.PublicKeyX448 k -> C.PublicKeyX448 . CE.throwCryptoError . X448.publicKey <$> lowOrderPoints (BA.length k)
+  where
+    lowOrderPoints n = [B.replicate n '\0', B.cons '\1' $ B.replicate (n - 1) '\0']
+
+allZeroDhError :: CryptoError
+allZeroDhError = C.CryptoHeaderError "all-zero DH secret"
+
 testPqX3dhProposeInReply :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testPqX3dhProposeInReply _ = do
   g <- C.newRandom
@@ -531,8 +586,8 @@ initRatchets = do
   Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   (_, pkBob3) <- atomically $ C.generateKeyPair g
   let vs = testRatchetVersions
-      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff
+  Right bob <- pure $ initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+  let alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff
   pure (alice, bob, encrypt' noSndKEM, decrypt' noRcvKEM, (\#>))
 
 initRatchetsKEMProposed :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
@@ -548,8 +603,8 @@ initRatchetsKEMProposed = do
   Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   (_, pkBob3) <- atomically $ C.generateKeyPair g
   let vs = testRatchetVersions
-      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  Right bob <- pure $ initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+  let alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
   pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
 
 initRatchetsKEMAccepted :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
@@ -566,8 +621,8 @@ initRatchetsKEMAccepted = do
   Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   (_, pkBob3) <- atomically $ C.generateKeyPair g
   let vs = testRatchetVersions
-      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  Right bob <- pure $ initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+  let alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
   pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
 
 initRatchetsKEMProposedAgain :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
@@ -583,8 +638,8 @@ initRatchetsKEMProposedAgain = do
   Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   (_, pkBob3) <- atomically $ C.generateKeyPair g
   let vs = testRatchetVersions
-      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  Right bob <- pure $ initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+  let alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
   pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
 
 testRatchetVersions :: RatchetVersions