From 9ee684b0f4051a43d0eee60eb7b9d99ea5262e30 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 30 Jun 2024 08:36:24 +0100 Subject: [PATCH] rfc: faster handshake protocol (#1203) * rfc: faster handshake protocol * update * 1 message * SKEY * use SKEY for both parties * test * update doc * NEW command parameter * add k=s param to queue URI * fix * add sndSecure field to queues * make sender key non-optional in SndQueue (WIP, tests fail) * fast handshake sometimes works (many tests fail) * correctly handle SKEY retries, avoiding to re-generate the keys * handle SKEY retries during async connection * fix most tests (1 test fails) * remove do * fix contact requests encoding/tests * export * fix: ignore duplicate confirmations, fixes testBatchedPendingMessages * do not store sndSecure in store log if it is false to allow server downgrade * add connection invitation encoding tests --- .../duplex-messaging/duplex-creating-v6.mmd | 63 ++ rfcs/2024-06-14-fast-connection.md | 42 + simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 210 +++-- src/Simplex/Messaging/Agent/Client.hs | 35 +- src/Simplex/Messaging/Agent/Protocol.hs | 60 +- src/Simplex/Messaging/Agent/QueryString.hs | 7 +- src/Simplex/Messaging/Agent/Store.hs | 9 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 63 +- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../SQLite/Migrations/M20240624_snd_secure.hs | 36 + .../Store/SQLite/Migrations/agent_schema.sql | 4 +- src/Simplex/Messaging/Client.hs | 11 +- src/Simplex/Messaging/Protocol.hs | 50 +- src/Simplex/Messaging/Server.hs | 38 +- src/Simplex/Messaging/Server/QueueStore.hs | 1 + src/Simplex/Messaging/Server/StoreLog.hs | 7 +- src/Simplex/Messaging/Transport.hs | 10 +- tests/AgentTests/ConnectionRequestTests.hs | 296 ++++--- tests/AgentTests/FunctionalAPITests.hs | 793 ++++++++++-------- tests/AgentTests/NotificationTests.hs | 79 +- tests/AgentTests/SQLiteTests.hs | 11 +- tests/CoreTests/TRcvQueuesTests.hs | 1 + tests/NtfClient.hs | 17 +- tests/SMPAgentClient.hs | 6 +- tests/SMPClient.hs | 24 +- tests/SMPProxyTests.hs | 39 +- tests/ServerTests.hs | 26 +- tests/XFTPAgent.hs | 12 +- tests/XFTPClient.hs | 8 +- 30 files changed, 1184 insertions(+), 779 deletions(-) create mode 100644 protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd create mode 100644 rfcs/2024-06-14-fast-connection.md create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs diff --git a/protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd b/protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd new file mode 100644 index 000000000..183e4bfa9 --- /dev/null +++ b/protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd @@ -0,0 +1,63 @@ +sequenceDiagram + participant A as Alice + participant AA as Alice's
agent + participant AS as Alice's
server + participant BS as Bob's
server + participant BA as Bob's
agent + participant B as Bob + + note over AA, BA: status (receive/send): NONE/NONE + + note over A, AA: 1. request connection
from agent + A ->> AA: NEW: create
duplex connection + + note over AA, AS: 2. create Alice's SMP queue + AA ->> AS: NEW: create SMP queue + AS ->> AA: IDS: SMP queue IDs + note over AA: status: NEW/NONE + + AA ->> A: INV: invitation
to connect + + note over A, B: 3. out-of-band invitation + A ->> B: OOB: invitation to connect + + note over BA, B: 4. accept connection + B ->> BA: JOIN:
via invitation info + note over BA: status: NONE/NEW + + note over BA, AS: 5. secure Alice's SMP queue + BA ->> AS: SKEY: secure queue (this command needs to be proxied) + note over BA: status: NONE/SECURED + + note over BA, BS: 6. create Bob's SMP queue + BA ->> BS: NEW: create SMP queue + BS ->> BA: IDS: SMP queue IDs + note over BA: status: NEW/SECURED + + note over BA, AA: 7. confirm Alice's SMP queue + BA ->> AS: SEND: Bob's info without sender's key (SMP confirmation with reply queues) + note over BA: status: NEW/CONFIRMED + + AS ->> AA: MSG: Bob's info without
sender server key + note over AA: status: CONFIRMED/NEW + AA ->> AS: ACK: confirm message + + note over AA, BS: 8. secure Bob's SMP queue + AA ->> BS: SKEY: secure queue (this command needs to be proxied) + note over BA: status: CONFIRMED/SECURED + + AA ->> BS: SEND: Alice's info without sender's server key (SMP confirmation without reply queues) + note over AA: status: CONFIRMED/CONFIRMED + + note over AA, A: 9. notify Alice
about connection success
(no HELLO needed in v6) + AA ->> A: CON: connected + note over AA: status: ACTIVE/ACTIVE + + BS ->> BA: MSG: Alice's info without
sender's server key + note over BA: status: CONFIRMED/CONFIRMED + BA ->> B: INFO: Alice's info + BA ->> BS: ACK: confirm message + + note over BA, B: 10. notify Bob
about connection success + BA ->> B: CON: connected + note over BA: status: ACTIVE/ACTIVE diff --git a/rfcs/2024-06-14-fast-connection.md b/rfcs/2024-06-14-fast-connection.md new file mode 100644 index 000000000..000f0ef10 --- /dev/null +++ b/rfcs/2024-06-14-fast-connection.md @@ -0,0 +1,42 @@ +# Faster connection establishment + +## Problem + +SMP protocol is unidirectional, and to create a connection users have to agree two messaging queues. + +V1 of handshake protocol required 5 messages and multiple HELLO sent between the users, which consumed a lot of traffic. + +V2 of handshake protocol was optimized to remove multiple HELLO and also REPLY message, thanks to including queue address together with the key to secure this queue into the confirmation message. + +This eliminated unnecessary traffic from repeated HELLOs, but still requires 4 messages in total and 2 times of each client being online. It is perceived by the users as "it didn't work" (because they see "connecting" after using the link) or "we have to be online at the same time" (and even in this case it is slow on bad network). This hurts usability and creates churn of the new users, as unless people are onboarded by the friends who know how the app works, they cannot figure out how to connect. + +Ideally, we want to have handshake protocol design when an accepting user can send messages straight after using the link (their client says "connected") and the initiating client can send messages as soon as it received confirmation message with the profile. + +This RFC proposes modifications to SMP and SMP Agent protocols to reduce the number of required messages to 2 and allows accepting client to send messages straight after using the link (and sending the confirmation), before receiving the profile of the initiating client in the second message, and the initiating client can send the messages straight after processing the confirmation and sending its own confirmation. + +## Solution + +The current protocol design allows additional confirmation step where the initiating client can confirm the connection having received the profile of the sender. We don't use it in the UI - this confirmation is done automatically and unconditionally. + +Instead of requiring the initiating client to secure its queue with sender's key, we can allow the accepting client to secure it with the additional SKEY command. This would avoid "connecting" state but would introduce "Profile unknown" state where the accepting client does not yet have the profile of the initiating client. In this case we could also use the non-optional alias created during the connection (or have something like "Add alias to be able to send messages immediately" and show warning if the user proceeds without it). + +The additional advantage here is that if the queue of the initiating client was removed, the connection will not procede to create additional queue, failing faster. + +These are the proposed changes: + +1. Modify NEW command to add flag allowing sender to secure the queue (it should not be allowed if queue is created for the contact address). +2. Include flag into the invitation link URI and in reply address encoding that queue(s) can be secured by the sender (to avoid coupling with the protocol version and preserve the possibility of the longer handshakes). +3. Add SKEY command to SMP protocol to allow the sender securing the message queue. +4. This command has to be supported by SMP proxy as well, so that the sender does not connect to the recipient's server directly. +5. Accepting client will secure the messaging queue before sending the confirmation to it. +6. Initiating client will secure the messaging queue before sending the confirmation. + +See [this sequence diagram](../protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd) for the updated handshake protocol. + +Changes to threat model: the attacker who compromised TLS and knows the queue address can block the connection, as the protocol no longer requires the recipient to decrypt the confirmation to secure the queue. + +Possibly, "fast connection" should be an option in Privacy & security settings. + +## Implementation questions + +Currently we store received confirmations in the database, so that the client can confirm them. This becomes unnecessary. diff --git a/simplexmq.cabal b/simplexmq.cabal index 2474cebd4..d46b58dc2 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -134,6 +134,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240518_servers_stats + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 0c433cfed..121c1a1f4 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -175,7 +175,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth, sndAuthKeySMPClientVersion) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) @@ -751,7 +751,8 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwE e + let sndSecure = case cMode of SCMInvitation -> True; SCMContact -> False + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode sndSecure `catchAgentError` \e -> liftIO (print e) >> throwE e atomically $ incSMPServerStat c userId srv connCreated rq' <- withStore c $ \db -> updateNewConnRcv db connId rq lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId @@ -771,7 +772,7 @@ newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Connection newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of CRInvitationUri {} -> lift (compatibleInvitationUri cReq) >>= \case - Just (_, (Compatible (CR.E2ERatchetParams v _ _ _)), aVersion) -> create aVersion (Just v) + Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v) Nothing -> throwE $ AGENT A_VERSION CRContactUri {} -> lift (compatibleContactUri cReq) >>= \case @@ -793,10 +794,10 @@ joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do _ -> getSMPServer c userId joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv -startJoinInvitation :: UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) -startJoinInvitation userId connId enableNtfs cReqUri pqSup = +startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) +startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case - Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), Compatible connAgentVersion) -> do + Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) @@ -805,9 +806,13 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup = maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - q <- lift $ newSndQueue userId "" qInfo + -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out + -- e2ePubKey is always present, it's Maybe historically + (q, e2ePubKey) <- case sq_ of + Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k) + _ -> lift $ newSndQueue userId "" qInfo let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - pure (cData, q, rc, e2eSndParams) + pure (cData, q, e2ePubKey, rc, e2eSndParams) Nothing -> throwE $ AGENT A_VERSION connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) @@ -843,7 +848,7 @@ versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && ma joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ConnId joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = withInvLock c (strEncode inv) "joinConnSrv" $ do - (cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSup + (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup g <- asks random (connId', sq) <- withStore c $ \db -> runExceptT $ do r@(connId', _) <- @@ -853,7 +858,10 @@ joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo p liftIO $ createRatchet db connId' rc pure r let cData' = (cData :: ConnData) {connId = connId'} - tryError (confirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case + -- joinConnSrv is only used on user interaction, and its failure is permanent, + -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key, + -- similar to how joinConnAsync does that. + tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case Right _ -> pure connId' Left e -> do -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md @@ -869,17 +877,26 @@ joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM () joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do - (cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSupport - q' <- withStore c $ \db -> runExceptT $ do - liftIO $ createRatchet db connId rc - ExceptT $ updateNewConnSnd db connId q - confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) subMode + SomeConn cType conn <- withStore c (`getConn` connId) + case conn of + NewConnection _ -> doJoin Nothing + SndConnection _ sq -> doJoin $ Just sq + _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType + where + doJoin :: Maybe SndQueue -> AM () + doJoin sq_ = do + (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport + sq' <- withStore c $ \db -> runExceptT $ do + liftIO $ createRatchet db connId rc + maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_ + secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode + let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId @@ -1156,8 +1173,11 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do withStore c $ \db -> runExceptT $ (,) <$> ExceptT (getConn db connId) <*> ExceptT (getAcceptedConfirmation db connId) case conn of RcvConnection cData rq -> do - secure rq senderKey - mapM_ (connectReplyQueues c cData ownConnInfo) (L.nonEmpty $ smpReplyQueues senderConf) + mapM_ (secure rq) senderKey + mapM_ (connectReplyQueues c cData ownConnInfo Nothing) (L.nonEmpty $ smpReplyQueues senderConf) + -- duplex connection is matched to handle SKEY retries + DuplexConnection cData _ (sq :| _) -> + mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf) _ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd) ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey @@ -1332,7 +1352,7 @@ submitPendingMsg c cData sq = do void $ getDeliveryWorker True c cData sq runSmpQueueMsgDelivery :: AgentClient -> ConnData -> SndQueue -> (Worker, TMVar ()) -> AM () -runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userId, server} (Worker {doWork}, qLock) = do +runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userId, server, sndSecure} (Worker {doWork}, qLock) = do AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do atomically $ endAgentOperation c AOSndNetwork @@ -1380,7 +1400,6 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI Just _ -> connError msgId NOT_AVAILABLE -- party joining connection _ -> connError msgId NOT_ACCEPTED - AM_REPLY_ -> notifyDel msgId err AM_A_MSG_ -> notifyDel msgId err AM_A_RCVD_ -> notifyDel msgId err AM_QCONT_ -> notifyDel msgId err @@ -1409,10 +1428,11 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI retrySndOp c $ loop riMode Right proxySrv_ -> do case msgType of - AM_CONN_INFO -> setConfirmed - AM_CONN_INFO_REPLY -> setConfirmed + AM_CONN_INFO + | sndSecure -> notify (CON pqEncryption) >> setStatus Active + | otherwise -> setStatus Confirmed + AM_CONN_INFO_REPLY -> setStatus Confirmed AM_RATCHET_INFO -> pure () - AM_REPLY_ -> pure () AM_HELLO_ -> do withStore' c $ \db -> setSndQueueStatus db sq Active case rq_ of @@ -1469,9 +1489,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI AM_EREADY_ -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId where - setConfirmed = do + setStatus status = do withStore' c $ \db -> do - setSndQueueStatus db sq Confirmed + setSndQueueStatus db sq status when (isJust rq_) $ removeConfirmations db connId where notifyDelMsgs :: InternalId -> AgentErrorType -> UTCTime -> AM () @@ -1558,13 +1578,14 @@ switchConnection' c connId = _ -> throwE $ CMD PROHIBITED "switchConnection: not duplex" switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats -switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do +switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId, connAgentVersion} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do checkRQSwchStatus rq RSSwitchStarted clientVRange <- asks $ smpClientVRange . config -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth - (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe + let sndSecure = connAgentVersion >= sndAuthKeySMPAgentVersion + (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe sndSecure let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' lift $ addNewQueueSubscription c rq'' tSess sessId @@ -2191,7 +2212,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) notifyErr connId = notify' connId . ERR . protocolClientError SMP (B.unpack $ strEncode srv) processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM () processSMP - rq@RcvQueue {rcvId = rId, e2ePrivKey, e2eDhSecret, status} + rq@RcvQueue {rcvId = rId, sndSecure, e2ePrivKey, e2eDhSecret, status} conn cData@ConnData {userId, connId, connAgentVersion, ratchetSyncState = rss} smpMsg = @@ -2220,7 +2241,10 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) let e2eDh = C.dh' e2ePubKey e2ePrivKey decryptClientMessage e2eDh clientMsg >>= \case (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) -> - smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + smpConfirmation srvMsgId conn (Just senderKey) e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + (SMP.PHEmpty, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) + | sndSecure -> smpConfirmation srvMsgId conn Nothing e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + | otherwise -> prohibited "handshake: missing sender key" >> ack (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) -> smpInvitation srvMsgId conn connReq connInfo >> ack _ -> prohibited "handshake: incorrect state" >> ack @@ -2348,7 +2372,12 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) pure $ Just (internalId, msgMeta, aMessage, rc) _ -> pure Nothing _ -> prohibited "msg: bad client msg" >> ack - _ -> prohibited "msg: no keys" >> ack + (Just e2eDh, Just _) -> + decryptClientMessage e2eDh clientMsg >>= \case + -- this is a repeated confirmation delivery because ack failed to be sent + (_, AgentConfirmation {}) -> ack + _ -> prohibited "msg: public header" >> ack + (Nothing, Nothing) -> prohibited "msg: no keys" >> ack updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c) updateConnVersion conn' cData' msgAgentVersion = do aVRange <- asks $ smpAgentVRange . config @@ -2385,8 +2414,10 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m () notify = notify' connId - prohibited :: String -> AM () - prohibited = notify . ERR . AGENT . A_PROHIBITED + prohibited :: Text -> AM () + prohibited s = do + logError $ "prohibited: " <> s + notify . ERR . AGENT $ A_PROHIBITED $ T.unpack s enqueueCmd :: InternalCommand -> AM () enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand @@ -2413,7 +2444,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) parseMessage :: Encoding a => ByteString -> AM a parseMessage = liftEither . parse smpP (AGENT A_MESSAGE) - smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () + smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config @@ -2436,8 +2467,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) case (agentMsgBody_, skipped) of (Right agentMsgBody, CR.SMDNoChange) -> parseMessage agentMsgBody >>= \case - AgentConnInfoReply smpQueues connInfo -> + AgentConnInfoReply smpQueues connInfo -> do processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} + withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 where processConf connInfo senderConf = do @@ -2450,14 +2482,21 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) notify $ CONF confId pqSupport' srvs connInfo _ -> prohibited "conf: decrypt error or skipped" -- party accepting connection - (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do + (DuplexConnection _ (rq'@RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do g <- asks random - withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage . fst >>= \case + (agentMsgBody, pqEncryption) <- withStore c $ \db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo + parseMessage agentMsgBody >>= \case AgentConnInfo connInfo -> do notify $ INFO pqSupport connInfo let dhSecret = C.dh' e2ePubKey e2ePrivKey - withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion - enqueueCmd $ ICDuplexSecure rId senderKey + withStore' c $ \db -> do + setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion + updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) + case senderKey of + Just k -> enqueueCmd $ ICDuplexSecure rId k + Nothing -> do + notify $ CON pqEncryption + withStore' c $ \db -> setRcvQueueStatus db rq' Active _ -> prohibited "conf: not AgentConnInfo" _ -> prohibited "conf: incorrect state" _ -> prohibited "conf: status /= new" @@ -2533,21 +2572,17 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do - -- move inside case? - sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo + (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - case (sndPublicKey, e2ePubKey) of - (Just sndPubKey, Just dhPublicKey) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) - let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} - void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)] - sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY - let sqs'' = updatedQs sq1 sqs' <> [sq2] - conn' = DuplexConnection cData' rqs sqs'' - notify . SWITCH QDSnd SPStarted $ connectionStats conn' - _ -> qError "absent sender keys" + logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) + let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} + void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)] + sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY + let sqs'' = updatedQs sq1 sqs' <> [sq2] + conn' = DuplexConnection cData' rqs sqs'' + notify . SWITCH QDSnd SPStarted $ connectionStats conn' _ -> qError "QADD: won't delete all snd queues in connection" _ -> qError "QADD: replaced queue address is not found in connection" _ -> throwE $ AGENT A_VERSION @@ -2717,23 +2752,30 @@ switchStatusError q expected actual = <> (", expected=" <> show expected) <> (", actual=" <> show actual) -connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> AM () -connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do +connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM () +connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config case qInfo `proveCompatible` clientVRange of Nothing -> throwE $ AGENT A_VERSION Just qInfo' -> do - sq <- lift $ newSndQueue userId connId qInfo' - sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq + -- in case of SKEY retry the connection is already duplex + sq' <- maybe upgradeConn pure sq_ + agentSecureSndQueue c sq' enqueueConfirmation c cData sq' ownConnInfo Nothing + where + upgradeConn = do + (sq, _) <- lift $ newSndQueue userId connId qInfo' + withStore c $ \db -> upgradeRcvConnToDuplex db connId sq -confirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode lift $ submitPendingMsg c cData sq -confirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode void $ sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed @@ -2742,11 +2784,19 @@ confirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connI mkConfirmation aMessage = do currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do - void . liftIO $ updateSndIds db connId + let agentMsgBody = smpEncode aMessage + (_, internalSndId, _) <- liftIO $ updateSndIds db connId + liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody) let pqEnc = CR.pqSupportToEnc pqSupport - (encConnInfo, _) <- agentRatchetEncrypt db cData (smpEncode aMessage) e2eEncConnInfoLength (Just pqEnc) currentE2EVersion + (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo} +agentSecureSndQueue :: AgentClient -> SndQueue -> AM () +agentSecureSndQueue c sq@SndQueue {sndSecure, status} = + when (sndSecure && status == New) $ do + secureSndQueue c sq + withStore' c $ \db -> setSndQueueStatus db sq Secured + mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage mkAgentConfirmation c cData sq srv connInfo subMode = do qInfo <- createReplyQueue c cData sq subMode srv @@ -2822,26 +2872,28 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_ -newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' NewSndQueue -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' (NewSndQueue, C.PublicKeyX25519) +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g - pure - SndQueue - { userId, - connId, - server = smpServer, - sndId = senderId, - sndPublicKey = Just sndPublicKey, - sndPrivateKey, - e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, - e2ePubKey = Just e2ePubKey, - status = New, - dbQueueId = DBNewQueue, - primary = True, - dbReplaceQueueId = Nothing, - sndSwchStatus = Nothing, - smpClientVersion - } + let sq = + SndQueue + { userId, + connId, + server = smpServer, + sndId = senderId, + sndSecure, + sndPublicKey, + sndPrivateKey, + e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, + e2ePubKey = Just e2ePubKey, + status = New, + dbQueueId = DBNewQueue, + primary = True, + dbReplaceQueueId = Nothing, + sndSwchStatus = Nothing, + smpClientVersion + } + pure (sq, e2ePubKey) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index ec8424745..2f48ee17e 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -53,6 +53,7 @@ module Simplex.Messaging.Agent.Client temporaryOrHostError, serverHostError, secureQueue, + secureSndQueue, enableQueueNotifications, enableQueuesNtfs, disableQueueNotifications, @@ -73,7 +74,6 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, - agentCbEncrypt, agentCbDecrypt, cryptoError, sendAck, @@ -240,6 +240,7 @@ import Simplex.Messaging.Protocol RcvNtfPublicDhKey, SMPMsgMeta (..), SProtocolType (..), + SenderCanSecure, SndPublicAuthKey, SubscriptionMode (..), UserProtocol, @@ -1196,11 +1197,14 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g - (sKey, _) <- atomically $ C.generateAuthKeyPair sa g + (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe - liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey + SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True + liftError (testErr TSSecureQueue) $ + if sndSecure + then secureSndSMPQueue smp spKey sndId sKey + else secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok @@ -1307,8 +1311,8 @@ getSessionMode :: AgentClient -> IO TransportSessionMode getSessionMode = atomically . fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do +newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g @@ -1316,9 +1320,9 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- liftIO $ mkTransportSession c userId srv connId - (sessId, QIK {rcvId, sndId, rcvPublicDhKey}) <- + (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- withClient c tSess "NEW" $ \(SMPConnectedClient smp _) -> - (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode + (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue @@ -1331,6 +1335,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do e2ePrivKey, e2eDhSecret = Nothing, sndId, + sndSecure, status = New, dbQueueId = DBNewQueue, primary = True, @@ -1340,7 +1345,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do clientNtfCreds = Nothing, deleteErrors = 0 } - qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey + qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure pure (rq, qUri, tSess, sessId) processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM () @@ -1524,10 +1529,11 @@ logSecret bs = encode $ B.take 3 bs {-# INLINE logSecret #-} sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) -sendConfirmation c sq@SndQueue {userId, server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do - let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation +sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do + let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing) + clientMsg = SMP.ClientMessage privHdr agentConfirmation msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg - sendOrProxySMPMessage c userId server "" Nothing sndId (MsgFlags {notification = True}) msg + sendOrProxySMPMessage c userId server "" spKey sndId (MsgFlags {notification = True}) msg sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) @@ -1568,6 +1574,11 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey +secureSndQueue :: AgentClient -> SndQueue -> AM () +secureSndQueue c sq@SndQueue {sndId, sndPrivateKey, sndPublicKey} = + withSMPClient c sq "SKEY " $ \smp -> + secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey + enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c rq "NKEY " $ \smp -> diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index d6bbc13ca..b123fc1ec 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Protocol ratchetSyncSMPAgentVersion, deliveryRcptsSMPAgentVersion, pqdrSMPAgentVersion, + sndAuthKeySMPAgentVersion, currentSMPAgentVersion, supportedSMPAgentVRange, e2eEncConnInfoLength, @@ -208,6 +209,7 @@ import Simplex.Messaging.Protocol legacyStrEncodeServer, noAuthSrv, sameSrvAddr, + sndAuthKeySMPClientVersion, srvHostnamesSMPClientVersion, pattern ProtoServerWithAuth, pattern SMPServer, @@ -227,6 +229,7 @@ import UnliftIO.Exception (Exception) -- 3 - support ratchet renegotiation (6/30/2023) -- 4 - delivery receipts (7/13/2023) -- 5 - post-quantum double ratchet (3/14/2024) +-- 6 - secure reply queues with provided keys (6/14/2024) data SMPAgentVersion @@ -251,11 +254,17 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4 pqdrSMPAgentVersion :: VersionSMPA pqdrSMPAgentVersion = VersionSMPA 5 +sndAuthKeySMPAgentVersion :: VersionSMPA +sndAuthKeySMPAgentVersion = VersionSMPA 6 + +minSupportedSMPAgentVersion :: VersionSMPA +minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion + currentSMPAgentVersion :: VersionSMPA -currentSMPAgentVersion = VersionSMPA 5 +currentSMPAgentVersion = VersionSMPA 6 supportedSMPAgentVRange :: VersionRangeSMPA -supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion +supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion -- it is shorter to allow all handshake headers, -- including E2E (double-ratchet) parameters and @@ -685,7 +694,7 @@ data MsgMeta = MsgMeta data SMPConfirmation = SMPConfirmation { -- | sender's public key to use for authentication of sender's commands at the recepient's server - senderKey :: SndPublicAuthKey, + senderKey :: Maybe SndPublicAuthKey, -- | sender's DH public key for simple per-queue e2e encryption e2ePubKey :: C.PublicKeyX25519, -- | sender's information to be associated with the connection, e.g. sender's profile information @@ -775,12 +784,12 @@ instance Encoding AgentMessage where 'M' -> AgentMessage <$> smpP <*> smpP _ -> fail "bad AgentMessage" +-- internal type for storing message type in the database data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_RATCHET_INFO | AM_HELLO_ - | AM_REPLY_ | AM_A_MSG_ | AM_A_RCVD_ | AM_QCONT_ @@ -797,7 +806,6 @@ instance Encoding AgentMessageType where AM_CONN_INFO_REPLY -> "D" AM_RATCHET_INFO -> "S" AM_HELLO_ -> "H" - AM_REPLY_ -> "R" AM_A_MSG_ -> "M" AM_A_RCVD_ -> "V" AM_QCONT_ -> "QC" @@ -812,7 +820,6 @@ instance Encoding AgentMessageType where 'D' -> pure AM_CONN_INFO_REPLY 'S' -> pure AM_RATCHET_INFO 'H' -> pure AM_HELLO_ - 'R' -> pure AM_REPLY_ 'M' -> pure AM_A_MSG_ 'V' -> pure AM_A_RCVD_ 'Q' -> @@ -1004,7 +1011,8 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where where queryStr = strEncode . QSP QEscape $ - [("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)] + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + [("v", strEncode crAgentVRange), ("smp", B.intercalate ";" $ map strEncode $ L.toList crSmpQueues)] <> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData strP = connReqUriP' (Just SSSimplex) @@ -1026,7 +1034,7 @@ connReqUriP overrideScheme = do crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?" query <- strP aVRange <- queryParam "v" query - crSmpQueues <- queryParam "smp" query + crSmpQueues <- queryParamParser queuesP "smp" query let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query crData = ConnReqUriData {crScheme, crAgentVRange = aVRange, crSmpQueues, crClientData} case crMode of @@ -1038,8 +1046,10 @@ connReqUriP overrideScheme = do CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange} where crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + queuesP = L.fromList <$> (strDecode <$?> A.takeTill (== ';')) `A.sepBy1'` A.char ';' adjustAgentVRange vr = - let v = max duplexHandshakeSMPAgentVersion $ minVersion vr + let v = max minSupportedSMPAgentVersion $ minVersion vr in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr) instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where @@ -1117,14 +1127,16 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: deriving (Eq, Show) instance Encoding SMPQueueInfo where - smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}) + smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure) | clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey) | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey) smpP = do clientVersion <- smpP smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP (senderId, dhPublicKey) <- smpP - pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} -- This instance seems contrived and there was a temptation to split a common part of both types. -- But this is created to allow backward and forward compatibility where SMPQueueUri @@ -1150,7 +1162,8 @@ data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress : data SMPQueueAddress = SMPQueueAddress { smpServer :: SMPServer, senderId :: SMP.SenderId, - dhPublicKey :: C.PublicKeyX25519 + dhPublicKey :: C.PublicKeyX25519, + sndSecure :: Bool } deriving (Eq, Show) @@ -1177,37 +1190,42 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId' {-# INLINE sameQAddress #-} instance StrEncoding SMPQueueUri where - strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey}) + strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, sndSecure}) | minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam) where query = strEncode . QSP QEscape - queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] + queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> [("k", "s") | sndSecure] srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)] hs = L.tail $ host srv strP = do srv@ProtocolServer {host = h :| host} <- strP <* A.char '/' senderId <- strP <* optional (A.char '/') <* A.char '#' - (vr, hs, dhPublicKey) <- unversioned <|> versioned + (vr, hs, dhPublicKey, sndSecure) <- versioned <|> unversioned let srv' = srv {host = h :| host <> hs} smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv' - pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey} + pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} where - unversioned = (versionToRange initialSMPClientVersion,[],) <$> strP <* A.endOfInput + unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput versioned = do dhKey_ <- optional strP query <- optional (A.char '/') *> A.char '?' *> strP vr <- queryParam "v" query dhKey <- maybe (queryParam "dh" query) pure dhKey_ hs_ <- queryParam_ "srv" query - pure (vr, maybe [] thList_ hs_, dhKey) + let sndSecure = queryParamStr "k" query == Just "s" + pure (vr, maybe [] thList_ hs_, dhKey, sndSecure) instance Encoding SMPQueueUri where - smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}) = - smpEncode (clientVRange, smpServer, senderId, dhPublicKey) + smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure) + | otherwise = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey) smpP = do (clientVRange, smpServer, senderId, dhPublicKey) <- smpP - pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} data ConnectionRequestUri (m :: ConnectionMode) where CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation diff --git a/src/Simplex/Messaging/Agent/QueryString.hs b/src/Simplex/Messaging/Agent/QueryString.hs index fee552a01..9dc0e94a9 100644 --- a/src/Simplex/Messaging/Agent/QueryString.hs +++ b/src/Simplex/Messaging/Agent/QueryString.hs @@ -24,9 +24,12 @@ instance StrEncoding QueryStringParams where strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n') queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a -queryParam name q = +queryParam = queryParamParser strP + +queryParamParser :: Parser a -> ByteString -> QueryStringParams -> Parser a +queryParamParser p name q = case queryParamStr name q of - Just p -> either fail pure $ parseAll strP p + Just s -> either fail pure $ parseAll p s _ -> fail $ "no qs param " <> B.unpack name queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index b9ffecbbd..baec2ef93 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -44,6 +44,7 @@ import Simplex.Messaging.Protocol RcvPrivateAuthKey, SndPrivateAuthKey, SndPublicAuthKey, + SenderCanSecure, VersionSMPC, ) import qualified Simplex.Messaging.Protocol as SMP @@ -83,6 +84,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue e2eDhSecret :: Maybe C.DhSecretX25519, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | queue status status :: QueueStatus, -- | database queue ID (within connection) @@ -138,9 +141,11 @@ data StoredSndQueue (q :: QueueStored) = SndQueue server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | key pair used by the sender to authorize transmissions -- TODO combine keys to key pair so that types match - sndPublicKey :: Maybe SndPublicAuthKey, + sndPublicKey :: SndPublicAuthKey, sndPrivateKey :: SndPrivateAuthKey, -- | DH public key used to negotiate per-queue e2e encryption e2ePubKey :: Maybe C.PublicKeyX25519, @@ -372,7 +377,7 @@ instance StrEncoding AgentCommandTag where data InternalCommand = ICAck SMP.RecipientId MsgId | ICAckDel SMP.RecipientId MsgId InternalId - | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey + | ICAllowSecure SMP.RecipientId (Maybe SMP.SndPublicAuthKey) | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey | ICDeleteConn | ICDeleteRcvQueue SMP.RecipientId diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 434344c89..d4cd99b39 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -102,8 +102,10 @@ module Simplex.Messaging.Agent.Store.SQLite -- Messages updateRcvIds, createRcvMsg, + updateRcvMsgHash, updateSndIds, createSndMsg, + updateSndMsgHash, createSndMsgDelivery, getSndMsgViaRcpt, updateSndMsgRcpt, @@ -811,7 +813,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds = Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) Nothing -> (Nothing, Nothing, Nothing, Nothing) -type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) +type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) smpConfirmation :: SMPConfirmationRow -> SMPConfirmation smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = @@ -958,10 +960,10 @@ updateRcvIds db connId = do pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () -createRcvMsg db connId rq rcvMsgData = do +createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do insertRcvMsgBase_ db connId rcvMsgData insertRcvMsgDetails_ db connId rq rcvMsgData - updateHashRcv_ db connId rcvMsgData + updateRcvMsgHash db connId sndMsgId internalRcvId internalHash updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash) updateSndIds db connId = do @@ -972,10 +974,10 @@ updateSndIds db connId = do pure (internalId, internalSndId, prevSndHash) createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () -createSndMsg db connId sndMsgData = do +createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do insertSndMsgBase_ db connId sndMsgData insertSndMsgDetails_ db connId sndMsgData - updateHashSnd_ db connId sndMsgData + updateSndMsgHash db connId internalSndId internalHash createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO () createSndMsgDelivery db connId SndQueue {dbQueueId} msgId = @@ -1866,28 +1868,34 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT INTO rcv_queues - (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} -- * createSndConn helpers insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT OR REPLACE INTO snd_queues - (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored @@ -2009,7 +2017,7 @@ rcvQueueQuery :: Query rcvQueueQuery = [sql| SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, - q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, + q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status, q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret FROM rcv_queues q @@ -2018,17 +2026,17 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) - :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) + :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById db connId dbRcvId = @@ -2049,7 +2057,7 @@ sndQueueQuery :: Query sndQueueQuery = [sql| SELECT - c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, + c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version FROM snd_queues q @@ -2058,17 +2066,18 @@ sndQueueQuery = |] toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> SndQueue toSndQueue - ( (userId, keyHash, connId, host, port, sndId) - :. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) + ( (userId, keyHash, connId, host, port, sndId, sndSecure) + :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) ) = let server = SMPServer host port keyHash - in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} + sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey + in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) getSndQueueById db connId dbSndId = @@ -2147,10 +2156,10 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna ] DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) -updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () -updateHashRcv_ dbConn connId RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalHash, internalRcvId} = +updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () +updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = DB.executeNamed - dbConn + db -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections @@ -2226,10 +2235,10 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} = ":previous_msg_hash" := prevMsgHash ] -updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO () -updateHashSnd_ dbConn connId SndMsgData {..} = +updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () +updateSndMsgHash db connId internalSndId internalHash = DB.executeNamed - dbConn + db -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 340063f5c..1b8990ab8 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -73,6 +73,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wai import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240518_servers_stats +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) @@ -114,7 +115,8 @@ schemaMigrations = ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays), - ("m20240518_servers_stats", m20240518_servers_stats, Just down_m20240518_servers_stats) + ("m20240518_servers_stats", m20240518_servers_stats, Just down_m20240518_servers_stats), + ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs new file mode 100644 index 000000000..7f82d4ecf --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240624_snd_secure :: Query +m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB NOT NULL,', 'sender_key BLOB,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] + +down_m20240624_snd_secure :: Query +down_m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues DROP COLUMN snd_secure; +ALTER TABLE snd_queues DROP COLUMN snd_secure; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB,', 'sender_key BLOB NOT NULL,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 50cf6d74a..80af08989 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -55,6 +55,7 @@ CREATE TABLE rcv_queues( server_key_hash BLOB, switch_status TEXT, deleted INTEGER NOT NULL DEFAULT 0, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -77,6 +78,7 @@ CREATE TABLE snd_queues( replace_snd_queue_id INTEGER NULL, server_key_hash BLOB, switch_status TEXT, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, snd_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE @@ -132,7 +134,7 @@ CREATE TABLE conn_confirmations( confirmation_id BLOB NOT NULL PRIMARY KEY, conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, e2e_snd_pub_key BLOB NOT NULL, - sender_key BLOB NOT NULL, + sender_key BLOB, ratchet_state BLOB NOT NULL, sender_conn_info BLOB NOT NULL, accepted INTEGER NOT NULL, diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index de178e368..39cf32677 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -47,6 +47,7 @@ module Simplex.Messaging.Client subscribeSMPQueueNotifications, subscribeSMPQueuesNtfs, secureSMPQueue, + secureSndSMPQueue, enableSMPQueueNotifications, disableSMPQueueNotifications, enableSMPQueuesNtfs, @@ -655,9 +656,10 @@ createSMPQueue :: RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> + Bool -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c (rKey, rpKey) dhKey auth subMode = - sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case +createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure = + sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r @@ -729,6 +731,11 @@ secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuth secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId {-# INLINE secureSMPQueue #-} +-- | Secure the SMP queue via sender queue ID. +secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO () +secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId +{-# INLINE secureSndSMPQueue #-} + -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 5edea1719..d1b3f85d6 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -55,6 +55,7 @@ module Simplex.Messaging.Protocol ProtocolEncoding (..), Command (..), SubscriptionMode (..), + SenderCanSecure, Party (..), Cmd (..), DirectParty, @@ -133,6 +134,7 @@ module Simplex.Messaging.Protocol FwdTransmission (..), MsgFlags (..), initialSMPClientVersion, + currentSMPClientVersion, userProtocol, rcvMessageMeta, noMsgFlags, @@ -153,6 +155,7 @@ module Simplex.Messaging.Protocol legacyServerP, legacyStrEncodeServer, srvHostnamesSMPClientVersion, + sndAuthKeySMPClientVersion, sameSrvAddr, sameSrvAddr', noAuthSrv, @@ -240,8 +243,11 @@ initialSMPClientVersion = VersionSMPC 1 srvHostnamesSMPClientVersion :: VersionSMPC srvHostnamesSMPClientVersion = VersionSMPC 2 +sndAuthKeySMPClientVersion :: VersionSMPC +sndAuthKeySMPClientVersion = VersionSMPC 3 + currentSMPClientVersion :: VersionSMPC -currentSMPClientVersion = VersionSMPC 2 +currentSMPClientVersion = VersionSMPC 3 supportedSMPClientVRange :: VersionRangeSMPC supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion @@ -377,7 +383,7 @@ data Command (p :: Party) where -- v6 of SMP servers only support signature algorithm for command authorization. -- v7 of SMP servers additionally support additional layer of authenticated encryption. -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys. - NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient + NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient @@ -390,6 +396,7 @@ data Command (p :: Party) where DEL :: Command Recipient QUE :: Command Recipient -- SMP sender commands + SKEY :: SndPublicAuthKey -> Command Sender -- SEND v1 has to be supported for encoding/decoding -- SEND :: MsgBody -> Command Sender SEND :: MsgFlags -> MsgBody -> Command Sender @@ -432,6 +439,8 @@ instance Encoding SubscriptionMode where 'C' -> pure SMOnlyCreate _ -> fail "bad SubscriptionMode" +type SenderCanSecure = Bool + newtype EncTransmission = EncTransmission ByteString deriving (Show) @@ -664,6 +673,7 @@ data CommandTag (p :: Party) where OFF_ :: CommandTag Recipient DEL_ :: CommandTag Recipient QUE_ :: CommandTag Recipient + SKEY_ :: CommandTag Sender SEND_ :: CommandTag Sender PING_ :: CommandTag Sender PRXY_ :: CommandTag ProxiedClient @@ -712,6 +722,7 @@ instance PartyI p => Encoding (CommandTag p) where OFF_ -> "OFF" DEL_ -> "DEL" QUE_ -> "QUE" + SKEY_ -> "SKEY" SEND_ -> "SEND" PING_ -> "PING" PRXY_ -> "PRXY" @@ -732,6 +743,7 @@ instance ProtocolMsgTag CmdTag where "OFF" -> Just $ CT SRecipient OFF_ "DEL" -> Just $ CT SRecipient DEL_ "QUE" -> Just $ CT SRecipient QUE_ + "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ "PRXY" -> Just $ CT SProxiedClient PRXY_ @@ -1106,7 +1118,8 @@ instance FromJSON CorrId where data QueueIdsKeys = QIK { rcvId :: RecipientId, sndId :: SenderId, - rcvPublicDhKey :: RcvPublicDhKey + rcvPublicDhKey :: RcvPublicDhKey, + sndSecure :: SenderCanSecure } deriving (Eq, Show) @@ -1277,7 +1290,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg - instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case - NEW rKey dhKey auth_ subMode + NEW rKey dhKey auth_ subMode sndSecure + | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure) | v >= subModeSMPVersion -> new <> auth <> e subMode | v == basicAuthSMPVersion -> new <> auth | otherwise -> new @@ -1293,6 +1307,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where OFF -> e OFF_ DEL -> e DEL_ QUE -> e QUE_ + SKEY k -> e (SKEY_, ' ', k) SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg) PING -> e PING_ NSUB -> e NSUB_ @@ -1318,6 +1333,9 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where SEND {} | B.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd + SKEY _ + | isNothing auth || B.null entId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd PING -> noAuthCmd PRXY {} -> noAuthCmd PFWD {} @@ -1344,9 +1362,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= subModeSMPVersion -> new <*> auth <*> smpP - | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe - | otherwise -> new <*> pure Nothing <*> pure SMSubscribe + | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP + | v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False + | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False + | otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False where new = NEW <$> _smpP <*> smpP auth = optional (A.char 'A' *> smpP) @@ -1361,6 +1380,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where QUE_ -> pure QUE CT SSender tag -> Cmd SSender <$> case tag of + SKEY_ -> SKEY <$> _smpP SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) @@ -1377,8 +1397,12 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where type Tag BrokerMsg = BrokerMsgTag - encodeProtocol _v = \case - IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh) + encodeProtocol v = \case + IDS (QIK rcvId sndId srvDh sndSecure) + | v >= sndAuthKeySMPVersion -> ids <> e sndSecure + | otherwise -> ids + where + ids = e (IDS_, ' ', rcvId, sndId, srvDh) MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -> e (MSG_, ' ', msgId, Tail body) NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh) @@ -1395,13 +1419,17 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where e :: Encoding a => a -> ByteString e = smpEncode - protocolP _v = \case + protocolP v = \case MSG_ -> do msgId <- _smpP MSG . RcvMessage msgId <$> bodyP where bodyP = EncRcvMsgBody . unTail <$> smpP - IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP) + IDS_ + | v >= sndAuthKeySMPVersion -> ids smpP + | otherwise -> ids $ pure False + where + ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p) NID_ -> NID <$> _smpP <*> smpP NMSG_ -> NMSG <$> _smpP <*> smpP PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP)) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5c8d13a5e..f673018bf 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -607,9 +607,10 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient - -- SEND will be accepted without authorization before the queue is secured with KEY command + -- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command + Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing @@ -768,13 +769,18 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi transportErr :: TransportError -> ErrorType transportErr = PROXY . BROKER . TRANSPORT mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m () - mkIncProxyStats ps psOwn = \own sel -> do + mkIncProxyStats ps psOwn own sel = do atomically $ modifyTVar' (sel ps) (+ 1) when own $ atomically $ modifyTVar' (sel psOwn) (+ 1) processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg)) processCommand (qr_, (corrId, queueId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, queueId, command) Cmd SSender command -> Just <$> case command of + SKEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {sndSecure, recipientId} + | sndSecure -> secureQueue_ "SKEY" recipientId sKey + | otherwise -> pure $ ERR AUTH + Nothing -> pure $ ERR INTERNAL SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody PING -> pure (corrId, "", PONG) RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock @@ -782,10 +788,10 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Cmd SRecipient command -> do st <- asks queueStore Just <$> case command of - NEW rKey dhKey auth subMode -> + NEW rKey dhKey auth subMode sndSecure -> ifM allowNew - (createQueue st rKey dhKey subMode) + (createQueue st rKey dhKey subMode sndSecure) (pure (corrId, queueId, ERR AUTH)) where allowNew = do @@ -794,18 +800,20 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi SUB -> withQueue (`subscribeQueue` queueId) GET -> withQueue getMessage ACK msgId -> withQueue (`acknowledgeMsg` msgId) - KEY sKey -> secureQueue_ st sKey + KEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {recipientId} -> secureQueue_ "KEY" recipientId sKey + Nothing -> pure $ ERR INTERNAL NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey NDEL -> deleteQueueNotifier_ st OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st QUE -> withQueue getQueueInfo where - createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> M (Transmission BrokerMsg) - createQueue st recipientKey dhKey subMode = time "NEW" $ do + createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) + createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey - qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey} + qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} qRec (recipientId, senderId) = QueueRec { recipientId, @@ -814,7 +822,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi rcvDhSecret, senderKey = Nothing, notifier = Nothing, - status = QueueActive + status = QueueActive, + sndSecure } (corrId,queueId,) <$> addQueueRetry 3 qik qRec where @@ -849,12 +858,13 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicAuthKey -> M (Transmission BrokerMsg) - secureQueue_ st sKey = time "KEY" $ do - withLog $ \s -> logSecureQueue s queueId sKey + secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg + secureQueue_ name rId sKey = time name $ do + withLog $ \s -> logSecureQueue s rId sKey + st <- asks queueStore stats <- asks serverStats atomically $ modifyTVar' (qSecured stats) (+ 1) - atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey + atomically $ either ERR (const OK) <$> secureQueue st rId sKey addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index cd1b94215..8d5bd8fff 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -14,6 +14,7 @@ data QueueRec = QueueRec rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, senderKey :: !(Maybe SndPublicAuthKey), + sndSecure :: !SenderCanSecure, notifier :: !(Maybe NtfCreds), status :: !ServerQueueStatus } diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b1011c404..d1ce15ed6 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -53,7 +54,7 @@ data StoreLogRecord | DeleteNotifier QueueId instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} = + strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} = B.unwords [ "rid=" <> strEncode recipientId, "rk=" <> strEncode recipientKey, @@ -61,6 +62,7 @@ instance StrEncoding QueueRec where "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey ] + <> if sndSecure then " sndSecure=" <> strEncode sndSecure else "" <> maybe "" notifierStr notifier where notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds @@ -71,8 +73,9 @@ instance StrEncoding QueueRec where rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP + sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive} + pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive} instance StrEncoding StoreLogRecord where strEncode = \case diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 7088480f5..d7f81f563 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -46,6 +46,7 @@ module Simplex.Messaging.Transport subModeSMPVersion, authCmdsSMPVersion, sendingProxySMPVersion, + sndAuthKeySMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -156,14 +157,17 @@ authCmdsSMPVersion = VersionSMP 7 sendingProxySMPVersion :: VersionSMP sendingProxySMPVersion = VersionSMP 8 +sndAuthKeySMPVersion :: VersionSMP +sndAuthKeySMPVersion = VersionSMP 9 + currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 8 +currentClientSMPRelayVersion = VersionSMP 9 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 8 +currentServerSMPRelayVersion = VersionSMP 9 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. @@ -171,7 +175,7 @@ currentServerSMPRelayVersion = VersionSMP 8 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 8 +proxiedSMPRelayVersion = VersionSMP 9 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 20480f84c..8684c787c 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -7,7 +7,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} -module AgentTests.ConnectionRequestTests where +module AgentTests.ConnectionRequestTests + ( connectionRequestTests, + connReqData, + queueAddr, + testE2ERatchetParams12, + ) where import Data.ByteString (ByteString) import Network.HTTP.Types (urlEncode) @@ -15,179 +20,228 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ProtocolServer (..), pattern VersionSMPC, supportedSMPClientVRange) +import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Version import Test.Hspec -uri :: String -uri = "smp.simplex.im" - srv :: SMPServer -srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") +srv = SMPServer "smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "5223" (C.KeyHash "\215m\248\251") + +srv1 :: SMPServer +srv1 = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") queueAddr :: SMPQueueAddress queueAddr = SMPQueueAddress { smpServer = srv, senderId = "\223\142z\251", - dhPublicKey = testDhKey + dhPublicKey = testDhKey, + sndSecure = False } +queueAddrSK :: SMPQueueAddress +queueAddrSK = queueAddr {sndSecure = True} + +queueAddr1 :: SMPQueueAddress +queueAddr1 = queueAddr {smpServer = srv1} + queueAddrNoPort :: SMPQueueAddress queueAddrNoPort = queueAddr {smpServer = srv {port = ""}} +queueAddrNoPort1 :: SMPQueueAddress +queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} + +-- current version range includes version 1 and it uses legacy encoding queue :: SMPQueueUri queue = SMPQueueUri supportedSMPClientVRange queueAddr +queueSK :: SMPQueueUri +queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK + +queueStr :: ByteString +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queueStrSK :: ByteString +queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queue1 :: SMPQueueUri +queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1 + +queue1Str :: ByteString +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr + queueV1 :: SMPQueueUri queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr +queueV1NoPort :: SMPQueueUri +queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +-- version range 2-3 uses new encoding +-- it is fixed/changed in v5.8.2. +queueNew :: SMPQueueUri +queueNew = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr + +queueNewStr :: ByteString +queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNewStr' :: ByteString +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> testDhKeyStr + +queueNewNoPort :: SMPQueueUri +queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +queueNew1 :: SMPQueueUri +queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1 + +queueNew1Str :: ByteString +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNew1NoPort :: SMPQueueUri +queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} + testDhKey :: C.PublicKeyX25519 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=" testDhKeyStr :: ByteString testDhKeyStr = strEncode testDhKey -testDhKeyStrUri :: ByteString -testDhKeyStrUri = urlEncode True testDhKeyStr - connReqData :: ConnReqUriData connReqData = ConnReqUriData { crScheme = SSSimplex, - crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2), - crSmpQueues = [queueV1], + crAgentVRange = supportedSMPAgentVRange, + crSmpQueues = [queue], crClientData = Nothing } +connReqDataSK :: ConnReqUriData +connReqDataSK = connReqData {crSmpQueues = [queueSK]} + +connReqData1 :: ConnReqUriData +connReqData1 = connReqData {crSmpQueues = [queue1]} + +connReqDataV1 :: ConnReqUriData +connReqDataV1 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 1) (VersionSMPA 1)} + +connReqDataV2 :: ConnReqUriData +connReqDataV2 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2)} + +connReqDataNew :: ConnReqUriData +connReqDataNew = connReqData {crSmpQueues = [queueNew]} + +connReqDataNew1 :: ConnReqUriData +connReqDataNew1 = connReqData {crSmpQueues = [queueNew1]} + testDhPubKey :: C.PublicKeyX448 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U=" testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing +testE2ERatchetParamsStrUri :: ByteString +testE2ERatchetParamsStrUri = "v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" + testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing connectionRequest :: AConnectionRequestUri -connectionRequest = - ACR SCMInvitation $ - CRInvitationUri connReqData testE2ERatchetParams +connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams + +connectionRequestSK :: AConnectionRequestUri +connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams + +connectionRequestV1 :: AConnectionRequestUri +connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams + +connectionRequest1 :: AConnectionRequestUri +connectionRequest1 = ACR SCMInvitation $ CRInvitationUri connReqData1 testE2ERatchetParams + +connectionRequestNew :: AConnectionRequestUri +connectionRequestNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew testE2ERatchetParams + +connectionRequestNew1 :: AConnectionRequestUri +connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams contactAddress :: AConnectionRequestUri contactAddress = ACR SCMContact $ CRContactUri connReqData -connectionRequestCurrentRange :: AConnectionRequestUri -connectionRequestCurrentRange = - ACR SCMInvitation $ - CRInvitationUri - connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]} - testE2ERatchetParams12 +contactAddressV2 :: AConnectionRequestUri +contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2 + +contactAddressNew :: AConnectionRequestUri +contactAddressNew = ACR SCMContact $ CRContactUri connReqDataNew + +connectionRequest2queues :: AConnectionRequestUri +connectionRequest2queues = ACR SCMInvitation $ CRInvitationUri connReqData {crSmpQueues = [queue, queue]} testE2ERatchetParams + +connectionRequest2queuesNew :: AConnectionRequestUri +connectionRequest2queuesNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} testE2ERatchetParams + +contactAddress2queues :: AConnectionRequestUri +contactAddress2queues = ACR SCMContact $ CRContactUri connReqData {crSmpQueues = [queue, queue]} + +contactAddress2queuesNew :: AConnectionRequestUri +contactAddress2queuesNew = ACR SCMContact $ CRContactUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} connectionRequestClientDataEmpty :: AConnectionRequestUri -connectionRequestClientDataEmpty = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams +connectionRequestClientDataEmpty = ACR SCMInvitation $ CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams -connectionRequestClientData :: AConnectionRequestUri -connectionRequestClientData = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams +contactAddressClientData :: AConnectionRequestUri +contactAddressClientData = ACR SCMContact $ CRContactUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} + +url :: ByteString -> ByteString +url = urlEncode True + +(==#) :: (StrEncoding a, HasCallStack) => a -> ByteString -> Expectation +a ==# s = strEncode a `shouldBe` s + +(#==) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #== s = strDecode s `shouldBe` Right a + +(#==#) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #==# s = do + a ==# s + a #== s connectionRequestTests :: Spec connectionRequestTests = describe "connection request parsing / serializing" $ do - it "should serialize SMP queue URIs" $ do - strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - strEncode queue {clientVRange = mkVersionRange (VersionSMPC 1) (VersionSMPC 2)} - `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - it "should parse SMP queue URIs" $ do - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStr) - `shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr) - `shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc") - `shouldBe` Right queue - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc") - `shouldBe` Right queueV1 - it "should serialize connection requests" $ do - strEncode connectionRequest - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestCurrentRange - `shouldBe` "simplex:/invitation#/?v=2-5&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestClientDataEmpty - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - strEncode connectionRequestClientData - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - it "should parse connection requests" $ do - strDecode - ( "https://simplex.chat/contact#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&v=1" -- adjusted to v2 - ) - `shouldBe` Right contactAddress - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D" - <> testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=extra_key%3Dnew%26v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&some_new_param=abc" - <> "&v=2-5" - ) - `shouldBe` Right connectionRequestCurrentRange - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequestClientDataEmpty - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - <> "&v=2" - ) - `shouldBe` Right connectionRequestClientData + it "should serialize and parse SMP queue URIs" $ do + queue #==# queueStr + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-3&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueSK #==# queueStrSK + queue1 #==# queue1Str + queueNew #==# queueNewStr + queueNew #== queueNewStr' + queueNew1 #==# queueNew1Str + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueV1 #==# ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#" <> testDhKeyStr) + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#" <> testDhKeyStr) + it "should serialize and parse connection invitations and contact addresses" $ do + connectionRequest #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest #== ("https://simplex.chat/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestSK #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queues #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestV1 #== ("https://simplex.chat/invitation#/?v=1&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}") + contactAddress #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress #== ("https://simplex.chat/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress2queues #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr)) + contactAddressNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueNewStr) + contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr)) + contactAddressV2 #==# ("simplex:/contact#/?v=2&smp=" <> url queueStr) + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1-2&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=2-2&smp=" <> url queueStr) + contactAddressClientData #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index d52c12877..9f133ebf5 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -25,7 +25,7 @@ module AgentTests.FunctionalAPITests withAgentClients2, withAgentClients3, makeConnection, - exchangeGreetingsMsgId, + exchangeGreetings, switchComplete, createConnection, joinConnection, @@ -47,7 +47,7 @@ module AgentTests.FunctionalAPITests pattern Msg, pattern Msg', pattern SENT, - agentCfgV7, + agentCfgVPrevPQ, ) where @@ -75,7 +75,7 @@ import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7) +import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -89,13 +89,13 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF) +import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -195,46 +195,25 @@ pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMs smpCfgVPrev :: ProtocolClientConfig SMPVersion smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} -smpCfgV7 :: ProtocolClientConfig SMPVersion -smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} - ntfCfgVPrev :: ProtocolClientConfig NTFVersion ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} -ntfCfgV2 :: ProtocolClientConfig NTFVersion -ntfCfgV2 = (ntfCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion} - agentCfgVPrev :: AgentConfig -agentCfgVPrev = +agentCfgVPrev = agentCfgVPrevPQ {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} + +agentCfgVPrevPQ :: AgentConfig +agentCfgVPrevPQ = agentCfg { sndAuthAlg = C.AuthAlg C.SEd25519, smpAgentVRange = prevRange $ smpAgentVRange agentCfg, smpClientVRange = prevRange $ smpClientVRange agentCfg, - e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg, smpCfg = smpCfgVPrev, ntfCfg = ntfCfgVPrev } --- agent config for the next client version -agentCfgV7 :: AgentConfig -agentCfgV7 = - agentCfg - { sndAuthAlg = C.AuthAlg C.SX25519, - smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion, - e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion, - smpCfg = smpCfgV7, - ntfCfg = ntfCfgV2 - } - agentCfgRatchetVPrev :: AgentConfig agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} -prevRange :: VersionRange v -> VersionRange v -prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} - -prevVersion :: Version v -> Version v -prevVersion (Version v) = Version (v - 1) - mkVersionRange :: Word16 -> Word16 -> VersionRange v mkVersionRange v1 v2 = V.mkVersionRange (Version v1) (Version v2) @@ -345,6 +324,8 @@ functionalAPITests t = do it "should synchronize ratchets when clients start synchronization simultaneously" $ testRatchetSyncSimultaneous t describe "Subscription mode OnlyCreate" $ do + it "messages delivered only when polled (v8 - slow handshake)" $ + withSmpServer t testOnlyCreatePullSlowHandshake it "messages delivered only when polled" $ withSmpServer t testOnlyCreatePull describe "Inactive client disconnection" $ do @@ -371,14 +352,16 @@ functionalAPITests t = do withSmpServer t $ testBatchedPendingMessages 10 5 describe "Async agent commands" $ do - it "should connect using async agent commands" $ - withSmpServer t testAsyncCommands + describe "connect using async agent commands" $ + testBasicMatrix2 t testAsyncCommands it "should restore and complete async commands on restart" $ testAsyncCommandsRestore t - it "should accept connection using async command" $ - withSmpServer t testAcceptContactAsync + describe "accept connection using async command" $ + testBasicMatrix2 t testAcceptContactAsync it "should delete connections using async command when server connection fails" $ testDeleteConnectionAsync t + it "join connection when reply queue creation fails (v8 - slow handshake)" $ + testJoinConnectionAsyncReplyErrorV8 t it "join connection when reply queue creation fails" $ testJoinConnectionAsyncReplyError t describe "delete connection waiting for delivery" $ do @@ -421,29 +404,30 @@ functionalAPITests t = do describe "SMP basic auth" $ do let v4 = prevVersion basicAuthSMPVersion forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do + let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 describe ("v" <> show v <> ": with server auth") $ do -- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail - it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) `shouldReturn` 0 - it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) `shouldReturn` 1 - it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) `shouldReturn` 1 - it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) `shouldReturn` 1 + it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) baseId `shouldReturn` 0 + it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 1 + it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) baseId `shouldReturn` 1 + it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do - it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 0 - it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) `shouldReturn` 2 - it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) `shouldReturn` 2 - it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) `shouldReturn` 2 - it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 + it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 2 + it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 0 + it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) 3 `shouldReturn` 2 + it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) baseId `shouldReturn` 2 + it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) 3 `shouldReturn` 2 + it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 2 + it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) 3 `shouldReturn` 2 + it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing let srv1 = testSMPServer2 {keyHash = "1234"} @@ -471,8 +455,8 @@ functionalAPITests t = do it "server should respond with queue and subscription information" $ withSmpServer t testServerQueueInfo -testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do +testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 baseId = do let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 @@ -480,7 +464,7 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do | canCreate1 && canCreate2 = 2 | canCreate1 = 1 | otherwise = 0 - created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 + created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 baseId created `shouldBe` expected pure created @@ -491,26 +475,28 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True - it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False - it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False - it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False - it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False +testBasicMatrix2 :: HasCallStack => ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testBasicMatrix2 t runTest = do + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest + it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest + it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest + it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest + testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 t runTest = do - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True - it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False - it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False - it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False - it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff False - it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff False - it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff False + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False + it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff False + it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff False + it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff False testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec testServerMatrix2 t runTest = do @@ -533,7 +519,7 @@ pqMatrix2_ pqInv t test = do it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) where - runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 + runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 testPQMatrix3 :: HasCallStack => @@ -552,8 +538,8 @@ testPQMatrix3 t test = do where runTest test' = withSmpServerProxy t $ - runTestCfgServers2 agentProxyCfg agentProxyCfg servers 3 $ \a b baseMsgId -> - withAgent 3 agentProxyCfg servers testDB3 $ \c -> test' a b c baseMsgId + runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> + withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId servers = initAgentServersProxy SPMAlways SPFProhibit runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () @@ -637,48 +623,48 @@ testEnablePQEncryption = (aId, bId) <- makeConnection_ PQSupportOff ca cb let a = (ca, aId) b = (cb, bId) - (a, 4, "msg 1") \#>\ b - (b, 5, "msg 2") \#>\ a + (a, 2, "msg 1") \#>\ b + (b, 3, "msg 2") \#>\ a -- 45 bytes is used by agent message envelope inside double ratchet message envelope let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' lrg <- largeMsg g PQSupportOff - (a, 6, lrg) \#>\ b - (b, 7, lrg) \#>\ a + (a, 4, lrg) \#>\ b + (b, 5, lrg) \#>\ a -- switched to smaller envelopes (before reporting PQ encryption enabled) sml <- largeMsg g PQSupportOn -- fail because of message size Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg - (9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml - get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False - get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False - ackMessage cb aId 8 Nothing + (7, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml + get ca =##> \case ("", connId, SENT 7) -> connId == bId; _ -> False + get cb =##> \case ("", connId, MsgErr' 6 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False + ackMessage cb aId 6 Nothing -- -- fail in reply to sync IDss Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg - (10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml - get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False - get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False - ackMessage ca bId 10 Nothing - (a, 11, sml) \#>! b + (8, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml + get cb =##> \case ("", connId, SENT 8) -> connId == aId; _ -> False + get ca =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False + ackMessage ca bId 8 Nothing + (a, 9, sml) \#>! b -- PQ encryption now enabled + (b, 10, sml) !#>! a + (a, 11, sml) !#>! b (b, 12, sml) !#>! a - (a, 13, sml) !#>! b - (b, 14, sml) !#>! a -- disabling PQ encryption - (a, 15, sml) !#>\ b - (b, 16, sml) !#>\ a - (a, 17, sml) \#>\ b - (b, 18, sml) \#>\ a + (a, 13, sml) !#>\ b + (b, 14, sml) !#>\ a + (a, 15, sml) \#>\ b + (b, 16, sml) \#>\ a -- enabling PQ encryption again + (a, 17, sml) \#>! b + (b, 18, sml) \#>! a (a, 19, sml) \#>! b - (b, 20, sml) \#>! a - (a, 21, sml) \#>! b - (b, 22, sml) !#>! a - (a, 23, sml) !#>! b + (b, 20, sml) !#>! a + (a, 21, sml) !#>! b -- disabling PQ encryption again - (b, 24, sml) !#>\ a - (a, 25, sml) !#>\ b - (b, 26, sml) \#>\ a - (a, 27, sml) \#>\ b + (b, 22, sml) !#>\ a + (a, 23, sml) !#>\ b + (b, 24, sml) \#>\ a + (a, 25, sml) \#>\ b -- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456") Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456") @@ -703,22 +689,22 @@ testAgentClient3 = (aIdForB, bId) <- makeConnection a b (aIdForC, cId) <- makeConnection a c - 4 <- sendMessage a bId SMP.noMsgFlags "b4" - 4 <- sendMessage a cId SMP.noMsgFlags "c4" - 5 <- sendMessage a bId SMP.noMsgFlags "b5" - 5 <- sendMessage a cId SMP.noMsgFlags "c5" - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "b4" + 2 <- sendMessage a cId SMP.noMsgFlags "c4" + 3 <- sendMessage a bId SMP.noMsgFlags "b5" + 3 <- sendMessage a cId SMP.noMsgFlags "c5" + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False get b =##> \case ("", connId, Msg "b4") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 4 Nothing + ackMessage b aIdForB 2 Nothing get b =##> \case ("", connId, Msg "b5") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 5 Nothing + ackMessage b aIdForB 3 Nothing get c =##> \case ("", connId, Msg "c4") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 4 Nothing + ackMessage c aIdForC 2 Nothing get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 5 Nothing + ackMessage c aIdForC 3 Nothing runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientContactTest pqSupport viaProxy alice bob baseId = @@ -920,7 +906,7 @@ testAllowConnectionClientRestart t = do runRight_ $ do allowConnectionAsync alice "1" bobId confId "alice's connInfo" - get alice =##> \case ("1", _, OK) -> True; _ -> False + get alice ##> ("1", bobId, OK) pure () threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation) @@ -937,8 +923,7 @@ testAllowConnectionClientRestart t = do get alice2 ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) - - exchangeGreetingsMsgId 4 alice2 bobId bob aliceId + exchangeGreetings alice2 bobId bob aliceId disposeAgentClient alice2 disposeAgentClient bob @@ -949,7 +934,7 @@ testIncreaseConnAgentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -961,7 +946,7 @@ testIncreaseConnAgentVersion t = do runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 2 checkVersion bob aliceId 2 @@ -972,7 +957,7 @@ testIncreaseConnAgentVersion t = do runRight_ $ do subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 8 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 @@ -983,7 +968,7 @@ testIncreaseConnAgentVersion t = do runRight_ $ do subscribeConnection alice3 bobId - exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 8 alice3 bobId bob2 aliceId checkVersion alice3 bobId 3 checkVersion bob2 aliceId 3 @@ -992,7 +977,7 @@ testIncreaseConnAgentVersion t = do runRight_ $ do subscribeConnection bob3 aliceId - exchangeGreetingsMsgId_ PQEncOff 12 alice3 bobId bob3 aliceId + exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob3 aliceId checkVersion alice3 bobId 3 checkVersion bob3 aliceId 3 disposeAgentClient alice3 @@ -1010,7 +995,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -1025,7 +1010,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do runRight_ $ do subscribeConnection alice2 bobId subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 disposeAgentClient alice2 @@ -1038,7 +1023,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -1050,7 +1035,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 3 checkVersion bob aliceId 3 disposeAgentClient alice2 @@ -1064,13 +1049,13 @@ testDeliverClientRestart t = do (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do runRight $ do (aliceId, bobId) <- makeConnection alice bob - exchangeGreetingsMsgId 4 alice bobId bob aliceId + exchangeGreetings alice bobId bob aliceId pure (aliceId, bobId) ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob - 6 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" + 4 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" disposeAgentClient bob @@ -1082,7 +1067,7 @@ testDeliverClientRestart t = do subscribeConnection bob2 aliceId - get bob2 ##> ("", aliceId, SENT 6) + get bob2 ##> ("", aliceId, SENT 4) get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False disposeAgentClient alice disposeAgentClient bob2 @@ -1094,8 +1079,8 @@ testDuplicateMessage t = do (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False disposeAgentClient bob @@ -1104,9 +1089,9 @@ testDuplicateMessage t = do runRight_ $ do subscribeConnection bob1 aliceId get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob1 aliceId 4 Nothing - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" - get alice ##> ("", bobId, SENT 5) + ackMessage bob1 aliceId 2 Nothing + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False pure (aliceId, bobId, bob1) @@ -1116,7 +1101,7 @@ testDuplicateMessage t = do -- commenting two lines below and uncommenting further two lines would also runRight_, -- it is the scenario tested above, when the message was not acknowledged by the user threadDelay 200000 - Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing + Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing disposeAgentClient alice disposeAgentClient bob1 @@ -1131,8 +1116,8 @@ testDuplicateMessage t = do -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False -- ackMessage bob2 aliceId 5 Nothing -- message 2 is not delivered again, even though it was delivered to the agent - 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" - get alice2 ##> ("", bobId, SENT 6) + 4 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" + get alice2 ##> ("", bobId, SENT 4) get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False disposeAgentClient alice2 disposeAgentClient bob2 @@ -1144,20 +1129,20 @@ testSkippedMessages t = do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing disposeAgentClient bob runRight_ $ do - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) + 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" get alice ##> ("", bobId, SENT 5) - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) - 7 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" - get alice ##> ("", bobId, SENT 7) pure (aliceId, bobId) @@ -1174,15 +1159,15 @@ testSkippedMessages t = do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId - 8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" - get alice2 ##> ("", bobId, SENT 8) - get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 5 Nothing + 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" + get alice2 ##> ("", bobId, SENT 6) + get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 3, toMsgId = 5}}} _ "hello 5") -> c == aliceId; _ -> False + ackMessage bob2 aliceId 3 Nothing - 9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" - get alice2 ##> ("", bobId, SENT 9) + 7 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" + get alice2 ##> ("", bobId, SENT 7) get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 6 Nothing + ackMessage bob2 aliceId 4 Nothing disposeAgentClient alice2 disposeAgentClient bob2 @@ -1192,7 +1177,7 @@ testDeliveryAfterSubscriptionError t = do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" liftIO $ noMessages b "not delivered" pure (aId, bId) @@ -1201,9 +1186,9 @@ testDeliveryAfterSubscriptionError t = do Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId pure () withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - withUP a bId $ \case ("", c, SENT 4) -> c == bId; _ -> False + withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO () testMsgDeliveryQuotaExceeded t = @@ -1213,24 +1198,24 @@ testMsgDeliveryQuotaExceeded t = forM_ ([1 .. 4] :: [Int]) $ \i -> do mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False - 8 <- sendMessage a bId SMP.noMsgFlags "over quota" - pGet' a False =##> \case ("", c, AEvt _ (MWARN 8 (SMP _ QUOTA))) -> bId == c; _ -> False - 4 <- sendMessage a bId' SMP.noMsgFlags "hello" - get a =##> \case ("", c, SENT 4) -> bId' == c; _ -> False + 6 <- sendMessage a bId SMP.noMsgFlags "over quota" + pGet' a False =##> \case ("", c, AEvt _ (MWARN 6 (SMP _ QUOTA))) -> bId == c; _ -> False + 2 <- sendMessage a bId' SMP.noMsgFlags "hello" + get a =##> \case ("", c, SENT 2) -> bId' == c; _ -> False get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False - ackMessage b aId' 4 Nothing - ackMessage b aId 4 Nothing + ackMessage b aId' 2 Nothing + ackMessage b aId 2 Nothing get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False - ackMessage b aId 5 Nothing + ackMessage b aId 3 Nothing get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False - ackMessage b aId 6 Nothing + ackMessage b aId 4 Nothing get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False - ackMessage b aId 7 Nothing + ackMessage b aId 5 Nothing get a =##> \case ("", c, QCONT) -> bId == c; _ -> False get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False - ackMessage b aId 9 Nothing -- msg 8 was QCONT - get a =##> \case ("", c, SENT 8) -> bId == c; _ -> False + ackMessage b aId 7 Nothing -- msg 8 was QCONT + get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") testExpireMessage :: HasCallStack => ATransport -> IO () @@ -1240,14 +1225,14 @@ testExpireMessage t = (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" threadDelay 1000000 - 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False + ackMessage b aId 2 Nothing testExpireManyMessages :: HasCallStack => ATransport -> IO () testExpireManyMessages t = @@ -1257,28 +1242,28 @@ testExpireManyMessages t = runRight_ $ do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- sendMessage a bId SMP.noMsgFlags "1" - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" liftIO $ threadDelay 1000000 - 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False -- get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False let expected c e = bId == c && (e == TIMEOUT || e == NETWORK) get a >>= \case - ("", c, MERR 5 (BROKER _ e)) -> do + ("", c, MERR 3 (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5] (BROKER _ e)) -> do + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3] (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5, 6] (BROKER _ e)) -> + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3, 4] (BROKER _ e)) -> liftIO $ expected c e `shouldBe` True r -> error $ show r withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False + ackMessage b aId 2 Nothing withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () withUP a bId p = @@ -1296,23 +1281,23 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" liftIO $ threadDelay 1000000 - 6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False + 4 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False, + [ \case ("", c, AEvt SAEConn (SENT 4)) -> c == bId; _ -> False, \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 3) "3") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testExpireManyMessagesQuota :: ATransport -> IO () @@ -1322,34 +1307,34 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - 7 <- sendMessage a bId SMP.noMsgFlags "4" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" + 5 <- sendMessage a bId SMP.noMsgFlags "4" liftIO $ threadDelay 1000000 - 8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False + 6 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False get a >>= \case - ("", c, MERR 6 (SMP _ QUOTA)) -> do + ("", c, MERR 4 (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP _ QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6] (SMP _ QUOTA)) -> do + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [5] (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4] (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6, 7] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4, 5] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c r -> error $ show r pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, AEvt SAEConn (SENT 8)) -> c == bId; _ -> False, + [ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False, \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 5) "5") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testRatchetSync :: HasCallStack => ATransport -> IO () @@ -1363,34 +1348,34 @@ testRatchetSync t = withAgentClients2 $ \alice bob -> get bob2 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing - 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" + get bob ##> ("", aliceId, SENT 3) get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False - ackMessage alice bobId 5 Nothing + ackMessage alice bobId 3 Nothing liftIO $ copyFile testDB2 (testDB2 <> ".bak") - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False - ackMessage bob aliceId 6 Nothing + ackMessage bob aliceId 4 Nothing - 7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" - get bob ##> ("", aliceId, SENT 7) + 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" + get bob ##> ("", aliceId, SENT 5) get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False - ackMessage alice bobId 7 Nothing + ackMessage alice bobId 5 Nothing disposeAgentClient bob @@ -1404,8 +1389,8 @@ setupDesynchronizedRatchet alice bob = do Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ synchronizeRatchet bob2 aliceId PQSupportOn False - 8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" - get alice ##> ("", bobId, SENT 8) + 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" + get alice ##> ("", bobId, SENT 6) get bob2 =##> ratchetSyncP aliceId RSRequired Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ sendMessage bob2 aliceId SMP.noMsgFlags "hello 6" @@ -1443,7 +1428,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 serverUpP :: ATransmission -> Bool @@ -1471,7 +1456,7 @@ testRatchetSyncClientRestart t = do get bob3 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob3 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob3 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob3 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob3 @@ -1500,7 +1485,7 @@ testRatchetSyncSuspendForeground t = do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 @@ -1528,13 +1513,13 @@ testRatchetSyncSimultaneous t = do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 -testOnlyCreatePull :: IO () -testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do +testOnlyCreatePullSlowHandshake :: IO () +testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProxyCfgV8 $ \alice bob -> runRight_ $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice @@ -1558,14 +1543,38 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do getMsg alice bobId $ get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessage alice bobId 5 Nothing - where - getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a - getMsg c cId action = do - liftIO $ noMessages c "nothing should be delivered before GET" - Just _ <- getConnectionMessage c cId - r <- action - get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False - pure r + +getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a +getMsg c cId action = do + liftIO $ noMessages c "nothing should be delivered before GET" + Just _ <- getConnectionMessage c cId + r <- action + get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False + pure r + +testOnlyCreatePull :: IO () +testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate + Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice + allowConnection alice bobId confId "alice's connInfo" + liftIO $ threadDelay 1_000000 + getMsg bob aliceId $ do + get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, CON) + liftIO $ threadDelay 1_000000 + get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation + -- exchange messages + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) + getMsg bob aliceId $ + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId 2 Nothing + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT 3) + getMsg alice bobId $ + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId 3 Nothing makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection = makeConnection_ PQSupportOn @@ -1643,14 +1652,14 @@ testSuspendingAgent :: IO () testSuspendingAgent = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing liftIO $ suspendAgent b 1000000 get' b ##> ("", "", SUSPENDED) - 5 <- sendMessage a bId SMP.noMsgFlags "hello 2" - get a ##> ("", bId, SENT 5) + 3 <- sendMessage a bId SMP.noMsgFlags "hello 2" + get a ##> ("", bId, SENT 3) Nothing <- 100000 `timeout` get b liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False @@ -1659,47 +1668,47 @@ testSuspendingAgentCompleteSending :: ATransport -> IO () testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 liftIO $ suspendAgent b 5000000 withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do - pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, AEvt SAEConn (SENT 6)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 4)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False ("", "", SUSPENDED) <- nGet b pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False - ackMessage a bId 5 Nothing + ackMessage a bId 3 Nothing get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False - ackMessage a bId 6 Nothing + ackMessage a bId 4 Nothing testSuspendingAgentTimeout :: ATransport -> IO () testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do (aId, _) <- withSmpServer t . runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ suspendAgent b 100000 ("", "", SUSPENDED) <- nGet b pure () @@ -1730,10 +1739,10 @@ testBatchedSubscriptions nCreate nDel t = (aIds', bIds') = unzip conns' subscribe a bIds subscribe b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 4 a bId b aId void $ resubscribeConnections a bIds void $ resubscribeConnections b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId delete a bIds' delete b aIds' deleteFail a bIds' @@ -1786,9 +1795,9 @@ testBatchedPendingMessages nCreate nMsgs = withA = withAgent 1 agentCfg initAgentServers testDB withB = withAgent 2 agentCfg initAgentServers testDB2 -testAsyncCommands :: IO () -testAsyncCommands = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAsyncCommands :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAsyncCommands alice bob baseId = + runRight_ $ do bobId <- createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bobId', INV (ACR _ qInfo)) <- get alice liftIO $ bobId' `shouldBe` bobId @@ -1833,7 +1842,6 @@ testAsyncCommands = get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testAsyncCommandsRestore :: ATransport -> IO () @@ -1848,9 +1856,9 @@ testAsyncCommandsRestore t = do get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () -testAcceptContactAsync :: IO () -testAcceptContactAsync = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAcceptContactAsync :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAcceptContactAsync alice bob baseId = + runRight_ $ do (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice @@ -1884,7 +1892,6 @@ testAcceptContactAsync = deleteConnection alice bobId liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testDeleteConnectionAsync :: ATransport -> IO () @@ -1931,7 +1938,7 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDelivery :: ATransport -> IO () @@ -1985,7 +1992,7 @@ testWaitDelivery t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryAUTHErr :: ATransport -> IO () @@ -2028,7 +2035,7 @@ testWaitDeliveryAUTHErr t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout :: ATransport -> IO () @@ -2068,7 +2075,7 @@ testWaitDeliveryTimeout t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout2 :: ATransport -> IO () @@ -2114,14 +2121,14 @@ testWaitDeliveryTimeout2 t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId -testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyError t = do +testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyErrorV8 t = do let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} - withAgent 1 agentCfg initAgentServers testDB $ \a -> - withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> + withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a @@ -2145,52 +2152,92 @@ testJoinConnectionAsyncReplyError t = do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False runRight_ $ do allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False - pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) + exchangeGreetingsMsgId 4 a bId b aId + +testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyError t = do + let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe + ("1", bId', INV (ACR _ qInfo)) <- get a + liftIO $ bId' `shouldBe` bId + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure (aId, bId) + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + withSmpServerOn t testPort2 $ do + confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + -- both servers need to be online for connection to progress because of SKEY + get b =##> \case ("2", c, OK) -> c == aId; _ -> False + pGet a >>= \case + ("", "", AEvt _ (UP _ [_])) -> do + ("", _, CONF confId _ "bob's connInfo") <- get a + pure confId + ("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do + ("", "", UP _ [_]) <- nGet a + pure confId + r -> error $ "unexpected response " <> show r + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + runRight_ $ do + allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) + get a ##> ("", bId, CON) + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure () + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) exchangeGreetings a bId b aId testUsers :: IO () testUsers = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId True get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testDeleteUserQuietly :: IO () testDeleteUserQuietly = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testUsersNoServer :: HasCallStack => ATransport -> IO () testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' pure (aId, bId, auId, aId', bId') nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False @@ -2204,7 +2251,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId where aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} @@ -2212,9 +2259,9 @@ testSwitchConnection :: InitialAgentServers -> IO () testSwitchConnection servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - testFullSwitch a bId b aId 10 - testFullSwitch a bId b aId 16 + exchangeGreetings a bId b aId + testFullSwitch a bId b aId 8 + testFullSwitch a bId b aId 14 testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO () testFullSwitch a bId b aId msgId = do @@ -2265,7 +2312,7 @@ testSwitchAsync :: HasCallStack => InitialAgentServers -> IO () testSwitchAsync servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2286,8 +2333,8 @@ testSwitchAsync servers = do withA $ \a -> withB $ \b -> runRight_ $ do subscribeConnection a bId subscribeConnection b aId - exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 16 + exchangeGreetingsMsgId 8 a bId b aId + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2310,7 +2357,7 @@ testSwitchDelete :: InitialAgentServers -> IO () testSwitchDelete servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId liftIO $ disposeAgentClient b stats <- switchConnectionAsync a "" bId liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted] @@ -2325,7 +2372,7 @@ testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStarted servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2362,9 +2409,9 @@ testAbortSwitchStarted servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2375,7 +2422,7 @@ testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStartedReinitiate servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2413,9 +2460,9 @@ testAbortSwitchStartedReinitiate servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2442,7 +2489,7 @@ testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO () testCannotAbortSwitchSecured servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2467,9 +2514,9 @@ testCannotAbortSwitchSecured servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId b aId + exchangeGreetingsMsgId 8 a bId b aId - testFullSwitch a bId b aId 16 + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2480,9 +2527,9 @@ testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO () testSwitch2Connections servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2523,11 +2570,11 @@ testSwitch2Connections servers = do void $ subscribeConnections a [bId1, bId2] void $ subscribeConnections b [aId1, aId2] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 16 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2538,9 +2585,9 @@ testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO () testSwitch2ConnectionsAbort1 servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2576,19 +2623,19 @@ testSwitch2ConnectionsAbort1 servers = do phaseRcv a bId1 SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 14 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 12 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testCreateQueueAuth srvVersion clnt1 clnt2 = do +testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testCreateQueueAuth srvVersion clnt1 clnt2 baseId = do a <- getClient 1 clnt1 testDB b <- getClient 2 clnt2 testDB2 r <- runRight $ do @@ -2605,7 +2652,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsMsgId (baseId + 1) a bId b aId pure 2 disposeAgentClient a disposeAgentClient b @@ -2638,20 +2685,20 @@ testDeliveryReceipts = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b -- a sends, b receives and sends delivery receipt - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" - get a =##> \case ("", c, Rcvd 4) -> c == bId; _ -> False - ackMessage a bId 5 Nothing + ackMessage b aId 2 $ Just "" + get a =##> \case ("", c, Rcvd 2) -> c == bId; _ -> False + ackMessage a bId 3 Nothing -- b sends, a receives and sends delivery receipt - 6 <- sendMessage b aId SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 6) + 4 <- sendMessage b aId SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 4) get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False - ackMessage a bId 6 $ Just "" - get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False - ackMessage b aId 7 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) - ackMessage b aId 7 Nothing + ackMessage a bId 4 $ Just "" + get b =##> \case ("", c, Rcvd 4) -> c == aId; _ -> False + ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) + ackMessage b aId 5 Nothing testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () testDeliveryReceiptsVersion t = do @@ -2662,15 +2709,15 @@ testDeliveryReceiptsVersion t = do (aId, bId) <- makeConnection_ PQSupportOff a b checkVersion a bId 3 checkVersion b aId 3 - (4, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) - get b =##> \case ("", c, Msg' 4 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" + (2, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) + get b =##> \case ("", c, Msg' 2 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b aId 2 $ Just "" liftIO $ noMessages a "no delivery receipt (unsupported version)" - (5, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 5) - get a =##> \case ("", c, Msg' 5 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a bId 5 $ Just "" + (3, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 3) + get a =##> \case ("", c, Msg' 3 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a bId 3 $ Just "" liftIO $ noMessages b "no delivery receipt (unsupported version)" pure (aId, bId) @@ -2682,27 +2729,27 @@ testDeliveryReceiptsVersion t = do runRight_ $ do subscribeConnection a' bId subscribeConnection b' aId - exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId - checkVersion a' bId 5 - checkVersion b' aId 5 - (8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" - get a' ##> ("", bId, SENT 8) - get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b' aId 8 $ Just "" - get a' =##> \case ("", c, Rcvd 8) -> c == bId; _ -> False - ackMessage a' bId 9 Nothing - (10, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" - get b' ##> ("", aId, SENT 10) - get a' =##> \case ("", c, Msg' 10 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a' bId 10 $ Just "" - get b' =##> \case ("", c, Rcvd 10) -> c == aId; _ -> False - ackMessage b' aId 11 Nothing - (12, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" - get a' ##> ("", bId, SENT 12) - get b' =##> \case ("", c, Msg' 12 PQEncOff "hello 2") -> c == aId; _ -> False - ackMessage b' aId 12 $ Just "" - get a' =##> \case ("", c, Rcvd 12) -> c == bId; _ -> False - ackMessage a' bId 13 Nothing + exchangeGreetingsMsgId_ PQEncOff 4 a' bId b' aId + checkVersion a' bId 6 + checkVersion b' aId 6 + (6, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" + get a' ##> ("", bId, SENT 6) + get b' =##> \case ("", c, Msg' 6 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b' aId 6 $ Just "" + get a' =##> \case ("", c, Rcvd 6) -> c == bId; _ -> False + ackMessage a' bId 7 Nothing + (8, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" + get b' ##> ("", aId, SENT 8) + get a' =##> \case ("", c, Msg' 8 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a' bId 8 $ Just "" + get b' =##> \case ("", c, Rcvd 8) -> c == aId; _ -> False + ackMessage b' aId 9 Nothing + (10, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" + get a' ##> ("", bId, SENT 10) + get b' =##> \case ("", c, Msg' 10 PQEncOff "hello 2") -> c == aId; _ -> False + ackMessage b' aId 10 $ Just "" + get a' =##> \case ("", c, Rcvd 10) -> c == bId; _ -> False + ackMessage a' bId 11 Nothing disposeAgentClient a' disposeAgentClient b' @@ -2773,8 +2820,8 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 6 a bId1 b aId1 - exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetingsMsgId 4 a bId1' b aId1' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2798,10 +2845,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 4 - exchangeGreetingsMsgId 8 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId1' b aId1' - exchangeGreetingsMsgId 6 a bId2 b aId2 - exchangeGreetingsMsgId 6 a bId2' b aId2' + exchangeGreetingsMsgId 6 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetingsMsgId 4 a bId2' b aId2' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2814,10 +2861,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId1' b aId1' - exchangeGreetingsMsgId 8 a bId2 b aId2 - exchangeGreetingsMsgId 8 a bId2' b aId2' + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId1' b aId1' + exchangeGreetingsMsgId 6 a bId2 b aId2 + exchangeGreetingsMsgId 6 a bId2' b aId2' where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n @@ -2846,7 +2893,7 @@ testServerMultipleIdentities = disposeAgentClient bob getSMPAgentClient' 3 agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId - exchangeGreetingsMsgId 6 alice bobId bob' aliceId + exchangeGreetingsMsgId 4 alice bobId bob' aliceId liftIO $ disposeAgentClient bob' where secondIdentityCReq :: ConnectionRequestUri 'CMInvitation @@ -2934,7 +2981,7 @@ testServerQueueInfo = do aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice liftIO $ threadDelay 200000 - checkEmptyQ alice bobId False + checkEmptyQ alice bobId True -- secured by sender allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -2942,7 +2989,7 @@ testServerQueueInfo = do liftIO $ threadDelay 200000 checkEmptyQ alice bobId True checkEmptyQ bob aliceId True - let msgId = 4 + let msgId = 2 (msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello" liftIO $ msgId' `shouldBe` msgId get alice ##> ("", bobId, SENT msgId) @@ -3031,7 +3078,7 @@ exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> Con exchangeGreetings = exchangeGreetings_ PQEncOn exchangeGreetings_ :: HasCallStack => PQEncryption -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 4 +exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 2 exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 01eab9555..ab9d8453c 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -12,9 +12,9 @@ module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import AgentTests.FunctionalAPITests - ( agentCfgV7, + ( agentCfgVPrevPQ, createConnection, - exchangeGreetingsMsgId, + exchangeGreetings, get, joinConnection, makeConnection, @@ -51,7 +51,7 @@ import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) +import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) 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) @@ -70,7 +70,6 @@ import Simplex.Messaging.Transport (ATransport) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO -import Util removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do @@ -144,28 +143,26 @@ notificationTests t = do withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> testNotificationsNewToken apns ntf -testNtfMatrix :: ATransport -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec testNtfMatrix t runTest = do describe "next and current" $ do - it "next servers: SMP v7, NTF v2; next clients: v7/v2" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfgV7 runTest - it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest - it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest - skip "this case cannot be supported - see RFC" $ - it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $ - runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest - -- servers can be migrated in any order - it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest - it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest - -- clients can be partially migrated - it "servers: next SMP v7, curr NTF v2; clients: next/curr" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfg runTest - it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest + it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest + it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + -- servers can be upgraded in any order + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + -- one of two clients can be upgraded + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest -runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO () -runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = do +runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do withSmpServerConfigOn t smpCfg testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ -> - withAgentClientsCfg2 aCfg bCfg $ runTest apns + withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId threadDelay 100000 testNotificationToken :: APNSMockServer -> IO () @@ -345,8 +342,8 @@ testRunNTFServerTests t srv = withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing -testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do +testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -404,11 +401,10 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen -- no notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId -testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = +testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob = runRight_ $ do -- alice registers notification token DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ @@ -426,9 +422,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = allowConnection alice bobId confId "alice's connInfo" void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, INFO "alice's connInfo") - void $ messageNotificationData alice apnsQ + when (baseId == 3) $ void $ messageNotificationData alice apnsQ get alice ##> ("", bobId, CON) - void $ messageNotificationData bob apnsQ + when (baseId == 3) $ void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, CON) -- bob sends message 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" @@ -445,7 +441,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = -- no unexpected notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken @@ -520,7 +515,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () @@ -559,7 +554,7 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () @@ -568,11 +563,11 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -580,8 +575,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice withNtfServerStoreLog t $ \threadId -> runRight_ $ do liftIO $ threadDelay 250000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -592,11 +587,11 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -608,8 +603,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) _ <- messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -664,7 +659,7 @@ testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () testSwitchNotifications servers APNSMockServer {apnsQ} = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId _ <- registerTestToken a "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 let testMessage msg = do @@ -739,7 +734,7 @@ messageNotification apnsQ = do pure (nonce, message) _ -> error "bad notification" -messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData +messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData messageNotificationData c apnsQ = do (nonce, message) <- messageNotification apnsQ NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 039e26090..39a4b1b95 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -197,6 +197,9 @@ cData1 = testPrivateAuthKey :: C.APrivateAuthKey testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testPublicAuthKey :: C.APublicAuthKey +testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe") + testPrivDhKey :: C.PrivateKeyX25519 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk" @@ -218,6 +221,7 @@ rcvQueue1 = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "2345", + sndSecure = True, status = New, dbQueueId = DBNewQueue, primary = True, @@ -235,7 +239,8 @@ sndQueue1 = connId = "conn1", server = smpServer1, sndId = "3456", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -379,7 +384,8 @@ testUpgradeRcvConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -412,6 +418,7 @@ testUpgradeSndConnToDuplex = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "4567", + sndSecure = True, status = New, dbQueueId = DBNewQueue, rcvSwchStatus = Nothing, diff --git a/tests/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 2b0009344..9f7c4932e 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -183,6 +183,7 @@ dummyRQ userId server connId = e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, sndId = "", + sndSecure = True, status = New, dbQueueId = DBQueueId 0, primary = True, diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index bd8cee771..9bd124e55 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -28,7 +28,7 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket -import SMPClient (serverBracket) +import SMPClient (prevRange, serverBracket) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -36,7 +36,6 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol (NtfResponse) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env -import qualified Simplex.Messaging.Notifications.Server.Env as Env import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport @@ -47,7 +46,6 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server import qualified Simplex.Messaging.Transport.Server as Server -import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -108,18 +106,19 @@ ntfServerCfg = serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig + transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} } -ntfServerCfgV2 :: NtfServerConfig -ntfServerCfgV2 = +ntfServerCfgVPrev :: NtfServerConfig +ntfServerCfgVPrev = ntfServerCfg - { ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion, - smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}, - Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} + { ntfServerVRange = prevRange $ ntfServerVRange ntfServerCfg, + smpAgentCfg = smpAgentCfg' {smpCfg = smpCfg' {serverVRange = prevRange serverVRange'}} } where smpAgentCfg' = smpAgentCfg ntfServerCfg + smpCfg' = smpCfg smpAgentCfg' + serverVRange' = serverVRange smpCfg' withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]} diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 3c9907c48..7cb2a88c5 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -14,7 +14,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import NtfClient (ntfTestPort) -import SMPClient (proxyVRange, testPort) +import SMPClient (proxyVRangeV8, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval @@ -80,8 +80,8 @@ agentCfg = where networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000} -agentProxyCfg :: AgentConfig -agentProxyCfg = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRange}} +agentProxyCfgV8 :: AgentConfig +agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}} fastRetryInterval :: RetryInterval fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6bc36c29a..144ad8b10 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -29,6 +29,7 @@ import qualified Simplex.Messaging.Transport.Client as Client import Simplex.Messaging.Transport.Server import qualified Simplex.Messaging.Transport.Server as Server import Simplex.Messaging.Version +import Simplex.Messaging.Version.Internal import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -133,18 +134,26 @@ cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVer cfgV8 :: ServerConfig cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} +cfgVPrev :: ServerConfig +cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} + +prevRange :: VersionRange v -> VersionRange v +prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} + +prevVersion :: Version v -> Version v +prevVersion (Version v) = Version (v - 1) + proxyCfg :: ServerConfig proxyCfg = - cfgV7 + cfg { allowSMPProxy = True, - smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, - smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = proxyVRange, agreeSecret = True}} + smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True}} } where - smpAgentCfg' = smpAgentCfg cfgV7 + smpAgentCfg' = smpAgentCfg cfg -proxyVRange :: VersionRangeSMP -proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion +proxyVRangeV8 :: VersionRangeSMP +proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} @@ -180,9 +189,6 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const withSmpServer :: HasCallStack => ATransport -> IO a -> IO a withSmpServer t = withSmpServerOn t testPort -withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a -withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const - withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index d71208db9..6452d2677 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -102,22 +102,22 @@ smpProxyTests = do describe "agent API" $ do describe "one server" $ do it "always via proxy" . oneServer $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . oneServer $ - agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do it "always via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 it "both via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy for unknown" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ agentViaProxyVersionError it "retries sending when destination or proxy relay is offline" $ @@ -157,7 +157,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe + QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") @@ -199,8 +199,8 @@ proxyConnectDeadRelay n d proxyServ = do Right !_noWay -> error "got unexpected client" Left !_err -> threadDelay d -agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> IO () -agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 = +agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () +agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe @@ -232,9 +232,8 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 4) Nothing where - baseId = 3 msgId = subtract baseId . fst - aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} + aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () @@ -299,14 +298,14 @@ agentDeliverMessagesViaProxyConc agentServers msgs = Left (Left e) -> cancel aSender >> throwIO e logDebug "run finished" pqEnc = CR.PQEncOn - aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} + aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} agentViaProxyVersionError :: IO () agentViaProxyVersionError = - withAgent 1 agentProxyCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do + withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- - withAgent 2 agentProxyCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do + withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () @@ -370,22 +369,22 @@ agentViaProxyRetryOffline = do withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False - aCfg = agentProxyCfg {messageRetryInterval = fastMessageRetryInterval} - baseId = 3 + aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} + baseId = 1 msgId = subtract baseId . fst servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers $ L.map noAuthSrv [srv]} testNoProxy :: IO () testNoProxy = do withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do - testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do + testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) testProxyAuth :: IO () testProxyAuth = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do - testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do + testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index a124a42e4..1fa76dfaa 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -73,7 +73,7 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType B pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg -pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} @@ -134,7 +134,7 @@ testCreateSecure (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -199,7 +199,7 @@ testCreateDelete (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -271,7 +271,7 @@ stressTest (ATransport t) = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -289,7 +289,7 @@ testAllowNewQueues t = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) pure () testDuplex :: ATransport -> Spec @@ -299,7 +299,7 @@ testDuplex (ATransport t) = g <- C.newRandom (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -315,7 +315,7 @@ testDuplex (ATransport t) = (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, not a part of SMP protocol @@ -354,7 +354,7 @@ testSwitchSub (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -740,7 +740,7 @@ createAndSecureQueue h sPub = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -751,7 +751,7 @@ testTiming (ATransport t) = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> it (testName tst) $ - smpTest2Cfg cfgV7 (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> + smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> testSameTiming rh sh tst where testName :: (C.AuthAlg, C.AuthAlg, Int) -> String @@ -775,7 +775,7 @@ testTiming (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -937,8 +937,8 @@ syntaxTests (ATransport t) = do describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX) - it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) - it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) + it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH) it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 37ec00199..8de86eff1 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -398,7 +398,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp' + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId -- tmp path should be removed after permanent error @@ -477,7 +477,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do -- send file - should fail with AUTH error withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- sfGet sndr' sfId' `shouldBe` sfId @@ -513,7 +513,7 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -551,7 +551,7 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -586,7 +586,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ runRight_ . void $ do -- receive file 1 again rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' @@ -619,7 +619,7 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do -- receive file 1 again - should fail with AUTH error runRight $ do rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId' `shouldBe` rfId diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 208b54dc5..72c843f32 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -67,10 +67,10 @@ withXFTPServer2 :: HasCallStack => IO a -> IO a withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const xftpTestPort :: ServiceName -xftpTestPort = "7000" +xftpTestPort = "8000" xftpTestPort2 :: ServiceName -xftpTestPort2 = "7001" +xftpTestPort2 = "8001" testXFTPServer :: XFTPServer testXFTPServer = fromString testXFTPServerStr @@ -79,10 +79,10 @@ testXFTPServer2 :: XFTPServer testXFTPServer2 = fromString testXFTPServerStr2 testXFTPServerStr :: String -testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" +testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" testXFTPServerStr2 :: String -testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" +testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001" xftpServerFiles :: FilePath xftpServerFiles = "tests/tmp/xftp-server-files"