pqdr: agent api to confirm PQ encryption support during connection handshake, fix incorrect PQ support (#1032)

* pqdr: agent api to confirm PQ encryption support during connection handshake

* fix CONF, tests

* fix REQ, tests

* remove unused

src/Simplex/Messaging/Agent.hs

@@ -46,6 +46,7 @@ module Simplex.Messaging.Agent
     withInvLock,
     createUser,
     deleteUser,
+    connRequestPQSupport,
     createConnectionAsync,
     joinConnectionAsync,
     allowConnectionAsync,
@@ -160,7 +161,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
-import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, pattern PQEncOn, pattern PQEncOff, pattern PQSupportOn, pattern PQSupportOff)
+import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOn, pattern PQEncOff, pattern PQSupportOn, pattern PQSupportOff)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -566,17 +567,17 @@ newConnNoQueues c userId connId enableNtfs cMode pqSupport = do
   withStore c $ \db -> createNewConn db g cData cMode
 
 joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> m ConnId
-joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo pqSupport subMode = do
+joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do
   withInvLock c (strEncode cReqUri) "joinConnAsync" $ do
-    aVRange <- asks $ ($ pqSupport) . smpAgentVRange . config
-    case crAgentVRange `compatibleVersion` aVRange of
-      Just (Compatible connAgentVersion) -> do
+    compatibleInvitationUri cReqUri pqSup >>= \case
+      Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
         g <- asks random
-        let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
+        let pqSupport = versionPQSupport_ pqSup 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
         pure connId
-      _ -> throwError $ AGENT A_VERSION
+      Nothing -> throwError $ AGENT A_VERSION
 joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo _pqEncryption =
   throwError $ CMD PROHIBITED
 
@@ -690,29 +691,56 @@ joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
   joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
 
 startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> m (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448)
-startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) pqSupport = do
-  AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
-  let e2eVRange = e2eEncryptVRange pqSupport
-  case ( qUri `compatibleVersion` smpClientVRange,
-         e2eRcvParamsUri `compatibleVersion` e2eVRange,
-         crAgentVRange `compatibleVersion` smpAgentVRange pqSupport
-       ) of
-    (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), Just aVersion@(Compatible connAgentVersion)) -> do
+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)
       (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
-      let rcVs = CR.RVersions {current = v, maxSupported = maxVersion e2eVRange}
+      maxSupported <- asks $ maxVersion . ($ pqSup) . e2eEncryptVRange . config
+      let rcVs = CR.RVersions {current = v, maxSupported}
           rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
       q <- newSndQueue userId "" qInfo
       let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
       pure (aVersion, cData, q, rc, e2eSndParams)
-    _ -> throwError $ AGENT A_VERSION
+    Nothing -> throwError $ AGENT A_VERSION
+
+connRequestPQSupport :: AgentMonad' m => PQSupport -> ConnectionRequestUri c -> m (Maybe PQSupport)
+connRequestPQSupport pqSup cReq = case cReq of
+  CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq pqSup
+    where
+      invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = versionPQSupport_ pqSup agentV (Just e2eV)
+  CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq pqSup
+    where
+      ctPQSupported (_, Compatible agentV) = versionPQSupport_ pqSup 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
+  AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
+  pure $
+    (,,)
+      <$> (qUri `compatibleVersion` smpClientVRange)
+      <*> (e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange pqSup)
+      <*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup)
+
+compatibleContactUri :: AgentMonad' m => ConnectionRequestUri 'CMContact -> PQSupport -> m (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
+compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) pqSup = do
+  AgentConfig {smpClientVRange, smpAgentVRange} <- asks config
+  pure $
+    (,)
+      <$> (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_
 
 joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> m ConnId
-joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv =
+joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
   withInvLock c (strEncode inv) "joinConnSrv" $ do
-    (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSupport
+    (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSup
     g <- asks random
     (connId', sq) <- withStore c $ \db -> runExceptT $ do
       r@(connId', _) <- ExceptT $ createSndConn db g cData q
@@ -725,17 +753,13 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport su
         -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
         void $ withStore' c $ \db -> deleteConn db Nothing connId'
         throwError e
-joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo pqEnc subMode srv = do
-  aVRange <- asks $ ($ pqEnc) . smpAgentVRange . config
-  clientVRange <- asks $ smpClientVRange . config
-  case ( qUri `compatibleVersion` clientVRange,
-         crAgentVRange `compatibleVersion` aVRange
-       ) of
-    (Just qInfo, Just vrsn) -> do
-      (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.joinContactInitialKeys pqEnc) subMode srv
+joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
+  compatibleContactUri cReqUri pqSup >>= \case
+    Just (qInfo, vrsn) -> do
+      (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.joinContactInitialKeys pqSup) subMode srv
       sendInvitation c userId qInfo vrsn cReq cInfo
       pure connId'
-    _ -> throwError $ AGENT A_VERSION
+    Nothing -> throwError $ AGENT A_VERSION
 
 joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> m ()
 joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do
@@ -2162,7 +2186,8 @@ 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}
-                      rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport
+                      pqSupport' = versionPQSupport_ pqSupport 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
                   case (agentMsgBody_, skipped) of
@@ -2176,16 +2201,17 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
                           let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
                           confId <- withStore c $ \db -> do
                             setConnAgentVersion db connId agentVersion
+                            when (pqSupport /= pqSupport') $ setConnPQSupport db connId pqSupport'
                             createConfirmation db g newConfirmation
                           let srvs = map qServer $ smpReplyQueues senderConf
-                          notify $ CONF confId srvs connInfo
+                          notify $ CONF confId pqSupport' srvs connInfo
                     _ -> prohibited
                 -- party accepting connection
                 (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
                   g <- asks random
                   withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage . fst >>= \case
                     AgentConnInfo connInfo -> do
-                      notify $ INFO connInfo
+                      notify $ INFO pqSupport connInfo
                       let dhSecret = C.dh' e2ePubKey e2ePrivKey
                       withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion
                       enqueueCmd $ ICDuplexSecure rId senderKey
@@ -2336,12 +2362,19 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
             logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret srvMsgId
             case conn' of
               ContactConnection {} -> do
+                -- show connection request even if invitaion via contact address is not compatible.
+                -- in case invitation not compatible, assume there is no PQ encryption support.
+                pqSupport <- maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq PQSupportOn
+                liftIO $ print pqSupport
                 g <- asks random
                 let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
                 invId <- withStore c $ \db -> createInvitation db g newInv
                 let srvs = L.map qServer $ crSmpQueues crData
-                notify $ REQ invId srvs cInfo
+                notify $ REQ invId pqSupport srvs cInfo
               _ -> prohibited
+            where
+              pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) =
+                versionPQSupport_ PQSupportOn agentVersion (Just v)
 
           qDuplex :: Connection c -> String -> (Connection 'CDuplex -> m ()) -> m ()
           qDuplex conn' name action = case conn' of

src/Simplex/Messaging/Agent/Protocol.hs

@@ -374,12 +374,12 @@ data ACommand (p :: AParty) (e :: AEntity) where
   NEW :: Bool -> AConnectionMode -> InitialKeys -> SubscriptionMode -> ACommand Client AEConn -- response INV
   INV :: AConnectionRequestUri -> ACommand Agent AEConn
   JOIN :: Bool -> AConnectionRequestUri -> PQSupport -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK
-  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
+  CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
-  REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
+  REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
   ACPT :: InvitationId -> PQSupport -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
   RJCT :: InvitationId -> ACommand Client AEConn
-  INFO :: ConnInfo -> ACommand Agent AEConn
+  INFO :: PQSupport -> ConnInfo -> ACommand Agent AEConn
   CON :: PQEncryption -> ACommand Agent AEConn -- notification that connection is established
   SUB :: ACommand Client AEConn
   END :: ACommand Agent AEConn
@@ -1748,9 +1748,9 @@ commandP binaryP =
       ACmdTag SAgent e cmd ->
         ACmd SAgent e <$> case cmd of
           INV_ -> s (INV <$> strP)
-          CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
-          REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
-          INFO_ -> s (INFO <$> binaryP)
+          CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strListP <* A.space <*> binaryP)
+          REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strP_ <*> binaryP)
+          INFO_ -> s (INFO <$> pqSupP <*> binaryP)
           CON_ -> s (CON <$> strP)
           END_ -> pure END
           CONNECT_ -> s (CONNECT <$> strP_ <*> strP)
@@ -1805,13 +1805,13 @@ serializeCommand :: ACommand p e -> ByteString
 serializeCommand = \case
   NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode)
   INV cReq -> s (INV_, cReq)
-  JOIN ntfs cReq pqEnc subMode cInfo -> s (JOIN_, ntfs, cReq, pqEnc, subMode, Str $ serializeBinary cInfo)
-  CONF confId srvs cInfo -> B.unwords [s CONF_, confId, strEncodeList srvs, serializeBinary cInfo]
+  JOIN ntfs cReq pqSup subMode cInfo -> s (JOIN_, ntfs, cReq, pqSup, subMode, Str $ serializeBinary cInfo)
+  CONF confId pqSup srvs cInfo -> B.unwords [s CONF_, confId, s pqSup, strEncodeList srvs, serializeBinary cInfo]
   LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo]
-  REQ invId srvs cInfo -> B.unwords [s REQ_, invId, s srvs, serializeBinary cInfo]
-  ACPT invId pqEnc cInfo -> B.unwords [s ACPT_, invId, s pqEnc, serializeBinary cInfo]
+  REQ invId pqSup srvs cInfo -> B.unwords [s REQ_, invId, s pqSup, s srvs, serializeBinary cInfo]
+  ACPT invId pqSup cInfo -> B.unwords [s ACPT_, invId, s pqSup, serializeBinary cInfo]
   RJCT invId -> B.unwords [s RJCT_, invId]
-  INFO cInfo -> B.unwords [s INFO_, serializeBinary cInfo]
+  INFO pqSup cInfo -> B.unwords [s INFO_, s pqSup, serializeBinary cInfo]
   SUB -> s SUB_
   END -> s END_
   CONNECT p h -> s (CONNECT_, p, h)
@@ -1910,14 +1910,14 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p))
     cmdWithMsgBody (APC e cmd) =
       APC e <$$> case cmd of
-        SEND kem msgFlags body -> SEND kem msgFlags <$$> getBody body
+        SEND pqEnc msgFlags body -> SEND pqEnc msgFlags <$$> getBody body
         MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-        JOIN ntfs qUri kem subMode cInfo -> JOIN ntfs qUri kem subMode <$$> getBody cInfo
-        CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
+        JOIN ntfs qUri pqSup subMode cInfo -> JOIN ntfs qUri pqSup subMode <$$> getBody cInfo
+        CONF confId pqSup srvs cInfo -> CONF confId pqSup srvs <$$> getBody cInfo
         LET confId cInfo -> LET confId <$$> getBody cInfo
-        REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
-        ACPT invId kem cInfo -> ACPT invId kem <$$> getBody cInfo
-        INFO cInfo -> INFO <$$> getBody cInfo
+        REQ invId pqSup srvs cInfo -> REQ invId pqSup srvs <$$> getBody cInfo
+        ACPT invId pqSup cInfo -> ACPT invId pqSup <$$> getBody cInfo
+        INFO pqSup cInfo -> INFO pqSup <$$> getBody cInfo
         _ -> pure $ Right cmd
 
     getBody :: ByteString -> m (Either AgentErrorType ByteString)