diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1243d6589..ff0e05fcb 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/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 diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 067fedd89..f8b063cdb 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/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) = diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index 6de00a495..9f71c676c 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/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