From 11288866f90bafb0892701b0e0679eddb030b5df Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 7 Mar 2024 12:41:10 +0000 Subject: [PATCH] pqdr: refactor --- src/Simplex/Messaging/Agent.hs | 18 +++++++++--------- src/Simplex/Messaging/Agent/Store/SQLite.hs | 8 -------- src/Simplex/Messaging/Crypto/Ratchet.hs | 21 +++++++++++++++++---- 3 files changed, 26 insertions(+), 21 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bb335d95c..9e27ca8f1 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -572,7 +572,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup compatibleInvitationUri cReqUri pqSup >>= \case Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do g <- asks random - let pqSupport = versionPQSupport_ pqSup connAgentVersion (Just v) + let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo @@ -695,7 +695,7 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup = compatibleInvitationUri cReqUri pqSup >>= \case Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), aVersion@(Compatible connAgentVersion)) -> do g <- asks random - let pqSupport = versionPQSupport_ pqSup connAgentVersion (Just v) + let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ kem_ pqSupport) (_, rcDHRs) <- atomically $ C.generateKeyPair g rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams @@ -711,10 +711,10 @@ connRequestPQSupport :: AgentMonad' m => PQSupport -> ConnectionRequestUri c -> connRequestPQSupport pqSup cReq = case cReq of CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq pqSup where - invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = versionPQSupport_ pqSup agentV (Just e2eV) + invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = pqSup `CR.pqSupportAnd` versionPQSupport_ agentV (Just e2eV) CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq pqSup where - ctPQSupported (_, Compatible agentV) = versionPQSupport_ pqSup agentV Nothing + ctPQSupported (_, Compatible agentV) = pqSup `CR.pqSupportAnd` versionPQSupport_ agentV Nothing compatibleInvitationUri :: AgentMonad' m => ConnectionRequestUri 'CMInvitation -> PQSupport -> m (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA)) compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) pqSup = do @@ -733,9 +733,9 @@ compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = <$> (qUri `compatibleVersion` smpClientVRange) <*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup) -versionPQSupport_ :: PQSupport -> VersionSMPA -> Maybe CR.VersionE2E -> PQSupport -versionPQSupport_ (PQSupport sup) agentV e2eV_ = - PQSupport $ sup && pqdrSMPAgentVersion <= agentV && maybe True (CR.pqRatchetE2EEncryptVersion <=) e2eV_ +versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport +versionPQSupport_ agentV e2eV_ = + PQSupport $ pqdrSMPAgentVersion <= agentV && maybe True (CR.pqRatchetE2EEncryptVersion <=) e2eV_ joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> m ConnId joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = @@ -2186,7 +2186,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams -- TODO PQ combine isCompatible check and construction in one call let rcVs = CR.RVersions {current = e2eVersion, maxSupported = maxVersion e2eVRange} - pqSupport' = versionPQSupport_ pqSupport agentVersion (Just e2eVersion) + pqSupport' = pqSupport `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion) rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport' g <- asks random (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo @@ -2374,7 +2374,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, _ -> prohibited where pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) = - versionPQSupport_ PQSupportOn agentVersion (Just v) + PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v) qDuplex :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m () qDuplex conn' name action = case conn' of diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 33051d234..2f6707c5a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1776,14 +1776,6 @@ instance ToField (Version v) where toField (Version v) = toField v instance FromField (Version v) where fromField f = Version <$> fromField f -instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField pqEnc - -instance FromField PQEncryption where fromField f = PQEncryption <$> fromField f - -instance ToField PQSupport where toField (PQSupport pqEnc) = toField pqEnc - -instance FromField PQSupport where fromField f = PQSupport <$> fromField f - listToEither :: e -> [a] -> Either e a listToEither _ (x : _) = Right x listToEither e _ = Left e diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 38ada0f01..47ca1c0f2 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -58,6 +58,8 @@ module Simplex.Messaging.Crypto.Ratchet replyKEM_, pqSupportToEnc, pqEncToSupport, + pqSupportAnd, + pqSupportOrEnc, pqX3dhSnd, pqX3dhRcv, initSndRatchet, @@ -788,8 +790,11 @@ pqSupportToEnc (PQSupport pq) = PQEncryption pq pqEncToSupport :: PQEncryption -> PQSupport pqEncToSupport (PQEncryption pq) = PQSupport pq -supportOrEnc :: PQSupport -> PQEncryption -> PQSupport -supportOrEnc (PQSupport sup) (PQEncryption enc) = PQSupport $ sup || enc +pqSupportAnd :: PQSupport -> PQSupport -> PQSupport +pqSupportAnd (PQSupport s1) (PQSupport s2) = PQSupport $ s1 && s2 + +pqSupportOrEnc :: PQSupport -> PQEncryption -> PQSupport +pqSupportOrEnc (PQSupport sup) (PQEncryption enc) = PQSupport $ sup || enc replyKEM_ :: Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM replyKEM_ kem_ = \case @@ -858,7 +863,7 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, -- PQ encryption can be enabled or disabled rcEnableKEM' = fromMaybe rcEnableKEM pqEnc_ -- support for PQ encryption (and therefore large headers/small envelopes) can only be enabled, it cannot be disabled - rcSupportKEM' = rcSupportKEM `supportOrEnc` rcEnableKEM' + rcSupportKEM' = rcSupportKEM `pqSupportOrEnc` rcEnableKEM' -- enc_header = HENCRYPT(state.HKs, header) (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen rcSupportKEM') rcAD (msgHeader v) -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header)) @@ -992,7 +997,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do rc' { rcDHRs = rcDHRs', rcKEM = rcKEM', - rcSupportKEM = rcSupportKEM `supportOrEnc` rcEnableKEM', + rcSupportKEM = rcSupportKEM `pqSupportOrEnc` rcEnableKEM', rcEnableKEM = rcEnableKEM', rcSndKEM = PQEncryption sndKEM, rcRcvKEM = PQEncryption rcvKEM, @@ -1138,3 +1143,11 @@ instance AlgorithmI a => FromJSON (Ratchet a) where instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict' + +instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField pqEnc + +instance FromField PQEncryption where fromField f = PQEncryption <$> fromField f + +instance ToField PQSupport where toField (PQSupport pqEnc) = toField pqEnc + +instance FromField PQSupport where fromField f = PQSupport <$> fromField f