mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 00:44:38 +00:00
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
This commit is contained in:
Evgeny Poberezkin
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
+34
-19
@@ -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)
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user