From 07fa75ec498958fdd702a3292ba579f86259cab5 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 7 Mar 2024 08:35:40 +0000 Subject: [PATCH] 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 | 97 +++++++++++++++++-------- src/Simplex/Messaging/Agent/Protocol.hs | 34 ++++----- tests/AgentTests.hs | 53 +++++++++----- tests/AgentTests/FunctionalAPITests.hs | 33 +++++++-- tests/AgentTests/NotificationTests.hs | 4 +- 5 files changed, 144 insertions(+), 77 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 204647ef6..bb335d95c 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/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 :" <> 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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 02aa5e260..465b19a01 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/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) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index bb91725f8..34719e803 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -27,7 +27,7 @@ import GHC.Stack (withFrozenCallStack) import Network.HTTP.Types (urlEncode) import SMPAgentClient import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn) -import Simplex.Messaging.Agent.Protocol hiding (MID) +import Simplex.Messaging.Agent.Protocol hiding (MID, CONF, INFO, REQ) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOn, pattern IKPQOff, pattern PQEncOn, pattern PQSupportOn, pattern PQSupportOff) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -214,12 +214,14 @@ testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, P testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () testDuplexConnection' (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ + pqSup = CR.pqEncToSupport pq ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) - ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:) + ("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) + pqSup' `shouldBe` pqSup alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) - bob <# ("", "alice", INFO "alice's connInfo") + bob <# ("", "alice", A.INFO pqSup "alice's connInfo") bob <# ("", "alice", CON pq) alice <# ("", "bob", CON pq) -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4 @@ -251,13 +253,15 @@ testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) ( testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ + pqSup = CR.pqEncToSupport pq ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") - ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:) + ("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) + pqSup' `shouldBe` pqSup bobConn' `shouldBe` bobConn alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False - bob <# ("", aliceConn, INFO "alice's connInfo") + bob <# ("", aliceConn, A.INFO pqSup "alice's connInfo") bob <# ("", aliceConn, CON pq) alice <# ("", bobConn, CON pq) alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq) @@ -287,14 +291,17 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq abPQ = pqConnectionMode aPQ bPQ + abPQSup = CR.pqEncToSupport abPQ aPQMode = CR.connPQEncryption aPQ bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) - ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:) + ("", "alice_contact", Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:) + pqSup' `shouldBe` bPQ alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK) - ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:) + ("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) + pqSup'' `shouldBe` abPQSup bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK) - alice <# ("", "bob", INFO "bob's connInfo 2") + alice <# ("", "bob", A.INFO abPQSup "bob's connInfo 2") alice <# ("", "bob", CON abPQ) bob <# ("", "alice", CON abPQ) alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ) @@ -303,12 +310,15 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK) let atPQ = pqConnectionMode aPQ tPQ + atPQSup = CR.pqEncToSupport atPQ tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK) - ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:) + ("", "alice_contact", Right (A.REQ aInvId' pqSup3 _ "tom's connInfo")) <- (alice <#:) + pqSup3 `shouldBe` tPQ alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK) - ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:) + ("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:) + pqSup4 `shouldBe` atPQSup tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK) - alice <# ("", "tom", INFO "tom's connInfo 2") + alice <# ("", "tom", A.INFO atPQSup "tom's connInfo 2") alice <# ("", "tom", CON atPQ) tom <# ("", "alice", CON atPQ) alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ) @@ -319,19 +329,22 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO () testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ + pqSup = CR.pqEncToSupport pq ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") - ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:) + ("", aliceContact', Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:) + pqSup' `shouldBe` bPQ aliceContact' `shouldBe` aliceContact ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo") - ("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:) + ("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) + pqSup'' `shouldBe` pqSup aliceConn' `shouldBe` aliceConn bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK) - alice <# ("", bobConn, INFO "bob's connInfo 2") + alice <# ("", bobConn, A.INFO pqSup "bob's connInfo 2") alice <# ("", bobConn, CON pq) bob <# ("", aliceConn, CON pq) @@ -345,7 +358,7 @@ testRejectContactRequest _ alice bob = do ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe") let cReq' = strEncode cReq bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK) - ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:) + ("", "a_contact", Right (A.REQ aInvId PQSupportOff _ "bob's info")) <- (alice <#:) -- RJCT must use correct contact connection alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND) alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK) @@ -486,7 +499,7 @@ testConcurrentMsgDelivery _ alice bob = do ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe") let cReq' = strEncode cReq bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK) - ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:) + ("", "bob2", Right (A.CONF _confId PQSupportOff _ "bob's connInfo")) <- (alice <#:) -- below commands would be needed to accept bob's connection, but alice does not -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) -- bob <# ("", "alice", INFO "alice's connInfo") @@ -553,11 +566,13 @@ connect' :: forall c. Transport c => (c, ByteString, InitialKeys) -> (c, ByteStr connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe") let cReq' = strEncode cReq + pq = pqConnectionMode pqMode1 pqMode2 + pqSup = CR.pqEncToSupport pq h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK) - ("", _, Right (CONF connId _ "info2")) <- (h1 <#:) + ("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:) + pqSup' `shouldBe` pqSup h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) - h2 <# ("", name1, INFO "info1") - let pq = pqConnectionMode pqMode1 pqMode2 + h2 <# ("", name1, A.INFO pqSup "info1") h2 <# ("", name1, CON pq) h1 <# ("", name2, CON pq) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 706f3994f..424a681e2 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -36,6 +36,9 @@ module AgentTests.FunctionalAPITests (##>), (=##>), pattern CON, + pattern CONF, + pattern INFO, + pattern REQ, pattern Msg, pattern Msg', agentCfgV7, @@ -52,6 +55,7 @@ import qualified Data.ByteString.Char8 as B import Data.Either (isRight) import Data.Int (Int64) import Data.List (nub) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M import Data.Maybe (isJust, isNothing) import qualified Data.Set as S @@ -66,7 +70,7 @@ import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMes import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) -import Simplex.Messaging.Agent.Protocol hiding (CON) +import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') @@ -144,6 +148,15 @@ pGet c = do DISCONNECT {} -> pGet c _ -> pure t +pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand 'Agent e +pattern CONF conId srvs connInfo <- A.CONF conId PQSupportOn srvs connInfo + +pattern INFO :: ConnInfo -> ACommand 'Agent 'AEConn +pattern INFO connInfo = A.INFO PQSupportOn connInfo + +pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand 'Agent e +pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo + pattern CON :: ACommand 'Agent 'AEConn pattern CON = A.CON PQEncOn @@ -471,11 +484,12 @@ runAgentClientTest pqSupport alice@AgentClient {} bob baseId = runRight_ $ do (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (IKNoPQ pqSupport) SMSubscribe aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe - ("", _, CONF confId _ "bob's connInfo") <- get alice + ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` pqSupport allowConnection alice bobId confId "alice's connInfo" let pqEnc = CR.pqSupportToEnc pqSupport get alice ##> ("", bobId, A.CON pqEnc) - get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello" @@ -533,12 +547,14 @@ runAgentClientContactTest pqSupport alice bob baseId = runRight_ $ do (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing (IKNoPQ pqSupport) SMSubscribe aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe - ("", _, REQ invId _ "bob's connInfo") <- get alice + ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` pqSupport bobId <- acceptContact alice True invId "alice's connInfo" PQSupportOn SMSubscribe - ("", _, CONF confId _ "alice's connInfo") <- get bob + ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob + liftIO $ pqSup'' `shouldBe` pqSupport allowConnection bob aliceId confId "bob's connInfo" let pqEnc = CR.pqSupportToEnc pqSupport - get alice ##> ("", bobId, INFO "bob's connInfo") + get alice ##> ("", bobId, A.INFO pqSupport "bob's connInfo") get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 @@ -1267,11 +1283,12 @@ makeConnectionForUsers_ :: PQSupport -> AgentClient -> UserId -> AgentClient -> makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe aliceId <- A.joinConnection bob bobUserId True qInfo "bob's connInfo" pqSupport SMSubscribe - ("", _, CONF confId _ "bob's connInfo") <- get alice + ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` pqSupport allowConnection alice bobId confId "alice's connInfo" let pqEnc = CR.pqSupportToEnc pqSupport get alice ##> ("", bobId, A.CON pqEnc) - get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) pure (aliceId, bobId) diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index f815fb808..d8354efed 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -30,6 +30,8 @@ import AgentTests.FunctionalAPITests (##>), (=##>), pattern CON, + pattern CONF, + pattern INFO, pattern Msg, ) import Control.Concurrent (ThreadId, killThread, threadDelay) @@ -50,7 +52,7 @@ import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpSer import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) -import Simplex.Messaging.Agent.Protocol hiding (CON) +import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO) import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String