pqdr: refactor

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

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

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