From b83d89765099533b2b9984aadf33f75b61333f28 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 26 Mar 2025 17:26:27 +0000 Subject: [PATCH 01/15] smp protocol: short links and other changes from RFC (#1489) * smp protocol: short links types and other changes from RFC * add fields for queue link ID and data * create queue and ntf credentials with NEW command * all tests * simplfiy types, update rfc * update rfc * include SenderId in NEW request in case queue data is sent * store queue data and generate link ID if needed * update rfc * agent API and types * SMP commands and persistence for short links * SMP client functions for short links * agent client functions for short links * create rcv queue with short link (TODO secret_box) * encryption and encoding for link data, postgres client migration * test creating short link * get link and data, tests * comments * type signature --- rfcs/2025-03-16-smp-queues.md | 125 ++++++++---- simplexmq.cabal | 6 + src/Simplex/Messaging/Agent.hs | 168 +++++++++++++--- src/Simplex/Messaging/Agent/Client.hs | 149 ++++++++++++--- src/Simplex/Messaging/Agent/Protocol.hs | 102 +++++++++- src/Simplex/Messaging/Agent/Store.hs | 22 +++ .../Messaging/Agent/Store/AgentStore.hs | 72 ++++++- .../Agent/Store/Postgres/Migrations/App.hs | 4 +- .../Migrations/M20250322_short_links.hs | 46 +++++ .../Agent/Store/SQLite/Migrations/App.hs | 4 +- .../Migrations/M20250322_short_links.hs | 43 +++++ .../Store/SQLite/Migrations/agent_schema.sql | 20 ++ src/Simplex/Messaging/Client.hs | 76 +++++++- src/Simplex/Messaging/Crypto.hs | 62 +++++- src/Simplex/Messaging/Crypto/Ratchet.hs | 5 +- src/Simplex/Messaging/Crypto/ShortLink.hs | 65 +++++++ src/Simplex/Messaging/Protocol.hs | 179 ++++++++++++++++-- src/Simplex/Messaging/Server.hs | 173 ++++++++++------- src/Simplex/Messaging/Server/Main.hs | 2 +- .../Messaging/Server/MsgStore/Journal.hs | 14 +- src/Simplex/Messaging/Server/MsgStore/STM.hs | 2 +- .../Messaging/Server/MsgStore/Types.hs | 3 +- src/Simplex/Messaging/Server/QueueStore.hs | 17 +- .../Messaging/Server/QueueStore/Postgres.hs | 128 ++++++++++--- .../Server/QueueStore/Postgres/Migrations.hs | 37 +++- .../Messaging/Server/QueueStore/QueueInfo.hs | 29 +++ .../Messaging/Server/QueueStore/STM.hs | 50 ++++- .../Messaging/Server/QueueStore/Types.hs | 3 + src/Simplex/Messaging/Server/StoreLog.hs | 47 ++++- .../Messaging/Server/StoreLog/ReadWrite.hs | 4 +- src/Simplex/Messaging/Transport.hs | 11 +- tests/AgentTests.hs | 11 +- tests/AgentTests/ConnectionRequestTests.hs | 12 +- tests/AgentTests/EqInstances.hs | 7 + tests/AgentTests/FunctionalAPITests.hs | 57 +++++- tests/AgentTests/SQLiteTests.hs | 2 + tests/AgentTests/ShortLinkTests.hs | 46 +++++ tests/CoreTests/MsgStoreTests.hs | 32 ++-- tests/CoreTests/StoreLogTests.hs | 7 +- tests/CoreTests/TRcvQueuesTests.hs | 1 + tests/NtfServerTests.hs | 52 +++-- tests/SMPProxyTests.hs | 13 +- tests/ServerTests.hs | 125 ++++++++++-- tests/Test.hs | 6 +- 44 files changed, 1701 insertions(+), 338 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs create mode 100644 src/Simplex/Messaging/Crypto/ShortLink.hs create mode 100644 tests/AgentTests/ShortLinkTests.hs diff --git a/rfcs/2025-03-16-smp-queues.md b/rfcs/2025-03-16-smp-queues.md index a0f845a43..d3d06d444 100644 --- a/rfcs/2025-03-16-smp-queues.md +++ b/rfcs/2025-03-16-smp-queues.md @@ -65,36 +65,32 @@ Proposed NEW command replaces SenderCanSecure with QueueMode, adds link data, an ```haskell NEW :: NewQueueRequest -> Command Recipient -data NewQueueRequest = NewQueueRequest +data NewQueueReq = NewQueueReq { rcvAuthKey :: RcvPublicAuthKey, rcvDhKey :: RcvPublicDhKey, - basicAuth :: Maybe BasicAuth, + auth_ :: Maybe BasicAuth, subMode :: SubscriptionMode, - ntfRequest :: Maybe NtfRequest, - queueLink :: Maybe QueueLink -- it is Maybe to allow testing and staged roll-out + queueData :: Maybe QueueReqData, + ntfCreds :: Maybe NewNtfCreds } --- To allow updating the existing contact addresses without changing them. --- This command would fail on queues that support sndSecure and also on new queues created with QLMessaging. --- RecipientId is entity ID. --- The response to this command is `OK`. -LNEW :: LinkId -> QueueLinkData -> Command Recipient - -- Replaces NKEY command -- This avoids additional command required from the client to enable notifications. -- Further changes would move NotifierId generation to the client, and including a signed and encrypted command to be forwarded by SMP server to notification server. data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey --- QLMessaging implies that sender can secure the queue. --- LinkId is not used with QLMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used. --- LinkId is required with QLContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists. -data QueueLink = QLMessaging QueueLinkData | QLContact LinkId QueueLinkData +-- QRMessaging implies that sender can secure the queue. +-- LinkId is not used with QRMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used. +-- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists. +data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, QueueLinkData)) -data QueueLinkData = QueueLinkData EncImmutableDataBytes EncUserDataBytes +-- SenderId should be computed client-side as sha3-256(correlation_id), +-- The server must verify it and reject if it is not. +type QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes) -newtype EncImmutableDataBytes = EncImmutableDataBytes ByteString +type EncImmutableDataBytes = ByteString -newtype EncUserDataBytes = EncUserDataBytes ByteString +type EncUserDataBytes = ByteString -- We need to use binary encoding for AConnectionRequestUri to reduce its size -- connReq including the full link allows connection redundancy. @@ -128,27 +124,45 @@ data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId In addition to that we add the command allowing to update and also to retrieve and, optionally, secure the queue and get link data in one request, to have only one request: ```haskell --- With RecipientId as entity ID, the command to update mutable part of link data --- The response is OK here. -LSET :: EncUserDataBytes -> Command Recipient +-- This command allows to set all data or to update mutlable part of contact address queue. +-- This command should fail on queues that support sndSecure and also on new queues created with QRMessaging. +-- This should fail if LinkId or immutable part of data is changed with the update, but will succeed if only mutable part is updated, so it can be retried. +-- Entity ID is RecipientId. +-- The response to this command is `OK`. +LSET :: LinkId -> QueueLinkData -> Command Recipient + +-- Delete should link and associated data +-- Entity ID is RecipientId +LDEL :: Command Recipient -- To be used with 1-time links. -- Sender's key provided on the first request prevents observers from undetectably accessing 1-time link data. --- If queue mode is QLContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY. +-- If queue mode is QRContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY. -- Once queue is secured, the key must be the same in subsequent requests - to allow retries in case of network failures, and to prevent passive attacks. -- The difference with securing queues is that queues allow sending unsecured messages to queues that allow sndSecure (for backwards compatibility), and 1-time links will NOT allow retrieving link data without securing the queue at the same time, preventing undetected access by observers. --- Entity ID is LinkId here +-- Entity ID is LinkId LKEY :: SndPublicAuthKey -> Command Sender --- If queue mode is QLMessaging the command will fail. --- Entity ID is LinkId here +-- If queue mode is QRMessaging the command will fail. +-- Entity ID is LinkId LGET :: Command Sender --- Response to LKEY and LGET --- Entity ID is LinkId here -LINK :: SenderId -> QueueLinkData -> BrokerMsg +-- Response to LGET, LSKEY and LSGET +-- Entity ID is the same as in the command +LNK :: SenderId -> QueueLinkData -> BrokerMsg ``` +To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as `sha3-256(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID. + +To allow retries and to avoid regenerating all queue data, NEW command must be idempotent, and `correlation_id` must be preserved in command for queue creation, so that the same `correlation_id` and all other data is used in retries. `correlation_id` should be removed after queue creation success. + +To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` / `link_id` should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used. + +Alternative solutions considered and rejected: +- additional request to save queue data, after `sender_id` is returned by the server. The scenarios that require short links are interactive - creating user addresses and 1-time invitations - so making two requests instead of one would make the UX worse. +- include empty sender_id in the immutable data and have it replaced by the accepting party with `sender_id` received in `LINK` response - both a weird design, and might create possibility for some attacks via server, especially for contact addresses. +- making NEW commands idempotent. Doing it would require generating all IDs client-side, not only `sender_id`. It increases complexity, and it is not really necessary as the only scenarios when retries are needed are async NEW commands, that do not require short links. For future short links of chat relays the retries are much less likely, as chat relays will have good network connections. + ## Algorithm to prepare and to interpret queue link data. For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existense checks. @@ -166,6 +180,42 @@ For contact addresses this approach follows the design proposed in [Short links] - for one time links the sender must authorize the request to retrieve the data, the key is provided with the first request, preventing undetected access by link observers. - having received the link data, the client can now decrypt it using secret_box. +## Improved algorithm to prepare and to interpret queue link data. + +This scheme reduces the size of the binary in the link from 48 bytes (72 in case of 1-time links) to 32 bytes (56 bytes for 1-time links). + +For immutable data. + +1. `link_key = SHA3-256(immutable_data)` - used as part of link, and to encrypt content. +2. HKDF: + 1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`. + 2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated. +3. +3. Random `nonce1` (for immutable data), to be stored with the link data. +4. Encrypt: `(ct1, tag1) = secret_box(immutable_data, key, nonce1)`. +5. Store: `(nonce1, ct1, tag1)` stored as immutable link data. + +For mutable user data: + +1. Random `nonce2` and the same key are used. +2. Sign `user_data` with key included in `immutable_data`. +3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`. +4. Store: `(nonce2, ct2, tag2)` + +Link recipient: + +1. Receives `link_key` in the link, for 1-time invitations also `link_id`. +2. HKDF: + 1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`. + 2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`. +3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`. +4. Decrypt: `immutable_data = decrypt (nonce1, ct1, tag1)`. +5. Verify: `SHA3-256(immutable_data) == link_key`, abort if not. +6. Decrypt: `signed_used_data = decrypt(nonce2, ct2, tag2)` +7. Verify signature with key in immutable data. + +While using content hash as encryption key is unconventional, it is not completely unheard of - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `immutable_data` contains mostly random keys. + ## Threat model **Compromised SMP server** @@ -214,11 +264,10 @@ The proposed syntax: shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ] smpServerHost = ; RFC1123, RFC5891 linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes -oneTimeLinkBytes = ; 60 bytes / 80 base64 encoded characters -contactLinkBytes = ; 48 bytes / 64 base64 encoded characters +oneTimeLinkBytes = ; 56 bytes / 75 base64 encoded characters +contactLinkBytes = ; 32 bytes / 43 base64 encoded characters ; linkId - 96 bits/24 bytes ; linkKey - 256 bits/32 bytes -; linkAuthTag - 128 bits/16 bytes auth tag from encryption of immutable link data> serverInfo = [fingerprint "@" [hostnames "/"]] ; not needed for preset servers, required otherwise - the clients must refuse to connect if they don't have fingerprint in the code. @@ -228,28 +277,28 @@ hostnames = "h=" *( "," ) ; additional hostnames, e.g. oni To have shorter links fingerpring and additional server hostnames do not need to be specified for preconfigured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint. -Example one-time link for preset server (108 characters): +Example one-time link for preset server (103 characters): ``` -https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789 +https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234 ``` -Example contact link for preset server (92 characters): +Example contact link for preset server (71 characters): ``` -https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd +https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc ``` -Example contact link for user-defined server (with fingerprint, but without onion hostname - 136 characters): +Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters): ``` -https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd +https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc ``` -Example contact link for user-defined server (with fingerprint ant onion hostname - 199 characters): +Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters): ``` -https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd +https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc ``` For the links to work in the browser the servers must provide server pages. diff --git a/simplexmq.cabal b/simplexmq.cabal index f2e1d2084..d1f30a2b9 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -121,6 +121,7 @@ library Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG + Simplex.Messaging.Crypto.ShortLink Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String Simplex.Messaging.Notifications.Client @@ -158,6 +159,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Migrations.App Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -203,6 +205,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links if !flag(client_library) exposed-modules: Simplex.FileTransfer.Client.Main @@ -366,6 +369,8 @@ executable ntf-server executable smp-server if flag(client_library) buildable: False + if flag(server_postgres) + cpp-options: -DdbServerPostgres main-is: Main.hs other-modules: Static @@ -441,6 +446,7 @@ test-suite simplexmq-test AgentTests.MigrationTests AgentTests.NotificationTests AgentTests.ServerChoice + AgentTests.ShortLinkTests CLITests CoreTests.BatchingTests CoreTests.CryptoFileTests diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d98fd5858..bc6a02715 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -56,6 +56,7 @@ module Simplex.Messaging.Agent deleteConnectionAsync, deleteConnectionsAsync, createConnection, + getConnShortLink, changeConnectionUser, prepareConnectionToJoin, prepareConnectionToAccept, @@ -181,13 +182,14 @@ import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), Server import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) +import qualified Simplex.Messaging.Crypto.ShortLink as SL import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -340,10 +342,27 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' {-# INLINE deleteConnectionsAsync #-} -- | Create SMP agent connection (NEW command) -createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c) -createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs +createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c))) +createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs {-# INLINE createConnection #-} +-- | Create or update user's contact connection short link +-- TODO [short links] +setConnShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact) +setConnShortLink c = withAgentEnv c .: setConnShortLink' c +{-# INLINE setConnShortLink #-} + +-- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries +getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo) +getConnShortLink c = withAgentEnv c .: getConnShortLink' c +{-# INLINE getConnShortLink #-} + +-- | This irreversible deletes short link data, and it won't be retrievable again +-- TODO [short links] +delInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE () +delInvShortLink c = withAgentEnv c . delInvShortLink' c +{-# INLINE delInvShortLink #-} + -- | Changes the user id associated with a connection changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE () changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId @@ -776,12 +795,45 @@ switchConnectionAsync' c corrId connId = pure . connectionStats $ DuplexConnection cData rqs' sqs _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex" -newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c) -newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do +newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c))) +newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do srv <- getSMPServer c userId connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) - cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv - pure (connId, cReq) + (connId,) <$> newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv + `catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e + +setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact) +setConnShortLink' = undefined + +getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) +getConnShortLink' c userId = \case + CSLInvitation srv linkId linkKey -> do + g <- asks random + invLink <- withStore' c $ \db -> do + getInvShortLink db srv linkId >>= \case + Just sl@InvShortLink {linkKey = lk} | linkKey == lk -> pure sl + _ -> do + (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey} + createInvShortLink db sl + pure sl + let k = SL.invShortLinkKdf linkKey + secureGetQueueLink c userId invLink >>= decryptData srv linkKey k + CSLContact srv _ linkKey -> do + let (linkId, k) = SL.contactShortLinkKdf linkKey + getQueueLink c userId srv linkId >>= decryptData srv linkKey k + where + decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) + decryptData srv linkKey k (sndId, d) = do + r <- liftEither $ SL.decryptLinkData @c linkKey k d + checkSameQueue $ case fst r of CRInvitationUri crd _ -> crd; CRContactUri crd -> crd + pure r + where + checkSameQueue ConnReqUriData {crSmpQueues = SMPQueueUri {queueAddress = SMPQueueAddress srv' sndId' _ _} :| _} = + unless (srv == srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address" + +delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () +delInvShortLink' = undefined changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do @@ -793,28 +845,86 @@ changeConnectionUser' c oldUserId connId newUserId = do where updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId -newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c) -newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do +newRcvConnSrv :: ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c) +newRcvConnSrv c userId connId enableNtfs cMode = + fmap fst .:: newRcvConnSrv_ c userId connId enableNtfs cMode Nothing +{-# INLINE newRcvConnSrv #-} + +newRcvConnSrv_ :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) +newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () - AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - 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 - when enableNtfs $ do - ns <- asks ntfSupervisor - atomically $ sendNtfSubCommand ns (NSCCreate, [connId]) - let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData - case cMode of - SCMContact -> pure $ CRContactUri crData - SCMInvitation -> do + e2eKeys <- atomically . C.generateKeyPair =<< asks random + case userData_ of + Just d -> do + (nonce, qUri, cReq, qd) <- prepareLinkData d $ fst e2eKeys + (rq, qUri') <- createRcvQueue (Just nonce) qd e2eKeys + connReqWithShortLink qUri cReq qUri' (shortLink rq) + Nothing -> do + let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing + (_, qUri) <- createRcvQueue Nothing qd e2eKeys + (,Nothing) <$> createConnReq qUri + where + createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri) + createRcvQueue nonce_ qd e2eKeys = do + AgentConfig {smpClientVRange = vr} <- asks config + let ntfCreds_ = Nothing -- TODO [short links] + (rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode ntfCreds_ nonce_ e2eKeys `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 + when enableNtfs $ do + ns <- asks ntfSupervisor + atomically $ sendNtfSubCommand ns (NSCCreate, [connId]) + pure (rq', qUri) + createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c) + createConnReq qUri = do + AgentConfig {smpAgentVRange, e2eEncryptVRange} <- asks config + let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData + case cMode of + SCMContact -> pure $ CRContactUri crData + SCMInvitation -> do + g <- asks random + (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys) + withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem + pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange + prepareLinkData :: ConnInfo -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData) + prepareLinkData userData e2eDhKey = do g <- asks random - (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys) - withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem - pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange + nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g + sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g + AgentConfig {smpClientVRange = vr, smpAgentVRange = agentVRange} <- asks config + let sndId = SMP.EntityId $ C.sha3_256 corrId + sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True + qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure + connReq <- createConnReq qUri + let (linkKey, linkData) = SL.encodeSignLinkData sigKeys agentVRange connReq userData + qd <- case cMode of + SCMContact -> do + let (linkId, k) = SL.contactShortLinkKdf linkKey + srvData <- liftIO $ SL.encryptLinkData g k linkData + pure $ CQRContact $ Just CQRData {linkKey, privSigKey, srvReq = (linkId, (sndId, srvData))} + SCMInvitation -> do + let k = SL.invShortLinkKdf linkKey + srvData <- liftIO $ SL.encryptLinkData g k linkData + pure $ CQRMessaging $ Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)} + pure (nonce, qUri, connReq, qd) + connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) + connReqWithShortLink qUri cReq qUri' shortLink = case shortLink of + Just ShortLinkCreds {shortLinkId, shortLinkKey} + | qUri == qUri' -> + let link = case cReq of + CRContactUri _ -> CSLContact srv CCTContact shortLinkKey + CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey + in pure (cReq, Just link) + | otherwise -> throwE $ INTERNAL "different rcv queue address" + Nothing -> + let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData) + cReq' = case cReq of + CRContactUri crData -> CRContactUri (updated crData) + CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams + in pure (cReq', Nothing) newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of @@ -842,6 +952,7 @@ newConnToAccept c connId enableNtfs invId pqSup = do newConnToJoin c userId connId enableNtfs connReq pqSup _ -> throwE $ CMD PROHIBITED "newConnToAccept" +-- TODO [short link] joining queue that was already secured with LKEY joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do srv <- getNextSMPServer c userId [qServer cReqQueue] @@ -958,8 +1069,8 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do - let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure + -- TODO [short links] ntf credentials + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode Nothing atomically $ incSMPServerStat c userId (qServer rq) connCreated let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq @@ -1727,7 +1838,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth - (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False + -- TODO [short links] send correct NTF credentials here + (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe Nothing let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' lift $ addNewQueueSubscription c rq'' tSess sessId diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 37f01752f..ae80dc459 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -26,6 +26,8 @@ module Simplex.Messaging.Agent.Client ( AgentClient (..), ProtocolTestFailure (..), ProtocolTestStep (..), + ClntQueueReqData (..), + CQRData (..), newAgentClient, withConnLock, withConnLocks, @@ -43,6 +45,7 @@ module Simplex.Messaging.Agent.Client runNTFServerTest, getXFTPWorkPath, newRcvQueue, + newRcvQueue_, subscribeQueues, getQueueMessage, decryptSMPMessage, @@ -57,6 +60,10 @@ module Simplex.Messaging.Agent.Client serverHostError, secureQueue, secureSndQueue, + addQueueLink, + deleteQueueLink, + secureGetQueueLink, + getQueueLink, enableQueueNotifications, EnableQueueNtfReq (..), enableQueuesNtfs, @@ -256,22 +263,25 @@ import Simplex.Messaging.Protocol RcvNtfPublicDhKey, SMPMsgMeta (..), SProtocolType (..), - SenderCanSecure, SndPublicAuthKey, SubscriptionMode (..), + QueueReqData (..), + QueueLinkData, + NewNtfCreds, UserProtocol, VersionRangeSMPC, VersionSMPC, XFTPServer, XFTPServerWithAuth, pattern NoEntity, + senderCanSecure, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Session import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId), TransportError (..)) +import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -1076,9 +1086,24 @@ sendOrProxySMPCommand :: (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) -> (SMPClient -> ExceptT SMPClientError IO ()) -> AM (Maybe SMPServer) -sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do +sendOrProxySMPCommand c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly = + fst <$> sendOrProxySMPCommand_ c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly +{-# INLINE sendOrProxySMPCommand #-} + +sendOrProxySMPCommand_ :: + forall a. + AgentClient -> + UserId -> + SMPServer -> + ConnId -> -- session entity ID, for short links LinkId is used + ByteString -> + SMP.EntityId -> -- sender or link ID + (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) -> + (SMPClient -> ExceptT SMPClientError IO a) -> + AM (Maybe SMPServer, a) +sendOrProxySMPCommand_ c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do tSess <- mkTransportSession c userId destSrv connId - ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing) + ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess) where shouldUseProxy = do cfg <- getNetworkConfig c @@ -1096,13 +1121,13 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId SPFAllowProtected -> ipAddressProtected cfg destSrv SPFProhibit -> False unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c) - sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer) + sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a) sendViaProxy proxySrv_ destSess@(_, _, connId_) = do - r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do + r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess let proxySrv = protocolClientServer' smp case r' of - Right () -> pure $ Just proxySrv + Right r -> pure (Just proxySrv, r) Left proxyErr -> do case proxyErr of ProxyProtocolError (SMP.PROXY SMP.NO_SESSION) -> do @@ -1136,18 +1161,17 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp') sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess' case r of - Right r' -> do + Right r'@(srv_, _) -> do atomically $ incSMPServerStat c userId destSrv sentViaProxy - forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied + forM_ srv_ $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied pure r' Left e - | serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e) + | serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e) | otherwise -> throwE e sendDirectly tSess = - withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do - r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp - case r of - Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect + withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + tryAgentError (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case + Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect) Left e -> throwE e ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool @@ -1222,11 +1246,11 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True + SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing liftError (testErr TSSecureQueue) $ - if sndSecure - then secureSndSMPQueue smp spKey sndId sKey - else secureSMPQueue smp rpKey rcvId sKey + case queueMode of + Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey + _ -> 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 @@ -1333,19 +1357,42 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode getSessionMode = fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do +-- TODO [short links] add ntf credentials to RcvQueue +newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> Maybe NewNtfCreds -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c userId connId srv vRange cMode subMode ntfCreds = do + let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing + e2eKeys <- atomically . C.generateKeyPair =<< asks random + newRcvQueue_ c userId connId srv vRange qrd subMode ntfCreds Nothing e2eKeys + +data ClntQueueReqData + = CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData))) + | CQRContact (Maybe (CQRData (SMP.LinkId, (SMP.SenderId, QueueLinkData)))) + +data CQRData r = CQRData + { linkKey :: LinkKey, + privSigKey :: C.PrivateKeyEd25519, + srvReq :: r + } + +queueReqData :: ClntQueueReqData -> QueueReqData +queueReqData = \case + CQRMessaging d -> QRMessaging $ srvReq <$> d + CQRContact d -> QRContact $ srvReq <$> d + +newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe NewNtfCreds -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode ntfCreds nonce_ (e2eDhKey, e2ePrivKey) = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, privDhKey) <- atomically $ C.generateKeyPair g - (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv NoEntity "NEW" tSess <- mkTransportSession c userId srv connId - (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- + -- TODO [short links] serverNtfCreds + r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serverNtfCreds}) <- withClient c tSess $ \(SMPConnectedClient smp _) -> - (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure + (thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] + shortLink <- mkShortLinkCreds r let rq = RcvQueue { userId, @@ -1358,17 +1405,47 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender e2eDhSecret = Nothing, sndId, sndSecure, + shortLink, status = New, dbQueueId = DBNewQueue, primary = True, dbReplaceQueueId = Nothing, rcvSwchStatus = Nothing, smpClientVersion = maxVersion vRange, - clientNtfCreds = Nothing, + clientNtfCreds = Nothing, -- TODO [short links] deleteErrors = 0 } qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure - pure (rq, qUri, tSess, sessId) + -- TODO [short links] maybe switch to queue mode? + sndSecure = senderCanSecure queueMode + pure (rq, qUri, tSess, sessionId thParams') + where + mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds) + mkShortLinkCreds (thParams', QIK {sndId, queueMode, linkId}) = case (cqrd, queueMode) of + (CQRMessaging ld, Just QMMessaging) -> + withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} -> + if sndId == sndId' + then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d) + else newErr "different sender ID" + (CQRContact ld, Just QMContact) -> + withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (lnkId', (sndId', d))} -> + if sndId == sndId' && lnkId == lnkId' + then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d) + else newErr "different sender or link IDs" + (_, Nothing) -> case linkId of + Nothing | v < sndAuthKeySMPVersion -> pure Nothing + _ -> newErr "unexpected link ID" + _ -> newErr "unexpected queue mode" + where + v = thVersion thParams' + withLinkData :: Maybe d -> (SMP.LinkId -> d -> AM (Maybe ShortLinkCreds)) -> AM (Maybe ShortLinkCreds) + withLinkData ld_ mkLink = case (ld_, linkId) of + (Just ld, Just lnkId) -> mkLink lnkId ld + (Just _, Nothing) | v < shortLinksSMPVersion -> pure Nothing + (Nothing, Nothing) -> pure Nothing + _ -> newErr "unexpected or absent link ID" + newErr :: String -> AM (Maybe ShortLinkCreds) + newErr = throwE . BROKER (B.unpack $ strEncode srv) . UNEXPECTED . ("Create queue: " <>) processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError () -> STM () processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case @@ -1611,6 +1688,28 @@ secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPubl secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey +addQueueLink :: AgentClient -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM () +addQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d = + withSMPClient c rq "LSET" $ \smp -> addSMPQueueLink smp rcvPrivateKey rcvId lnkId d + +deleteQueueLink :: AgentClient -> RcvQueue -> AM () +deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId + +secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData) +secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} = + snd <$> sendOrProxySMPCommand_ c userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly + where + secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey + secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey + +getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData) +getQueueLink c userId server lnkId = + snd <$> sendOrProxySMPCommand_ c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly + where + getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId + getDirectly smp = getSMPQueueLink smp lnkId + 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 4c6c75d8c..a7640fe0f 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -108,6 +110,11 @@ module Simplex.Messaging.Agent.Protocol ConnReqUriData (..), CRClientData, ServiceScheme, + FixedLinkData (..), + UserLinkData (..), + ConnShortLink (..), + ContactConnType (..), + LinkKey (..), sameConnReqContact, simplexChat, connReqUriP', @@ -151,8 +158,10 @@ import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Char (isDigit) import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind (Type) @@ -1042,6 +1051,11 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData strP = connReqUriP' (Just SSSimplex) +-- TODO [short links] do not use StrEncoding instance +instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where + smpEncode = smpEncode . Large . strEncode + smpP = strDecode . unLarge <$?> smpP + connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m) connReqUriP' overrideScheme = do ACR m cr <- connReqUriP overrideScheme @@ -1188,7 +1202,7 @@ data SMPQueueAddress = SMPQueueAddress { smpServer :: SMPServer, senderId :: SMP.SenderId, dhPublicKey :: C.PublicKeyX25519, - sndSecure :: Bool + sndSecure :: Bool -- TODO [short links] replace with queueMode? } deriving (Eq, Show) @@ -1271,6 +1285,65 @@ instance Eq AConnectionRequestUri where deriving instance Show AConnectionRequestUri +data ConnShortLink (m :: ConnectionMode) where + CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation + CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact + +deriving instance Show (ConnShortLink m) + +newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data) + deriving (Eq, Show) + deriving newtype (FromField, StrEncoding) + +instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s + +data ContactConnType = CCTContact | CCTGroup deriving (Show) + +data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) + +-- TODO [short link] parser, parsing tests +data AConnectionLink = ACLFull AConnectionRequestUri | ACLShort AConnShortLink + +instance ConnectionModeI m => StrEncoding (ConnShortLink m) where + strEncode = \case + CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i" + CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g" + where + encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType = + "https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> B64.encodeUnpadded kh <> "@" <> hosts <> B64.encodeUnpadded linkUri + where + port' = if null port then "" else B.pack (':' : port) + hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/" + strP = do + ACSL m l <- strP + case testEquality m $ sConnectionMode @m of + Just Refl -> pure l + _ -> fail "bad short link mode" + +instance StrEncoding AConnShortLink where + strEncode (ACSL _ l) = strEncode l + strP = do + h <- "https://" *> strP + port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure "" + linkType <- A.char '/' *> A.anyChar + keyHash <- optional (A.char '/') *> A.char '#' *> strP <* A.char '@' + TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ []) + linkUri <- strP + let srv = SMPServer (h :| hs) port keyHash + case linkType of + 'i' + | B.length linkUri == 56 -> + let (lnkId, k) = B.splitAt 24 linkUri + in pure $ ACSL SCMInvitation $ CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) + | otherwise -> fail "bad ConnShortLink: incorrect linkID and key length" + 'c' -> contactP srv CCTContact linkUri + 'g' -> contactP srv CCTGroup linkUri + _ -> fail "bad ConnShortLink: unknown link type" + where + contactP srv ct k + | B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k) + | otherwise = fail "bad ConnShortLink: incorrect key length" + sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) = L.length qs == L.length qs' && all same (L.zip qs qs') @@ -1287,6 +1360,31 @@ data ConnReqUriData = ConnReqUriData type CRClientData = Text +data FixedLinkData c = FixedLinkData + { agentVRange :: VersionRangeSMPA, + sigKey :: C.PublicKeyEd25519, + connReq :: ConnectionRequestUri c + } + +data UserLinkData = UserLinkData + { agentVRange :: VersionRangeSMPA, + userData :: ConnInfo + } + +instance ConnectionModeI c => Encoding (FixedLinkData c) where + smpEncode FixedLinkData {agentVRange, sigKey, connReq} = + smpEncode (agentVRange, sigKey, connReq) + smpP = do + (agentVRange, sigKey, connReq) <- smpP + pure FixedLinkData {agentVRange, sigKey, connReq} + +instance Encoding UserLinkData where + smpEncode UserLinkData {agentVRange, userData} = + smpEncode (agentVRange, Large userData) + smpP = do + (agentVRange, Large userData) <- smpP + pure UserLinkData {agentVRange, userData} + -- | SMP queue status. data QueueStatus = -- | queue is created @@ -1419,6 +1517,8 @@ data SMPAgentError A_PROHIBITED {prohibitedErr :: String} | -- | incompatible version of SMP client, agent or encryption protocols A_VERSION + | -- | failed signature, hash or senderId verification of retrieved link data + A_LINK {linkErr :: String} | -- | cannot decrypt message A_CRYPTO {cryptoErr :: AgentCryptoError} | -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 14e1f1fc8..7375ed41b 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -93,6 +93,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue sndId :: SMP.SenderId, -- | sender can secure the queue sndSecure :: SenderCanSecure, + -- | short link ID and credentials + shortLink :: Maybe ShortLinkCreds, -- | queue status status :: QueueStatus, -- | database queue ID (within connection) @@ -110,6 +112,14 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue } deriving (Show) +data ShortLinkCreds = ShortLinkCreds + { shortLinkId :: SMP.LinkId, + shortLinkKey :: LinkKey, + linkPrivSigKey :: C.PrivateKeyEd25519, + linkEncFixedData :: SMP.EncFixedDataBytes + } + deriving (Show) + rcvQueueInfo :: RcvQueue -> RcvQueueInfo rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} = RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq} @@ -137,6 +147,18 @@ data ClientNtfCreds = ClientNtfCreds } deriving (Show) +-- This record is stored in inv_short_links table. +-- It is needed only for 1-time invitation links because of "secure-on-read" property of link data, +-- that prevents undetected access to link data from link observers. +data InvShortLink = InvShortLink + { server :: SMPServer, + linkId :: SMP.LinkId, + linkKey :: LinkKey, + sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries + sndPublicKey :: SndPublicAuthKey + } + deriving (Show) + type SndQueue = StoredSndQueue 'QSStored type NewSndQueue = StoredSndQueue 'QSNew diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index a8c1e1fb0..f19b02af1 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -58,6 +58,7 @@ module Simplex.Messaging.Agent.Store.AgentStore getRcvQueueById, getSndQueueById, deleteConn, + deleteConnRecord, upgradeRcvConnToDuplex, upgradeSndConnToDuplex, addConnRcvQueue, @@ -88,6 +89,8 @@ module Simplex.Messaging.Agent.Store.AgentStore acceptInvitation, unacceptInvitation, deleteInvitation, + getInvShortLink, + createInvShortLink, -- Messages updateRcvIds, createRcvMsg, @@ -410,6 +413,9 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup |] (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True) +deleteConnRecord :: DB.Connection -> ConnId -> IO () +deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) + checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do fromMaybe False @@ -442,7 +448,7 @@ deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of (pure Nothing) ) where - delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId + delete = deleteConnRecord db connId $> Just connId checkNoPendingDeliveries_ = do r :: (Maybe Int64) <- maybeFirstRow fromOnly $ @@ -756,6 +762,40 @@ deleteInvitation db contactConnId invId = Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId) _ -> pure $ Left SEConnNotFound +getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink) +getInvShortLink db server linkId = + maybeFirstRow toInvShortLink $ + DB.query + db + [sql| + SELECT link_key, snd_private_key + FROM inv_short_links + WHERE host = ? AND port = ? AND link_id = ? + |] + (host server, port server, linkId) + where + toInvShortLink :: (LinkKey, C.APrivateAuthKey) -> InvShortLink + toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk)) = + let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk + in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey} + +createInvShortLink :: DB.Connection -> InvShortLink -> IO () +createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey} = do + serverKeyHash_ <- createServer_ db server + DB.execute + db + [sql| + INSERT INTO inv_short_links + (host, port, server_key_hash, link_id, link_key, snd_private_key) + VALUES (?,?,?,?,?,?) + ON CONFLICT (host, port, link_id) + DO UPDATE SET + server_key_hash = EXCLUDED.server_key_hash, + link_key = EXCLUDED.link_key, + snd_private_key = EXCLUDED.snd_private_key + |] + (host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey) + updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds db connId = do (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId @@ -1884,9 +1924,15 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do 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, snd_secure, 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, + link_id, link_key, link_priv_sig_key, link_enc_fixed_data + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) + :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_) + :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink) + ) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} -- * createSndConn helpers @@ -2054,7 +2100,8 @@ rcvQueueQuery = 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.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 + q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, + q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q JOIN servers s ON q.host = s.host AND q.port = s.port JOIN connections c ON q.conn_id = c.conn_id @@ -2063,15 +2110,24 @@ rcvQueueQuery = toRcvQueue :: (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt) :. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) - :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> + :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) + :. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue + ( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) + :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) + :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) + :. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) + ) = 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} + (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, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of + (Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} + _ -> Nothing + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById db connId dbRcvId = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs index e47fe432a..e6e6efaf8 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -6,12 +6,14 @@ import Data.List (sortOn) import Data.Text (Text) import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = [ ("20241210_initial", m20241210_initial, Nothing), - ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) + ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies), + ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs new file mode 100644 index 000000000..4948eac82 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.RawString.QQ (r) + +m20250322_short_links :: Text +m20250322_short_links = + T.pack + [r| +ALTER TABLE rcv_queues ADD COLUMN link_id BYTEA; +ALTER TABLE rcv_queues ADD COLUMN link_key BYTEA; +ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BYTEA; +ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BYTEA; + +CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id); + +CREATE TABLE inv_short_links( + inv_short_link_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + host TEXT NOT NULL, + port TEXT NOT NULL, + server_key_hash BYTEA, + link_id BYTEA NOT NULL, + link_key BYTEA NOT NULL, + snd_private_key BYTEA NOT NULL, + FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE +); + +CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id); +|] + +down_m20250322_short_links :: Text +down_m20250322_short_links = + T.pack + [r| +DROP INDEX idx_rcv_queues_link_id; +ALTER TABLE rcv_queues DROP COLUMN link_id; +ALTER TABLE rcv_queues DROP COLUMN link_key; +ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key; +ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data; + +DROP INDEX idx_inv_short_links_link_id; +DROP TABLE inv_short_links; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs index 8c885a9e5..eea7db3ca 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -42,6 +42,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_d import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -83,7 +84,8 @@ schemaMigrations = ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete), ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params), - ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) + ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies), + ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs new file mode 100644 index 000000000..b79ce24e0 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20250322_short_links :: Query +m20250322_short_links = + [sql| +ALTER TABLE rcv_queues ADD COLUMN link_id BLOB; +ALTER TABLE rcv_queues ADD COLUMN link_key BLOB; +ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BLOB; +ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BLOB; + +CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id); + +CREATE TABLE inv_short_links( + inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT, + host TEXT NOT NULL, + port TEXT NOT NULL, + server_key_hash BLOB, + link_id BLOB NOT NULL, + link_key BLOB NOT NULL, + snd_private_key BLOB NOT NULL, + FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE +); + +CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id); + |] + +down_m20250322_short_links :: Query +down_m20250322_short_links = + [sql| +DROP INDEX idx_rcv_queues_link_id; +ALTER TABLE rcv_queues DROP COLUMN link_id; +ALTER TABLE rcv_queues DROP COLUMN link_key; +ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key; +ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data; + +DROP INDEX idx_inv_short_links_link_id; +DROP TABLE inv_short_links; + |] 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 3f9a468e1..89d1d271a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -57,6 +57,10 @@ CREATE TABLE rcv_queues( deleted INTEGER NOT NULL DEFAULT 0, snd_secure INTEGER NOT NULL DEFAULT 0, last_broker_ts TEXT, + link_id BLOB, + link_key BLOB, + link_priv_sig_key BLOB, + link_enc_fixed_data BLOB, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -422,6 +426,16 @@ CREATE TABLE snd_message_bodies( snd_message_body_id INTEGER PRIMARY KEY, agent_msg BLOB NOT NULL DEFAULT x'' ); +CREATE TABLE inv_short_links( + inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT, + host TEXT NOT NULL, + port TEXT NOT NULL, + server_key_hash BLOB, + link_id BLOB NOT NULL, + link_key BLOB NOT NULL, + snd_private_key BLOB NOT NULL, + FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE +); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id); @@ -551,3 +565,9 @@ CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id); CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages( snd_message_body_id ); +CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id); +CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links( + host, + port, + link_id +); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index df12e5fce..4aebc107e 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -49,6 +49,12 @@ module Simplex.Messaging.Client secureSMPQueue, secureSndSMPQueue, proxySecureSndSMPQueue, + addSMPQueueLink, + deleteSMPQueueLink, + secureGetSMPQueueLink, + proxySecureGetSMPQueueLink, + getSMPQueueLink, + proxyGetSMPQueueLink, enableSMPQueueNotifications, disableSMPQueueNotifications, enableSMPQueuesNtfs, @@ -706,14 +712,16 @@ smpProxyError = \case -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command createSMPQueue :: SMPClient -> + Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> - Bool -> + QueueReqData -> + Maybe NewNtfCreds -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure = - sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case +createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds = + sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r @@ -799,9 +807,47 @@ secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey {-# INLINE secureSndSMPQueue #-} proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ()) -proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) +proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) {-# INLINE proxySecureSndSMPQueue #-} +-- | Add or update date for queue link +addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO () +addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId +{-# INLINE addSMPQueueLink #-} + +-- | Delete queue link +deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () +deleteSMPQueueLink = okSMPCommand LDEL +{-# INLINE deleteSMPQueueLink #-} + +-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID. +secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData) +secureGetSMPQueueLink c spKey lnkId senderKey = + sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case + LNK sId d -> pure (sId, d) + r -> throwE $ unexpectedResponse r + +proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) +proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey = + proxySMPCommand c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case + Right (LNK sId d) -> pure $ Right (sId, d) + Right r -> throwE $ unexpectedResponse r + Left e -> pure $ Left e + +-- | Get contact address SMP queue link data. +getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData) +getSMPQueueLink c lnkId = + sendSMPCommand c Nothing lnkId LGET >>= \case + LNK sId d -> pure (sId, d) + r -> throwE $ unexpectedResponse r + +proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) +proxyGetSMPQueueLink c proxiedRelay lnkId = + proxySMPCommand c proxiedRelay Nothing lnkId LGET >>= \case + Right (LNK sId d) -> pure $ Right (sId, d) + Right r -> throwE $ unexpectedResponse r + Left e -> pure $ Left e + -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command @@ -843,7 +889,7 @@ sendSMPMessage c spKey sId flags msg = r -> throwE $ unexpectedResponse r proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) -proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg) +proxySMPMessage c proxiedRelay spKey sId flags msg = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg) -- | Acknowledge message delivery (server deletes the message). -- @@ -955,15 +1001,24 @@ instance StrEncoding ProxyClientError where -- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError -- This function proxies Sender commands that return OK or ERR +proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxyOKSMPCommand c proxiedRelay spKey sId command = + proxySMPCommand c proxiedRelay spKey sId command >>= \case + Right OK -> pure $ Right () + Right r -> throwE $ unexpectedResponse r + Left e -> pure $ Left e + proxySMPCommand :: + forall p. + PartyI p => SMPClient -> -- proxy session from PKEY ProxiedRelay -> -- message to deliver Maybe SndPrivateAuthKey -> SenderId -> - Command 'Sender -> - ExceptT SMPClientError IO (Either ProxyClientError ()) + Command p -> + ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg) proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do -- prepare params let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams @@ -972,7 +1027,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c let cmdSecret = C.dh' serverKey cmdPrivKey nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g -- encode - let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command) + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command) auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of [] -> throwE $ PCETransportError TELargeMsg @@ -990,9 +1045,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c case tParse serverThParams t' of t'' :| [] -> case tDecodeParseValidate serverThParams t'' of (_auth, _signed, (_c, _e, cmd)) -> case cmd of - Right OK -> pure $ Right () Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay - Right r' -> throwE $ unexpectedResponse r' + Right r' -> pure $ Right r' Left e -> throwE $ PCEResponseError e _ -> throwE $ PCETransportError TEBadBlock ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left @@ -1101,6 +1155,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing -- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it. -- We could expire a batch of deletes, for example, either when the first response expires or when the last one does. -- But a better solution is to process delayed delete responses. +-- +-- Please note: if nonce is passed it is also used as a correlation ID sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd = ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index b4af69450..88b882432 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -142,6 +142,8 @@ module Simplex.Messaging.Crypto cbDecryptNoPad, sbDecrypt_, sbEncrypt_, + sbEncryptNoPad, + sbDecryptNoPad, cbNonce, randomCbNonce, reverseNonce, @@ -160,6 +162,7 @@ module Simplex.Messaging.Crypto SbKeyNonce, sbcInit, sbcHkdf, + hkdf, -- * pseudo-random bytes randomBytes, @@ -167,6 +170,7 @@ module Simplex.Messaging.Crypto -- * digests sha256Hash, sha512Hash, + sha3_256, -- * Message padding / un-padding canPad, @@ -207,7 +211,7 @@ import Crypto.Cipher.AES (AES256) import qualified Crypto.Cipher.Types as AES import qualified Crypto.Cipher.XSalsa as XSalsa import qualified Crypto.Error as CE -import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize) +import Crypto.Hash (Digest, SHA256 (..), SHA3_256, SHA512 (..), hash, hashDigestSize) import qualified Crypto.KDF.HKDF as H import qualified Crypto.MAC.Poly1305 as Poly1305 import qualified Crypto.PubKey.Curve25519 as X25519 @@ -887,6 +891,7 @@ x448_size = 448 `quot` 8 validSignatureSize :: Int -> Bool validSignatureSize n = n == Ed25519.signatureSize || n == Ed448.signatureSize +{-# INLINE validSignatureSize #-} -- | AES key newtype. newtype Key = Key {unKey :: ByteString} @@ -961,10 +966,17 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP -- | SHA256 digest. sha256Hash :: ByteString -> ByteString sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256) +{-# INLINE sha256Hash #-} -- | SHA512 digest. sha512Hash :: ByteString -> ByteString sha512Hash = BA.convert . (hash :: ByteString -> Digest SHA512) +{-# INLINE sha512Hash #-} + +-- | SHA3-256 digest. +sha3_256 :: ByteString -> ByteString +sha3_256 = BA.convert . (hash :: ByteString -> Digest SHA3_256) +{-# INLINE sha3_256 #-} -- | AEAD-GCM encryption with associated data. -- @@ -981,6 +993,7 @@ encryptAEAD aesKey ivBytes paddedLen ad msg = do -- This function requires 12 bytes IV, it does not transform IV. encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString) encryptAESNoPad key iv = encryptAEADNoPad key iv "" +{-# INLINE encryptAESNoPad #-} encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString) encryptAEADNoPad aesKey ivBytes ad msg = do @@ -1002,6 +1015,7 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do -- This function requires 12 bytes IV, it does not transform IV. decryptAESNoPad :: Key -> GCMIV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString decryptAESNoPad key iv = decryptAEADNoPad key iv "" +{-# INLINE decryptAESNoPad #-} decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do @@ -1054,6 +1068,7 @@ maxLenBS s unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i unsafeMaxLenBS = MLBS +{-# INLINE unsafeMaxLenBS #-} padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2) padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#' @@ -1066,6 +1081,7 @@ appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2 maxLength :: forall i. KnownNat i => Int maxLength = fromIntegral (natVal $ Proxy @i) +{-# INLINE maxLength #-} -- this function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here: -- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c @@ -1086,12 +1102,15 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do -- | Random AES256 key. randomAesKey :: TVar ChaChaDRG -> STM Key randomAesKey = fmap Key . randomBytes aesKeySize +{-# INLINE randomAesKey #-} randomGCMIV :: TVar ChaChaDRG -> STM GCMIV randomGCMIV = fmap GCMIV . randomBytes gcmIVSize +{-# INLINE randomGCMIV #-} ivSize :: forall c. AES.BlockCipher c => Int ivSize = AES.blockSize (undefined :: c) +{-# INLINE ivSize #-} gcmIVSize :: Int gcmIVSize = 12 @@ -1101,6 +1120,7 @@ makeIV bs = maybeError CryptoIVError $ AES.makeIV bs maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a maybeError e = maybe (throwE e) return +{-# INLINE maybeError #-} cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError @@ -1111,12 +1131,15 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg +{-# INLINE sign' #-} sign :: APrivateSignKey -> ByteString -> ASignature sign (APrivateSignKey a k) = ASignature a . sign' k +{-# INLINE sign #-} signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate signCertificate = signX509 +{-# INLINE signCertificate #-} signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o signX509 key = fst . objectToSignedExact f @@ -1141,6 +1164,7 @@ verifyX509 key exact = do certificateFingerprint :: SignedCertificate -> KeyHash certificateFingerprint = signedFingerprint +{-# INLINE certificateFingerprint #-} signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash signedFingerprint o = KeyHash fp @@ -1154,16 +1178,20 @@ instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where signatureAlgorithmX509 = \case SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519 SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448 + {-# INLINE signatureAlgorithmX509 #-} instance SignatureAlgorithmX509 APrivateSignKey where signatureAlgorithmX509 (APrivateSignKey a _) = signatureAlgorithmX509 a + {-# INLINE signatureAlgorithmX509 #-} instance SignatureAlgorithmX509 APublicVerifyKey where signatureAlgorithmX509 (APublicVerifyKey a _) = signatureAlgorithmX509 a + {-# INLINE signatureAlgorithmX509 #-} -- | An instance for 'ASignatureKeyPair' / ('PublicKeyType' pk, pk), without touching its type family. instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where signatureAlgorithmX509 = signatureAlgorithmX509 . snd + {-# INLINE signatureAlgorithmX509 #-} -- | A wrapper to marshall signed ASN1 objects, like certificates. newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a} @@ -1198,6 +1226,7 @@ certChainP = do verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig +{-# INLINE verify' #-} verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of @@ -1207,25 +1236,35 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk +{-# INLINE dh' #-} -- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce. cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret +{-# INLINE cbEncrypt #-} -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding). cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce +{-# INLINE cbEncryptNoPad #-} -- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce. sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString sbEncrypt (SbKey key) = sbEncrypt_ key +{-# INLINE sbEncrypt #-} sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString sbEncrypt_ secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen +{-# INLINE sbEncrypt_ #-} + +sbEncryptNoPad :: SbKey -> CbNonce -> ByteString -> ByteString +sbEncryptNoPad (SbKey key) (CbNonce nonce) = cryptoBox key nonce +{-# INLINE sbEncryptNoPad #-} -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce. cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS +{-# INLINE cbEncryptMaxLenBS #-} cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString cryptoBox secret nonce s = BA.convert tag <> c @@ -1236,18 +1275,26 @@ cryptoBox secret nonce s = BA.convert tag <> c -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret +{-# INLINE cbDecrypt #-} -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret +{-# INLINE cbDecryptNoPad #-} -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce. sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString sbDecrypt (SbKey key) = sbDecrypt_ key +{-# INLINE sbDecrypt #-} -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce +{-# INLINE sbDecrypt_ #-} + +sbDecryptNoPad :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString +sbDecryptNoPad (SbKey key) = sbDecryptNoPad_ key +{-# INLINE sbDecryptNoPad #-} -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString @@ -1356,20 +1403,23 @@ newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString} sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey) sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2) where - prk = H.extract salt secret :: H.PRK SHA512 - out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64 - (ck1, ck2) = B.splitAt 32 out + (ck1, ck2) = B.splitAt 32 $ hkdf salt secret "SimpleXSbChainInit" 64 type SbKeyNonce = (SbKey, CbNonce) sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey) sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck') where - prk = H.extract B.empty ck :: H.PRK SHA512 - out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce) + out = hkdf "" ck "SimpleXSbChain" 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce) (ck', rest) = B.splitAt 32 out (sk, nonce) = B.splitAt 32 rest +hkdf :: ByteArrayAccess secret => ByteString -> secret -> ByteString -> Int -> ByteString +hkdf salt ikm info n = + let prk = H.extract salt ikm :: H.PRK SHA512 + in H.expand prk info n +{-# INLINE hkdf #-} + xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString) xSalsa20 secret nonce msg = (rs, msg') where diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 5ac052ad8..8c79503c8 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -94,8 +94,6 @@ import Control.Monad.Except import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import Crypto.Cipher.AES (AES256) -import Crypto.Hash (SHA512) -import qualified Crypto.KDF.HKDF as H import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J @@ -1130,8 +1128,7 @@ chainKdf (RatchetKey ck) = hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString) hkdf3 salt ikm info = (s1, s2, s3) where - prk = H.extract salt ikm :: H.PRK SHA512 - out = H.expand prk info 96 + out = hkdf salt ikm info 96 (s1, rest) = B.splitAt 32 out (s2, s3) = B.splitAt 32 rest diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs new file mode 100644 index 000000000..786d89ec8 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Simplex.Messaging.Crypto.ShortLink where + +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (first) +import Data.Bitraversable (bimapM) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Simplex.Messaging.Agent.Client (cryptoError) +import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding +import Simplex.Messaging.Protocol (EntityId (..), LinkId, EncDataBytes (..), QueueLinkData) + +contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey) +contactShortLinkKdf (LinkKey k) = + let (lnkId, sbKey) = B.splitAt 24 $ C.hkdf "" k "SimpleXContactLink" 56 + in (EntityId lnkId, C.unsafeSbKey sbKey) + +invShortLinkKdf :: LinkKey -> C.SbKey +invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32 + +encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) +encodeSignLinkData (sigKey, pk) agentVRange connReq userData = + let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq} + ud = smpEncode UserLinkData {agentVRange, userData} + in (LinkKey (C.sha3_256 fd), (sign fd, sign ud)) + where + sign s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s + +-- TODO [short links] possibly use padded encryption for fixed and for user data +encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> IO QueueLinkData +encryptLinkData g k = bimapM encrypt encrypt + where + encrypt s = do + nonce <- atomically $ C.randomCbNonce g + pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s + +decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo) +decryptLinkData linkKey k (encFD, encUD) = do + (sig1, fd) <- decrypt encFD + (sig2, ud) <- decrypt encUD + FixedLinkData {sigKey, connReq} <- decode fd + UserLinkData {userData} <- decode ud + if + | LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash" + | not (C.verify' sigKey sig1 fd) -> linkErr "link data signature" + | not (C.verify' sigKey sig2 ud) -> linkErr "user data signature" + | otherwise -> Right (connReq, userData) + where + decrypt (EncDataBytes d) = do + (nonce, Tail ct) <- decode d + (sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecryptNoPad k nonce ct) + (,s) <$> msgErr (C.decodeSignature sigBytes) + decode :: Encoding a => ByteString -> Either AgentErrorType a + decode = msgErr . smpDecode + msgErr = first (const $ AGENT A_MESSAGE) + linkErr = Left . AGENT . A_LINK diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 122246868..dfe596cf6 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -58,6 +58,14 @@ module Simplex.Messaging.Protocol Command (..), SubscriptionMode (..), SenderCanSecure, + NewQueueReq (..), + QueueReqData (..), + QueueMode (..), + QueueLinkData, + EncFixedDataBytes, + EncUserDataBytes, + EncDataBytes (..), + NewNtfCreds (..), Party (..), Cmd (..), DirectParty, @@ -65,6 +73,7 @@ module Simplex.Messaging.Protocol SParty (..), PartyI (..), QueueIdsKeys (..), + ServerNtfCreds (..), ProtocolErrorType (..), ErrorType (..), CommandError (..), @@ -108,6 +117,7 @@ module Simplex.Messaging.Protocol QueueId, RecipientId, SenderId, + LinkId, NotifierId, RcvPrivateAuthKey, RcvPublicAuthKey, @@ -140,6 +150,8 @@ module Simplex.Messaging.Protocol MsgFlags (..), initialSMPClientVersion, currentSMPClientVersion, + senderCanSecure, + queueReqMode, userProtocol, rcvMessageMeta, noMsgFlags, @@ -215,6 +227,7 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+)) import qualified GHC.TypeLits as TE import qualified GHC.TypeLits as Type import Network.Socket (ServiceName) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -281,7 +294,7 @@ e2eEncMessageLength :: Int e2eEncMessageLength = 16000 -- 15988 .. 16005 -- | SMP protocol clients -data Party = Recipient | Sender | Notifier | ProxiedClient +data Party = Recipient | Sender | Notifier | LinkClient | ProxiedClient deriving (Show) -- | Singleton types for SMP protocol clients @@ -289,12 +302,14 @@ data SParty :: Party -> Type where SRecipient :: SParty Recipient SSender :: SParty Sender SNotifier :: SParty Notifier + SLinkClient :: SParty LinkClient SProxiedClient :: SParty ProxiedClient instance TestEquality SParty where testEquality SRecipient SRecipient = Just Refl testEquality SSender SSender = Just Refl testEquality SNotifier SNotifier = Just Refl + testEquality SLinkClient SLinkClient = Just Refl testEquality SProxiedClient SProxiedClient = Just Refl testEquality _ _ = Nothing @@ -308,12 +323,15 @@ instance PartyI Sender where sParty = SSender instance PartyI Notifier where sParty = SNotifier +instance PartyI LinkClient where sParty = SLinkClient + instance PartyI ProxiedClient where sParty = SProxiedClient type family DirectParty (p :: Party) :: Constraint where DirectParty Recipient = () DirectParty Sender = () DirectParty Notifier = () + DirectParty LinkClient = () DirectParty p = (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not direct")) @@ -377,6 +395,8 @@ type SenderId = QueueId -- | SMP queue ID for notifications. type NotifierId = QueueId +type LinkId = QueueId + -- | SMP queue ID on the server. type QueueId = EntityId @@ -395,9 +415,11 @@ 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 -> SenderCanSecure -> Command Recipient + NEW :: NewQueueReq -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient + LSET :: LinkId -> QueueLinkData -> Command Recipient + LDEL :: Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient NDEL :: Command Recipient GET :: Command Recipient @@ -411,6 +433,9 @@ data Command (p :: Party) where -- SEND :: MsgBody -> Command Sender SEND :: MsgFlags -> MsgBody -> Command Sender PING :: Command Sender + -- Client accessing short links + LKEY :: SndPublicAuthKey -> Command LinkClient + LGET :: Command LinkClient -- SMP notification subscriber commands NSUB :: Command Notifier PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI @@ -427,9 +452,58 @@ data Command (p :: Party) where deriving instance Show (Command p) +data NewQueueReq = NewQueueReq + { rcvAuthKey :: RcvPublicAuthKey, + rcvDhKey :: RcvPublicDhKey, + auth_ :: Maybe BasicAuth, + subMode :: SubscriptionMode, + queueReqData :: Maybe QueueReqData, + ntfCreds :: Maybe NewNtfCreds + } + deriving (Show) + data SubscriptionMode = SMSubscribe | SMOnlyCreate deriving (Eq, Show) +-- SenderId must be computed client-side as `sha3-256(corr_id)`, `corr_id` - a random transmission ID. +-- The server must verify and reject it if it does not match (and in case of collision). +-- This allows to include SenderId in FixedDataBytes in full connection request, +-- and at the same time prevents the possibility of checking whether a queue with a known ID exists. +data QueueReqData = QRMessaging (Maybe (SenderId, QueueLinkData)) | QRContact (Maybe (LinkId, (SenderId, QueueLinkData))) + deriving (Show) + +queueReqMode :: QueueReqData -> QueueMode +queueReqMode = \case + QRMessaging _ -> QMMessaging + QRContact _ -> QMContact + +senderCanSecure :: Maybe QueueMode -> Bool +senderCanSecure = \case + Just QMMessaging -> True + _ -> False + +type QueueLinkData = (EncFixedDataBytes, EncUserDataBytes) + +type EncFixedDataBytes = EncDataBytes + +type EncUserDataBytes = EncDataBytes + +newtype EncDataBytes = EncDataBytes ByteString + deriving (Eq, Show) + deriving newtype (FromField, StrEncoding) + +instance Encoding EncDataBytes where + smpEncode (EncDataBytes s) = smpEncode (Large s) + {-# INLINE smpEncode #-} + smpP = EncDataBytes . unLarge <$> smpP + {-# INLINE smpP #-} + +instance ToField EncDataBytes where + toField (EncDataBytes s) = toField (Binary s) + {-# INLINE toField #-} + +data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show) + instance StrEncoding SubscriptionMode where strEncode = \case SMSubscribe -> "subscribe" @@ -449,6 +523,20 @@ instance Encoding SubscriptionMode where 'C' -> pure SMOnlyCreate _ -> fail "bad SubscriptionMode" +instance Encoding QueueReqData where + smpEncode = \case + QRMessaging d -> smpEncode ('M', d) + QRContact d -> smpEncode ('C', d) + smpP = + A.anyChar >>= \case + 'M' -> QRMessaging <$> smpP + 'C' -> QRContact <$> smpP + _ -> fail "bad QueueReqData" + +instance Encoding NewNtfCreds where + smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey) + smpP = NewNtfCreds <$> smpP <*> smpP + type SenderCanSecure = Bool newtype EncTransmission = EncTransmission ByteString @@ -474,6 +562,7 @@ newtype EncFwdTransmission = EncFwdTransmission ByteString data BrokerMsg where -- SMP broker messages (responses, client messages, notifications) IDS :: QueueIdsKeys -> BrokerMsg + LNK :: SenderId -> QueueLinkData -> BrokerMsg -- MSG v1/2 has to be supported for encoding/decoding -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg @@ -679,6 +768,8 @@ data CommandTag (p :: Party) where NEW_ :: CommandTag Recipient SUB_ :: CommandTag Recipient KEY_ :: CommandTag Recipient + LSET_ :: CommandTag Recipient + LDEL_ :: CommandTag Recipient NKEY_ :: CommandTag Recipient NDEL_ :: CommandTag Recipient GET_ :: CommandTag Recipient @@ -689,6 +780,8 @@ data CommandTag (p :: Party) where SKEY_ :: CommandTag Sender SEND_ :: CommandTag Sender PING_ :: CommandTag Sender + LKEY_ :: CommandTag LinkClient + LGET_ :: CommandTag LinkClient PRXY_ :: CommandTag ProxiedClient PFWD_ :: CommandTag ProxiedClient RFWD_ :: CommandTag Sender @@ -702,6 +795,7 @@ deriving instance Show CmdTag data BrokerMsgTag = IDS_ + | LNK_ | MSG_ | NID_ | NMSG_ @@ -729,6 +823,8 @@ instance PartyI p => Encoding (CommandTag p) where NEW_ -> "NEW" SUB_ -> "SUB" KEY_ -> "KEY" + LSET_ -> "LSET" + LDEL_ -> "LDEL" NKEY_ -> "NKEY" NDEL_ -> "NDEL" GET_ -> "GET" @@ -739,6 +835,8 @@ instance PartyI p => Encoding (CommandTag p) where SKEY_ -> "SKEY" SEND_ -> "SEND" PING_ -> "PING" + LKEY_ -> "LKEY" + LGET_ -> "LGET" PRXY_ -> "PRXY" PFWD_ -> "PFWD" RFWD_ -> "RFWD" @@ -750,6 +848,8 @@ instance ProtocolMsgTag CmdTag where "NEW" -> Just $ CT SRecipient NEW_ "SUB" -> Just $ CT SRecipient SUB_ "KEY" -> Just $ CT SRecipient KEY_ + "LSET" -> Just $ CT SRecipient LSET_ + "LDEL" -> Just $ CT SRecipient LDEL_ "NKEY" -> Just $ CT SRecipient NKEY_ "NDEL" -> Just $ CT SRecipient NDEL_ "GET" -> Just $ CT SRecipient GET_ @@ -760,6 +860,8 @@ instance ProtocolMsgTag CmdTag where "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ + "LKEY" -> Just $ CT SLinkClient LKEY_ + "LGET" -> Just $ CT SLinkClient LGET_ "PRXY" -> Just $ CT SProxiedClient PRXY_ "PFWD" -> Just $ CT SProxiedClient PFWD_ "RFWD" -> Just $ CT SSender RFWD_ @@ -776,6 +878,7 @@ instance PartyI p => ProtocolMsgTag (CommandTag p) where instance Encoding BrokerMsgTag where smpEncode = \case IDS_ -> "IDS" + LNK_ -> "LNK" MSG_ -> "MSG" NID_ -> "NID" NMSG_ -> "NMSG" @@ -793,6 +896,7 @@ instance Encoding BrokerMsgTag where instance ProtocolMsgTag BrokerMsgTag where decodeTag = \case "IDS" -> Just IDS_ + "LNK" -> Just LNK_ "MSG" -> Just MSG_ "NID" -> Just NID_ "NMSG" -> Just NMSG_ @@ -1138,10 +1242,19 @@ data QueueIdsKeys = QIK { rcvId :: RecipientId, sndId :: SenderId, rcvPublicDhKey :: RcvPublicDhKey, - sndSecure :: SenderCanSecure + queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion) + linkId :: Maybe LinkId, + serverNtfCreds :: Maybe ServerNtfCreds } deriving (Eq, Show) +data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey + deriving (Eq, Show) + +instance Encoding ServerNtfCreds where + smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey) + smpP = ServerNtfCreds <$> smpP <*> smpP + -- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. @@ -1368,14 +1481,17 @@ 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 sndSecure - | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure) + NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds} + | v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds) + | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData)) | otherwise -> new <> auth <> e subMode where new = e (NEW_, ' ', rKey, dhKey) auth = maybe "" (e . ('A',)) auth_ SUB -> e SUB_ KEY k -> e (KEY_, ' ', k) + LSET lnkId d -> e (LSET_, ' ', lnkId, d) + LDEL -> e LDEL_ NKEY k dhKey -> e (NKEY_, ' ', k, dhKey) NDEL -> e NDEL_ GET -> e GET_ @@ -1387,6 +1503,8 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg) PING -> e PING_ NSUB -> e NSUB_ + LKEY k -> e (LKEY_, ' ', k) + LGET -> e LGET_ PRXY host auth_ -> e (PRXY_, ' ', host, auth_) PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s) RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s) @@ -1409,15 +1527,10 @@ 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 + LGET -> entityCmd PING -> noAuthCmd PRXY {} -> noAuthCmd - PFWD {} - | B.null entId -> Left $ CMD NO_ENTITY - | isNothing auth -> Right cmd - | otherwise -> Left $ CMD HAS_AUTH + PFWD {} -> entityCmd RFWD _ -> noAuthCmd -- other client commands must have both signature and queue ID _ @@ -1429,6 +1542,11 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where noAuthCmd | isNothing auth && B.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH + entityCmd :: Either ErrorType (Command p) + entityCmd + | B.null entId = Left $ CMD NO_ENTITY + | isNothing auth = Right cmd + | otherwise = Left $ CMD HAS_AUTH instance ProtocolEncoding SMPVersion ErrorType Cmd where type Tag Cmd = CmdTag @@ -1438,13 +1556,24 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP - | otherwise -> new <*> auth <*> smpP <*> pure False + | v >= shortLinksSMPVersion -> NEW <$> new smpP smpP smpP + | v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP) (pure Nothing) + | otherwise -> NEW <$> new auth (pure Nothing) (pure Nothing) where - new = NEW <$> _smpP <*> smpP + new p1 p2 p3 = do + rcvAuthKey <- _smpP + rcvDhKey <- smpP + auth_ <- p1 + subMode <- smpP + queueReqData <- p2 + ntfCreds <- p3 + pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds} auth = optional (A.char 'A' *> smpP) + qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing SUB_ -> pure SUB KEY_ -> KEY <$> _smpP + LSET_ -> LSET <$> _smpP <*> smpP + LDEL_ -> pure LDEL NKEY_ -> NKEY <$> _smpP <*> smpP NDEL_ -> pure NDEL GET_ -> pure GET @@ -1458,6 +1587,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) + CT SLinkClient tag -> + Cmd SLinkClient <$> case tag of + LKEY_ -> LKEY <$> _smpP + LGET_ -> pure LGET CT SProxiedClient tag -> Cmd SProxiedClient <$> case tag of PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP) @@ -1472,11 +1605,13 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where type Tag BrokerMsg = BrokerMsgTag encodeProtocol v = \case - IDS (QIK rcvId sndId srvDh sndSecure) - | v >= sndAuthKeySMPVersion -> ids <> e sndSecure + IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serverNtfCreds} + | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId <> e serverNtfCreds + | v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode) | otherwise -> ids where ids = e (IDS_, ' ', rcvId, sndId, srvDh) + LNK sId d -> e (LNK_, ' ', sId, d) MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -> e (MSG_, ' ', msgId, Tail body) NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh) @@ -1505,10 +1640,14 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where where bodyP = EncRcvMsgBody . unTail <$> smpP IDS_ - | v >= sndAuthKeySMPVersion -> ids smpP - | otherwise -> ids $ pure False + | v >= shortLinksSMPVersion -> ids smpP smpP smpP + | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing + | otherwise -> ids nothing nothing nothing where - ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p) + qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact + nothing = pure Nothing + ids p1 p2 p3 = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p1 <*> p2 <*> p3) + LNK_ -> LNK <$> _smpP <*> smpP 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 e422fef84..f6589d176 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -849,8 +849,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt q <- liftIO $ getQueueRec st SSender sId liftIO $ hPutStrLn h $ case q of Left e -> "error: " <> show e - Right (_, QueueRec {sndSecure, status, updatedAt}) -> - "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure + Right (_, QueueRec {queueMode, status, updatedAt}) -> + "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", queueMode: " <> show queueMode CPBlock sId info -> withUserRole $ unliftIO u $ do AMS _ _ (st :: s) <- asks msgStore r <- liftIO $ runExceptT $ do @@ -1060,13 +1060,15 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient (NEW NewQueueReq {rcvAuthKey = k}) -> pure $ Nothing `verifiedWith` k Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey (snd q)) <$> get SRecipient - -- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command - Cmd SSender (SKEY k) -> verifyQueue (\q -> if maybe True (k ==) (senderKey $ snd q) then Just q `verifiedWith` k else dummyVerify) <$> get SSender - Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey $ snd q)) <$> get SSender + Cmd SSender (SKEY k) -> verifySecure SSender k + -- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command + Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing + Cmd SLinkClient (LKEY k) -> verifySecure SLinkClient k + Cmd SLinkClient LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SLinkClient -- NSUB will not be accepted without authorization Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier Cmd SProxiedClient _ -> pure $ VRVerified Nothing @@ -1075,9 +1077,16 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s) -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s verifyQueue = either (const dummyVerify) - verified q cond = if cond then VRVerified q else VRFailed + verifySecure :: DirectParty p => SParty p -> SndPublicAuthKey -> M (VerificationResult s) + verifySecure p k = verifyQueue (\q -> if k `allowedKey` snd q then Just q `verifiedWith` k else dummyVerify) <$> get p verifiedWith :: Maybe (StoreQueue s, QueueRec) -> C.APublicAuthKey -> VerificationResult s - verifiedWith q k = q `verified` verify k + verifiedWith q_ k = if verify k then VRVerified q_ else VRFailed + allowedKey k = \case + QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey + _ -> False + isContact = \case + QueueRec {queueMode = Just QMContact} -> True + _ -> False get :: DirectParty p => SParty p -> M (Either ErrorType (StoreQueue s, QueueRec)) get party = liftIO $ getQueueRec ms party queueId @@ -1233,84 +1242,106 @@ client processCommand clntVersion (q_, (corrId, entId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command) Cmd SSender command -> Just <$> case command of - SKEY sKey -> - withQueue $ \q QueueRec {sndSecure} -> - (corrId,entId,) <$> if sndSecure then secureQueue_ q sKey else pure $ ERR AUTH + SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody PING -> pure (corrId, NoEntity, PONG) RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock + Cmd SLinkClient command -> Just <$> case command of + LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr + LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr Cmd SNotifier NSUB -> Just <$> subscribeNotifications Cmd SRecipient command -> Just <$> case command of - NEW rKey dhKey auth subMode sndSecure -> - ifM - allowNew - (createQueue rKey dhKey subMode sndSecure) - (pure (corrId, entId, ERR AUTH)) + -- TODO [short links] idempotent NEW + NEW nqr@NewQueueReq {auth_} -> + ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH)) where allowNew = do ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config - pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth + pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth SUB -> withQueue subscribeQueue GET -> withQueue getMessage ACK msgId -> withQueue $ acknowledgeMsg msgId - KEY sKey -> withQueue $ \q _ -> (corrId,entId,) <$> secureQueue_ q sKey + KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey + LSET lnkId d -> + withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ + OK <$$ addQueueLinkData (queueStore ms) q lnkId d + LDEL -> + withQueue $ \q _ -> liftIO $ (corrId,entId,) . either ERR (const OK) <$> + deleteQueueLinkData (queueStore ms) q NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_ DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_ QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr where - createQueue :: RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) - createQueue recipientKey dhKey subMode sndSecure = time "NEW" $ do - (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random + createQueue :: NewQueueReq -> M (Transmission BrokerMsg) + createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds} = time "NEW" $ do + g <- asks random + idSize <- asks $ queueIdBytes . config updatedAt <- Just <$> liftIO getSystemDate - let rcvDhSecret = C.dh' dhKey privDhKey - qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} - qRec senderId = - QueueRec - { senderId, - recipientKey, - rcvDhSecret, - senderKey = Nothing, - notifier = Nothing, - status = EntityActive, - sndSecure, - updatedAt - } - (corrId,entId,) <$> addQueueRetry 3 qik qRec - where - addQueueRetry :: - Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> (SenderId -> QueueRec) -> M BrokerMsg - addQueueRetry 0 _ _ = pure $ ERR INTERNAL - addQueueRetry n qik qRec = do - ids@(rId, sId) <- getIds - let qr = qRec sId - liftIO (addQueue ms rId qr) >>= \case - Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec - Left e -> pure $ ERR e - Right q -> do - stats <- asks serverStats - incStat $ qCreated stats - incStat $ qCount stats - case subMode of - SMOnlyCreate -> pure () - SMSubscribe -> void $ subscribeQueue q qr - pure $ IDS (qik ids) + (rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g + ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do + (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g + pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey) + let randId = EntityId <$> atomically (C.randomBytes idSize g) + tryCreate 0 = pure $ ERR INTERNAL + tryCreate n = do + (sndId, clntIds, queueData) <- case queueReqData of + Just (QRMessaging (Just (sId, d))) -> (\linkId -> (sId, True, Just (linkId, d))) <$> randId + Just (QRContact (Just (linkId, (sId, d)))) -> pure (sId, True, Just (linkId, d)) + _ -> (,False,Nothing) <$> randId + -- The condition that client-provided sender ID must match hash of correlation ID + -- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check + -- if queue with this ID still exists. + if clntIds && unEntityId sndId /= C.sha3_256 (bs corrId) + then pure $ ERR $ CMD PROHIBITED + else do + rcvId <- randId + ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do + notifierId <- randId + pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey) + let queueMode = queueReqMode <$> queueReqData + qr = + QueueRec + { senderId = sndId, + recipientKey = rcvAuthKey, + rcvDhSecret = C.dh' rcvDhKey privDhKey, + senderKey = Nothing, + queueMode, + queueData, + notifier = fst <$> ntf, + status = EntityActive, + updatedAt + } + liftIO (addQueue ms rcvId qr) >>= \case + Left DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied? + | clntIds -> pure $ ERR AUTH -- no retry on collision if sender ID is client-supplied + | otherwise -> tryCreate (n - 1) + Left e -> pure $ ERR e + Right q -> do + stats <- asks serverStats + incStat $ qCreated stats + incStat $ qCount stats + when (isJust ntf) $ incStat $ ntfCreated stats + case subMode of + SMOnlyCreate -> pure () + SMSubscribe -> void $ subscribeQueue q qr + pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serverNtfCreds = snd <$> ntf} + (corrId,entId,) <$> tryCreate (3 :: Int) - getIds :: M (RecipientId, SenderId) - getIds = do - n <- asks $ queueIdBytes . config - liftM2 (,) (randomId n) (randomId n) + checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) + checkMode qm QueueRec {queueMode} a = + (corrId,entId,) . either ERR id + <$> if queueMode == Just qm then a else pure $ Left AUTH - secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M BrokerMsg + secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M (Either ErrorType BrokerMsg) secureQueue_ q sKey = do - liftIO (secureQueue (queueStore ms) q sKey) >>= \case - Left e -> pure $ ERR e - Right () -> do - stats <- asks serverStats - incStat $ qSecured stats - pure OK + liftIO (secureQueue (queueStore ms) q sKey) + $>> (asks serverStats >>= incStat . qSecured) $> Right OK + + getQueueLink_ :: StoreQueue s -> QueueRec -> M (Either ErrorType BrokerMsg) + getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do @@ -1617,7 +1648,7 @@ client pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta} processForwardedCommand :: EncFwdTransmission -> M BrokerMsg - processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do + processForwardedCommand (EncFwdTransmission s) = fmap (either ERR RRES) . runExceptT $ do THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams') sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret' let proxyNonce = C.cbNonce $ bs corrId @@ -1652,7 +1683,7 @@ client r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) stats <- asks serverStats incStat $ pMsgFwdsRecv stats - pure $ RRES r3 + pure r3 where rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe (StoreQueue s, QueueRec), Transmission Cmd)) rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) = @@ -1665,6 +1696,8 @@ client allowed = case cmd' of Cmd SSender SEND {} -> True Cmd SSender (SKEY _) -> True + Cmd SLinkClient (LKEY _) -> True + Cmd SLinkClient LGET -> True _ -> False verified = \case VRVerified q -> Right (q, (corrId', entId', cmd')) @@ -1720,12 +1753,12 @@ client getQueueInfo :: StoreQueue s -> QueueRec -> M BrokerMsg getQueueInfo q QueueRec {senderKey, notifier} = do - fmap (either ERR id) $ liftIO $ runExceptT $ do + fmap (either ERR INFO) $ liftIO $ runExceptT $ do qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub qiSize <- getQueueSize ms q qiMsg <- toMsgInfo <$$> tryPeekMsg ms q let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} - pure $ INFO info + pure info where mkQSub Sub {subThread, delivered} = do qSubThread <- case subThread of @@ -1787,7 +1820,7 @@ exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () exportMessages tty ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f liftIO $ withFile f WriteMode $ \h -> - tryAny (unsafeWithAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case + tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case Right (Sum total) -> logInfo $ "messages saved: " <> tshow total Left e -> do logError $ "error exporting messages: " <> tshow e @@ -1824,7 +1857,7 @@ processServerMessages StartOptions {skipWarnings} = do run processValidateQueue | otherwise = logWarn "skipping message expiration" $> Nothing where - run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure + run a = unsafeWithAllMsgQueues False False ms a `catchAny` \_ -> exitFailure processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do mq <- getMsgQueue ms q False diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 83e59243d..9e63c1dbb 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -210,7 +210,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} ps <- newJournalMsgStore $ PQStoreCfg storeCfg sl <- openWriteStoreLog False storeLogFilePath - Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int) + Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int) putStrLn $ "Export completed: " <> show qCnt <> " queues" putStrLn $ case readStoreType ini of Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file." diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 0686a71bf..b48d31743 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -321,6 +321,12 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where {-# INLINE addQueue_ #-} getQueue_ = withQS getQueue_ {-# INLINE getQueue_ #-} + addQueueLinkData = withQS addQueueLinkData + {-# INLINE addQueueLinkData #-} + getQueueLinkData = withQS getQueueLinkData + {-# INLINE getQueueLinkData #-} + deleteQueueLinkData = withQS deleteQueueLinkData + {-# INLINE deleteQueueLinkData #-} secureQueue = withQS secureQueue {-# INLINE secureQueue #-} addQueueNotifier = withQS addQueueNotifier @@ -389,11 +395,11 @@ instance MsgStoreClass (JournalMsgStore s) where -- This function can only be used in server CLI commands or before server is started. -- It does not cache queues and is NOT concurrency safe. - unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of + unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of MQStore st -> withLoadedQueues st run #if defined(dbServerPostgres) - PQStore st -> foldQueueRecs tty st Nothing $ uncurry (mkTempQueue ms) >=> run + PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkTempQueue ms) >=> run #endif where run q = do @@ -413,7 +419,7 @@ instance MsgStoreClass (JournalMsgStore s) where #if defined(dbServerPostgres) PQStore st -> do let JournalMsgStore {queueLocks, sharedLock} = ms - foldQueueRecs tty st (Just veryOld) $ \(rId, qr) -> do + foldQueueRecs tty False st (Just veryOld) $ \(rId, qr) -> do q <- mkTempQueue ms rId qr withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $ getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 6fa94fd03..af8cde941 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -80,7 +80,7 @@ instance MsgStoreClass STMMsgStore where {-# INLINE closeMsgStore #-} withActiveMsgQueues = withLoadedQueues . queueStore_ {-# INLINE withActiveMsgQueues #-} - unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_ + unsafeWithAllMsgQueues _ _ = withLoadedQueues . queueStore_ {-# INLINE unsafeWithAllMsgQueues #-} expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 01dfdb88c..3bf857e6d 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -37,7 +37,8 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M closeMsgStore :: s -> IO () withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a -- This function can only be used in server CLI commands or before server is started. - unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a + -- tty, withData, store + unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> s -> (StoreQueue s -> IO a) -> IO a -- tty, store, now, ttl expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats logQueueStates :: s -> IO () diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index f4c2f108e..d2492fe43 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -25,14 +25,15 @@ import Simplex.Messaging.Util (eitherToMaybe) #endif data QueueRec = QueueRec - { recipientKey :: !RcvPublicAuthKey, - rcvDhSecret :: !RcvDhSecret, - senderId :: !SenderId, - senderKey :: !(Maybe SndPublicAuthKey), - sndSecure :: !SenderCanSecure, - notifier :: !(Maybe NtfCreds), - status :: !ServerEntityStatus, - updatedAt :: !(Maybe RoundedSystemTime) + { recipientKey :: RcvPublicAuthKey, + rcvDhSecret :: RcvDhSecret, + senderId :: SenderId, + senderKey :: Maybe SndPublicAuthKey, + queueMode :: Maybe QueueMode, + queueData :: Maybe (LinkId, QueueLinkData), + notifier :: Maybe NtfCreds, + status :: ServerEntityStatus, + updatedAt :: Maybe RoundedSystemTime } deriving (Show) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 93d6e8213..454e54c12 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -35,7 +35,6 @@ import Control.Monad.Trans.Except import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Bitraversable (bimapM) import Data.Either (fromRight) @@ -43,10 +42,10 @@ import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intersperse) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError) +import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) import qualified Database.PostgreSQL.Simple as DB import qualified Database.PostgreSQL.Simple.Copy as DB import Database.PostgreSQL.Simple.FromField (FromField (..)) @@ -146,10 +145,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where >>= bimapM handleDuplicate pure atomically $ TM.insert rId sq queues atomically $ TM.insert (senderId qr) rId senders + forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr pure sq where - PostgresQueueStore {queues, senders} = st + PostgresQueueStore {queues, senders, notifiers} = st -- Not doing duplicate checks in maps as the probability of duplicates is very low. -- It needs to be reconsidered when IDs are supplied by the users. -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier] @@ -160,12 +160,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where SRecipient -> getRcvQueue qId SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue + SLinkClient -> loadLinkQueue where PostgresQueueStore {queues, senders, notifiers} = st getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right) loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure () loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare + loadLinkQueue = loadQueue " WHERE link_id = ?" $ \_ -> pure () loadQueue condition insertRef = E.uninterruptibleMask_ $ runExceptT $ do (rId, qRec) <- @@ -187,6 +189,43 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where TM.insert rId sq queues pure sq + getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData) + getQueueLinkData st sq lnkId = runExceptT $ do + qr <- ExceptT $ readQueueRecIO $ queueRec sq + case queueData qr of + Just (lnkId', _) | lnkId' == lnkId -> + withDB "getQueueLinkData" st $ \db -> firstRow id AUTH $ + DB.query db "SELECT fixed_data, user_data FROM msg_queues WHERE link_id = ? AND deleted_at IS NULL" (Only lnkId) + _ -> throwE AUTH + + addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) + addQueueLinkData st sq lnkId d = + withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of + Nothing -> + addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId)) + Just (lnkId', _) | lnkId' == lnkId -> + addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data != ?)") (d :. (lnkId, rId, fst d)) + _ -> throwE AUTH + where + rId = recipientId sq + addLink q update = do + assertUpdated $ withDB' "addQueueLinkData" st update + atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just (lnkId, d)} + withLog "addQueueLinkData" st $ \s -> logCreateLink s rId lnkId d + qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL" + + deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) + deleteQueueLinkData st sq = + withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of + Just _ -> do + assertUpdated $ withDB' "deleteQueueLinkData" st $ \db -> + DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId) + atomically $ writeTVar (queueRec sq) $ Just q {queueData = Nothing} + withLog "deleteQueueLinkData" st (`logDeleteLink` rId) + _ -> throwE AUTH + where + rId = recipientId sq + secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = withQueueRec sq "secureQueue" $ \q -> do @@ -320,15 +359,15 @@ insertQueueQuery :: Query insertQueueQuery = [sql| INSERT INTO msg_queues - (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?) + (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] -foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a -foldQueueRecs tty st skipOld_ f = do +foldQueueRecs :: forall a q. Monoid a => Bool -> Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a +foldQueueRecs tty withData st skipOld_ f = do (n, r) <- withConnection (dbStore st) $ \db -> - foldRecs db (0 :: Int, mempty) $ \(i, acc) row -> do - r <- f $ rowToQueueRec row + foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do + r <- f qr let !i' = i + 1 !acc' = acc <> r when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout @@ -336,29 +375,49 @@ foldQueueRecs tty st skipOld_ f = do when tty $ putStrLn $ progress n pure r where - foldRecs db = case skipOld_ of - Nothing -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") - Just old -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) + foldRecs db acc f' = case skipOld_ of + Nothing + | withData -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData + | otherwise -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec + Just old + | withData -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData + | otherwise -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec + query = if withData then queueRecQueryWithData else queueRecQuery progress i = "Processed: " <> show i <> " records" queueRecQuery :: Query queueRecQuery = [sql| SELECT recipient_id, recipient_key, rcv_dh_secret, - sender_id, sender_key, snd_secure, + sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, - status, updated_at + status, updated_at, + link_id FROM msg_queues |] -type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime) +queueRecQueryWithData :: Query +queueRecQueryWithData = + [sql| + SELECT recipient_id, recipient_key, rcv_dh_secret, + sender_id, sender_key, queue_mode, + notifier_id, notifier_key, rcv_ntf_dh_secret, + status, updated_at, + link_id, fixed_data, user_data + FROM msg_queues + |] -queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow -queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) = - (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt) +type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId) + +queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) +queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = + (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_) + :. (fst <$> queueData_, snd <$> queueData_) + where + (linkId_, queueData_) = queueDataColumns queueData queueRecToText :: (RecipientId, QueueRec) -> ByteString -queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) = +queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n' where tabFields = BB.char7 ',' `intersperse` fields @@ -368,13 +427,17 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s renderField (toField rcvDhSecret), renderField (toField senderId), nullable senderKey, - renderField (toField sndSecure), + nullable queueMode, nullable (notifierId <$> n), nullable (notifierKey <$> n), nullable (rcvNtfDhSecret <$> n), BB.char7 '"' <> renderField (toField status) <> BB.char7 '"', - nullable updatedAt + nullable updatedAt, + nullable linkId_, + nullable (fst <$> queueData_), + nullable (snd <$> queueData_) ] + (linkId_, queueData_) = queueDataColumns queueData nullable :: ToField a => Maybe a -> Builder nullable = maybe mempty (renderField . toField) renderField :: Action -> Builder @@ -385,10 +448,23 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s EscapeIdentifier s -> BB.byteString s -- Not used in COPY data Many as -> mconcat (map renderField as) +queueDataColumns :: Maybe (LinkId, QueueLinkData) -> (Maybe LinkId, Maybe QueueLinkData) +queueDataColumns = \case + Just (linkId, linkData) -> (Just linkId, Just linkData) + Nothing -> (Nothing, Nothing) + rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) -rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) = +rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) + queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_ + in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) + +rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec) +rowToQueueRecWithData ((rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) = + let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ + encData = fromMaybe (EncDataBytes "") + queueData = (,(encData immutableData_, encData userData_)) <$> linkId_ + in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) setStatusDB op st sq status writeLog = @@ -441,4 +517,8 @@ instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder str instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey + +instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s) + +deriving newtype instance FromField EncDataBytes #endif diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs index a5b69b94b..9d0973976 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -12,7 +12,8 @@ import Text.RawString.QQ (r) serverSchemaMigrations :: [(String, Text, Maybe Text)] serverSchemaMigrations = [ ("20250207_initial", m20250207_initial, Nothing), - ("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index) + ("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index), + ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links) ] -- | The list of migrations in ascending order by date @@ -61,3 +62,37 @@ down_m20250319_updated_index = DROP INDEX idx_msg_queues_updated_at; CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at); |] + +m20250320_short_links :: Text +m20250320_short_links = + T.pack + [r| +ALTER TABLE msg_queues + ADD COLUMN queue_mode TEXT, + ADD COLUMN link_id BYTEA, + ADD COLUMN fixed_data BYTEA, + ADD COLUMN user_data BYTEA; + +UPDATE msg_queues SET queue_mode = 'M' WHERE snd_secure IS TRUE; + +ALTER TABLE msg_queues DROP COLUMN snd_secure; + +CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id); + |] + +down_m20250320_short_links :: Text +down_m20250320_short_links = + T.pack + [r| +ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE; + +UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M'; + +ALTER TABLE + DROP COLUMN queue_mode, + DROP COLUMN link_id, + DROP COLUMN fixed_data, + DROP COLUMN user_data; + +DROP INDEX idx_msg_queues_link_id; + |] diff --git a/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs index b329a54ff..dbb716c53 100644 --- a/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs +++ b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Messaging.Server.QueueStore.QueueInfo where @@ -12,6 +15,14 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Util ((<$?>)) +#if defined(dbServerPostgres) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) +import Simplex.Messaging.Util (eitherToMaybe) +#endif + data QueueInfo = QueueInfo { qiSnd :: Bool, qiNtf :: Bool, @@ -40,6 +51,24 @@ data MsgInfo = MsgInfo data MsgType = MTMessage | MTQuota deriving (Eq, Show) +data QueueMode = QMMessaging | QMContact deriving (Eq, Show) + +instance Encoding QueueMode where + smpEncode = \case + QMMessaging -> "M" + QMContact -> "C" + smpP = + A.anyChar >>= \case + 'M' -> pure QMMessaging + 'C' -> pure QMContact + _ -> fail "bad QueueMode" + +#if defined(dbServerPostgres) +instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 + +instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode +#endif + $(JQ.deriveJSON (enumJSON $ dropPrefix "Q") ''QSubThread) $(JQ.deriveJSON defaultJSON ''QSub) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 8a360c3a0..5638312c6 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -44,6 +44,7 @@ data STMQueueStore q = STMQueueStore { queues :: TMap RecipientId q, senders :: TMap SenderId RecipientId, notifiers :: TMap NotifierId RecipientId, + links :: TMap LinkId RecipientId, storeLog :: TVar (Maybe (StoreLog 'WriteMode)) } @@ -58,8 +59,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where queues <- TM.emptyIO senders <- TM.emptyIO notifiers <- TM.emptyIO + links <- TM.emptyIO storeLog <- newTVarIO Nothing - pure STMQueueStore {queues, senders, notifiers, storeLog} + pure STMQueueStore {queues, senders, notifiers, links, storeLog} closeQueueStore :: STMQueueStore q -> IO () closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do @@ -80,17 +82,19 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where pure QueueCounts {queueCount, notifierCount} addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) - addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier} = do + addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do sq <- mkQ rId qr add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq where - STMQueueStore {queues, senders, notifiers} = st + STMQueueStore {queues, senders, notifiers, links} = st add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do TM.insert rId q queues TM.insert sId rId senders forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers - hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier] + forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links + hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink] hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier + hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData getQueue_ :: DirectParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) getQueue_ st _ party qId = @@ -98,8 +102,44 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where SRecipient -> TM.lookupIO qId queues SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) + SLinkClient -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues) where - STMQueueStore {queues, senders, notifiers} = st + STMQueueStore {queues, senders, notifiers, links} = st + + getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData) + getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData + where + getData qr = case queueData qr of + Just (lnkId', d) | lnkId' == lnkId -> Right d + _ -> Left AUTH + + addQueueLinkData :: STMQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) + addQueueLinkData st sq lnkId d = + atomically (readQueueRec qr $>>= add) + $>> withLog "addQueueLinkData" st (\s -> logCreateLink s rId lnkId d) + where + rId = recipientId sq + qr = queueRec sq + add q = case queueData q of + Nothing -> addLink + Just (lnkId', d') | lnkId' == lnkId && fst d' == fst d -> addLink + _ -> pure $ Left AUTH + where + addLink = do + let !q' = q {queueData = Just (lnkId, d)} + writeTVar qr $ Just q' + TM.insert lnkId rId $ links st + pure $ Right () + + deleteQueueLinkData :: STMQueueStore q -> q -> IO (Either ErrorType ()) + deleteQueueLinkData st sq = + withQueueRec qr delete + $>> withLog "deleteQueueLinkData" st (`logDeleteLink` recipientId sq) + where + qr = queueRec sq + delete q = forM (queueData q) $ \(lnkId, _) -> do + TM.delete lnkId $ links st + writeTVar qr $ Just q {queueData = Nothing} secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 8af65a335..73c098a68 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -30,6 +30,9 @@ class StoreQueueClass q => QueueStoreClass q s where compactQueues :: s -> IO Int64 addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData) + addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) + deleteQueueLinkData :: s -> q -> IO (Either ErrorType ()) secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId)) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 1cc8ebd6c..5ed894d9e 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -18,6 +18,8 @@ module Simplex.Messaging.Server.StoreLog closeStoreLog, writeStoreLogRecord, logCreateQueue, + logCreateLink, + logDeleteLink, logSecureQueue, logAddNotifier, logSuspendQueue, @@ -37,6 +39,7 @@ import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (sort, stripPrefix) @@ -45,6 +48,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol -- import Simplex.Messaging.Server.MsgStore.Types @@ -57,6 +61,8 @@ import System.FilePath (takeDirectory, takeFileName) data StoreLogRecord = CreateQueue RecipientId QueueRec + | CreateLink RecipientId LinkId QueueLinkData + | DeleteLink RecipientId | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId @@ -69,6 +75,8 @@ data StoreLogRecord data SLRTag = CreateQueue_ + | CreateLink_ + | DeleteLink_ | SecureQueue_ | AddNotifier_ | SuspendQueue_ @@ -79,21 +87,22 @@ data SLRTag | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = + strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} = B.unwords [ "rk=" <> strEncode recipientKey, "rdh=" <> strEncode rcvDhSecret, "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey ] - <> sndSecureStr - <> maybe "" notifierStr notifier - <> maybe "" updatedAtStr updatedAt + <> maybe "" ((" queue_mode=" <>) . smpEncode) queueMode + <> opt " link_id=" (fst <$> queueData) + <> opt " queue_data=" (snd <$> queueData) + <> opt " notifier=" notifier + <> opt " updated_at=" updatedAt <> statusStr where - sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else "" - notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds - updatedAtStr t = " updated_at=" <> strEncode t + opt :: StrEncoding a => ByteString -> Maybe a -> ByteString + opt param = maybe "" ((param <>) . strEncode) statusStr = case status of EntityActive -> "" _ -> " status=" <> strEncode status @@ -103,15 +112,23 @@ instance StrEncoding QueueRec where rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP - sndSecure <- (" sndSecure=" *> strP) <|> pure False + queueMode <- + toQueueMode <$> (" sndSecure=" *> strP) + <|> Just <$> (" queue_mode=" *> smpP) + <|> pure Nothing -- unknown queue mode, we cannot imply that it is contact address + queueData <- optional $ (,) <$> (" link_id" *> strP) <*> (" queue_data" *> strP) notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP status <- (" status=" *> strP) <|> pure EntityActive - pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} + pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} + where + toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact instance StrEncoding SLRTag where strEncode = \case CreateQueue_ -> "CREATE" + CreateLink_ -> "CREATE_LINK" + DeleteLink_ -> "DELETE_LINK" SecureQueue_ -> "SECURE" AddNotifier_ -> "NOTIFIER" SuspendQueue_ -> "SUSPEND" @@ -124,6 +141,8 @@ instance StrEncoding SLRTag where strP = A.choice [ "CREATE" $> CreateQueue_, + "CREATE_LINK" $> CreateLink_, + "DELETE_LINK" $> DeleteLink_, "SECURE" $> SecureQueue_, "NOTIFIER" $> AddNotifier_, "SUSPEND" $> SuspendQueue_, @@ -137,6 +156,8 @@ instance StrEncoding SLRTag where instance StrEncoding StoreLogRecord where strEncode = \case CreateQueue rId q -> B.unwords [strEncode CreateQueue_, "rid=" <> strEncode rId, strEncode q] + CreateLink rId lnkId d -> strEncode (CreateLink_, rId, lnkId, d) + DeleteLink rId -> strEncode (DeleteLink_, rId) SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) @@ -149,6 +170,8 @@ instance StrEncoding StoreLogRecord where strP = strP_ >>= \case CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP + CreateLink_ -> CreateLink <$> strP_ <*> strP_ <*> strP + DeleteLink_ -> DeleteLink <$> strP SecureQueue_ -> SecureQueue <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP @@ -189,6 +212,12 @@ writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO () logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q +logCreateLink :: StoreLog 'WriteMode -> RecipientId -> LinkId -> QueueLinkData -> IO () +logCreateLink s rId lnkId d = writeStoreLogRecord s $ CreateLink rId lnkId d + +logDeleteLink :: StoreLog 'WriteMode -> RecipientId -> IO () +logDeleteLink s = writeStoreLogRecord s . DeleteLink + logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index fd4da85ab..d03bf55df 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -16,7 +16,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol +import Simplex.Messaging.Protocol (ErrorType, RecipientId, SParty (..)) import Simplex.Messaging.Server.QueueStore (QueueRec) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog @@ -42,6 +42,8 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine procLogRecord :: StoreLogRecord -> IO () procLogRecord = \case CreateQueue rId qr -> addQueue_ st mkQ rId qr >>= qError rId "CreateQueue" + CreateLink rId lnkId d -> withQueue rId "CreateLink" $ \q -> addQueueLinkData st q lnkId d + DeleteLink rId -> withQueue rId "DeleteLink" $ \q -> deleteQueueLinkData st q SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 67cb83d01..0480f28f9 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -52,6 +52,7 @@ module Simplex.Messaging.Transport deletedEventSMPVersion, encryptedBlockSMPVersion, blockedEntitySMPVersion, + shortLinksSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -147,6 +148,7 @@ smpBlockSize = 16384 -- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024) -- 12 - BLOCKED error for blocked queues (1/11/2025) -- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025) +-- 15 - short links, include creating NTF credentials in NEW command data SMPVersion @@ -183,6 +185,9 @@ blockedEntitySMPVersion = VersionSMP 12 proxyServerHandshakeSMPVersion :: VersionSMP proxyServerHandshakeSMPVersion = VersionSMP 14 +shortLinksSMPVersion :: VersionSMP +shortLinksSMPVersion = VersionSMP 15 + minClientSMPRelayVersion :: VersionSMP minClientSMPRelayVersion = VersionSMP 6 @@ -190,13 +195,13 @@ minServerSMPRelayVersion :: VersionSMP minServerSMPRelayVersion = VersionSMP 6 currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 14 +currentClientSMPRelayVersion = VersionSMP 15 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 14 +currentServerSMPRelayVersion = VersionSMP 15 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. @@ -204,7 +209,7 @@ currentServerSMPRelayVersion = VersionSMP 14 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 14 +proxiedSMPRelayVersion = VersionSMP 15 -- minimal supported protocol version is 6 -- TODO remove code that supports sending commands without batching diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index a9a64e5c7..0b261672a 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -6,7 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module AgentTests (agentTests) where +module AgentTests (agentCoreTests, agentTests) where import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) @@ -14,6 +14,7 @@ import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) import AgentTests.NotificationTests (notificationTests) import AgentTests.ServerChoice (serverChoiceTests) +import AgentTests.ShortLinkTests (shortLinkTests) import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec @@ -24,11 +25,15 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) import AgentTests.SQLiteTests (storeTests) #endif -agentTests :: (ATransport, AStoreType) -> Spec -agentTests ps = do +agentCoreTests :: Spec +agentCoreTests = do describe "Migration tests" migrationTests describe "Connection request" connectionRequestTests describe "Double ratchet tests" doubleRatchetTests + describe "Short link tests" shortLinkTests + +agentTests :: (ATransport, AStoreType) -> Spec +agentTests ps = do #if defined(dbPostgres) after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do #else diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 14f19efc3..5ac090b8b 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -12,6 +12,8 @@ module AgentTests.ConnectionRequestTests connReqData, queueAddr, testE2ERatchetParams12, + contactConnRequest, + invConnRequest, ) where import Data.ByteString (ByteString) @@ -146,7 +148,10 @@ testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing connectionRequest :: AConnectionRequestUri -connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams +connectionRequest = ACR SCMInvitation invConnRequest + +invConnRequest :: ConnectionRequestUri 'CMInvitation +invConnRequest = CRInvitationUri connReqData testE2ERatchetParams connectionRequestSK :: AConnectionRequestUri connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams @@ -164,7 +169,10 @@ connectionRequestNew1 :: AConnectionRequestUri connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams contactAddress :: AConnectionRequestUri -contactAddress = ACR SCMContact $ CRContactUri connReqData +contactAddress = ACR SCMContact $ contactConnRequest + +contactConnRequest :: ConnectionRequestUri 'CMContact +contactConnRequest = CRContactUri connReqData contactAddressV2 :: AConnectionRequestUri contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2 diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index a810247fe..14ad526a5 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -6,6 +6,7 @@ module AgentTests.EqInstances where import Data.Type.Equality import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Client (ProxiedRelay (..)) instance Eq SomeConn where @@ -25,6 +26,12 @@ deriving instance Eq (DBQueueId q) deriving instance Eq ClientNtfCreds +deriving instance Eq ShortLinkCreds + +deriving instance Eq ContactConnType + +deriving instance Eq (ConnShortLink m) + deriving instance Show ProxiedRelay deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index cbe1c47bc..869f3ef6f 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -55,11 +55,12 @@ module AgentTests.FunctionalAPITests where import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams12) +import AgentTests.EqInstances () import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad import Control.Monad.Except import Control.Monad.Reader -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -249,8 +250,9 @@ inAnyOrder g rs = withFrozenCallStack $ do expected :: a -> (a -> Bool) -> Bool expected r rp = rp r -createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c) -createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn) +createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c) +createConnection c userId enableNtfs cMode clientData = + fmap (second fst) . A.createConnection c userId enableNtfs cMode Nothing clientData (IKNoPQ PQSupportOn) joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured) joinConnection c userId enableNtfs cReq connInfo subMode = do @@ -306,6 +308,9 @@ functionalAPITests ps = do testAsyncServerOffline ps it "should restore confirmation after client restart" $ testAllowConnectionClientRestart ps + describe "Short connection links" $ do + it "create and get 1-time short link" $ testInviationShortLink ps + it "create and get contact short link" $ testContactShortLink ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -607,7 +612,7 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe + (bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured @@ -809,7 +814,7 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe + (_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection @@ -853,7 +858,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do - (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe + (_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo sentMessages abPQEnc alice bobId bob bAliceId (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo @@ -906,7 +911,7 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () testRejectContactRequest :: HasCallStack => IO () testRejectContactRequest = withAgentClients2 $ \alice bob -> runRight_ $ do - (addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe + (addrConnId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection @@ -1073,6 +1078,42 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do disposeAgentClient alice2 disposeAgentClient bob +testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () +testInviationShortLink ps = + withAgentClients3 $ \a b c -> withSmpServer ps $ do + let userData = "some user data" + (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + -- same user can get invitation link again + (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + connReq2 `shouldBe` connReq + userData2 `shouldBe` userData + -- another user cannot get the same invitation link + runExceptT (getConnShortLink c 1 shortLink) >>= \case + Left (SMP _ AUTH) -> pure () + r -> liftIO $ expectationFailure ("unexpected result " <> show r) + +testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () +testContactShortLink ps = + withAgentClients3 $ \a b c -> withSmpServer ps $ do + let userData = "some user data" + (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + -- same user can get contact link again + (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + connReq2 `shouldBe` connReq + userData2 `shouldBe` userData + -- another user can get the same contact link + (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + connReq3 `shouldBe` connReq + userData3 `shouldBe` userData + testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB @@ -1760,7 +1801,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do - (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe + (bobId, (qInfo, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (CR.IKNoPQ pqSupport) SMSubscribe aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 5ead81613..7be9ac465 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -227,6 +227,7 @@ rcvQueue1 = e2eDhSecret = Nothing, sndId = EntityId "2345", sndSecure = True, + shortLink = Nothing, status = New, dbQueueId = DBNewQueue, primary = True, @@ -439,6 +440,7 @@ testUpgradeSndConnToDuplex = e2eDhSecret = Nothing, sndId = EntityId "4567", sndSecure = True, + shortLink = Nothing, status = New, dbQueueId = DBNewQueue, rcvSwchStatus = Nothing, diff --git a/tests/AgentTests/ShortLinkTests.hs b/tests/AgentTests/ShortLinkTests.hs new file mode 100644 index 000000000..d46ab6135 --- /dev/null +++ b/tests/AgentTests/ShortLinkTests.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module AgentTests.ShortLinkTests (shortLinkTests) where + +import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) +import Control.Concurrent.STM +import Simplex.Messaging.Agent.Protocol (supportedSMPAgentVRange) +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.ShortLink as SL +import Test.Hspec + +-- TODO [short tests] tests failures +shortLinkTests :: Spec +shortLinkTests = do + it "should encrypt and decrypt invitation short link data" testInvShortLink + it "should encrypt and decrypt contact short link data" testContactShortLink + +testInvShortLink :: IO () +testInvShortLink = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData + k = SL.invShortLinkKdf linkKey + srvData <- SL.encryptLinkData g k linkData + -- decrypt + Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + connReq `shouldBe` invConnRequest + userData' `shouldBe` userData + +testContactShortLink :: IO () +testContactShortLink = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData + (_linkId, k) = SL.contactShortLinkKdf linkKey + srvData <- SL.encryptLinkData g k linkData + -- decrypt + Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + connReq `shouldBe` contactConnRequest + userData' `shouldBe` userData diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 1f9cbf777..2c76b051c 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -39,6 +39,7 @@ import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) @@ -109,8 +110,8 @@ deriving instance Eq (JournalState t) deriving instance Eq (SJournalType t) -testNewQueueRec :: TVar ChaChaDRG -> Bool -> IO (RecipientId, QueueRec) -testNewQueueRec g sndSecure = do +testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec) +testNewQueueRec g qm = do rId <- atomically $ EntityId <$> C.randomBytes 24 g senderId <- atomically $ EntityId <$> C.randomBytes 24 g (recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g @@ -121,7 +122,8 @@ testNewQueueRec g sndSecure = do rcvDhSecret = C.dh' k pk, senderId, senderKey = Nothing, - sndSecure, + queueMode = Just qm, + queueData = Nothing, notifier = Nothing, status = EntityActive, updatedAt = Nothing @@ -132,7 +134,7 @@ testNewQueueRec g sndSecure = do testGetQueue :: MsgStoreClass s => s -> IO () testGetQueue ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging runRight_ $ do q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s @@ -175,7 +177,7 @@ testGetQueue ms = do testChangeReadJournal :: MsgStoreClass s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging runRight_ $ do q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s @@ -194,8 +196,8 @@ testChangeReadJournal ms = do testExportImportStore :: JournalMsgStore 'QSMemory -> IO () testExportImportStore ms = do g <- C.newRandom - (rId1, qr1) <- testNewQueueRec g True - (rId2, qr2) <- testNewQueueRec g True + (rId1, qr1) <- testNewQueueRec g QMMessaging + (rId2, qr2) <- testNewQueueRec g QMMessaging sl <- readWriteQueueStore True (mkQueue ms) testStoreLogFile $ queueStore ms runRight_ $ do let write q s = writeMsg ms q True =<< mkMessage s @@ -302,7 +304,7 @@ testQueueState ms = do testMessageState :: JournalMsgStore s -> IO () testMessageState ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) write q s = writeMsg ms q True =<< mkMessage s @@ -327,7 +329,7 @@ testMessageState ms = do testRemoveJournals :: JournalMsgStore s -> IO () testRemoveJournals ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) write q s = writeMsg ms q True =<< mkMessage s @@ -393,7 +395,7 @@ testRemoveJournals ms = do testRemoveQueueStateBackups :: IO () testRemoveQueueStateBackups = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0} -- set expiration time 1 second ahead @@ -429,7 +431,7 @@ testRemoveQueueStateBackups = do testExpireIdleQueues :: IO () testExpireIdleQueues = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0} @@ -462,7 +464,7 @@ testExpireIdleQueues = do testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging let write q s = writeMsg ms q True =<< mkMessage s q <- runRight $ do q <- ExceptT $ addQueue ms rId qr @@ -486,7 +488,7 @@ testReadFileMissing ms = do testReadFileMissingSwitch :: JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue q) @@ -504,7 +506,7 @@ testReadFileMissingSwitch ms = do testWriteFileMissing :: JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue q) @@ -527,7 +529,7 @@ testWriteFileMissing ms = do testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom - (rId, qr) <- testNewQueueRec g True + (rId, qr) <- testNewQueueRec g QMMessaging q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue q) diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index d871f5b0a..0f3d22f38 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -52,14 +52,15 @@ deriving instance Eq StoreLogRecord deriving instance Eq NtfCreds +-- TODO [short links] test store log with queue data storeLogTests :: Spec storeLogTests = - forM_ [False, True] $ \sndSecure -> do + forM_ [QMMessaging, QMContact] $ \qm -> do ((rId, qr), ntfCreds, date) <- runIO $ do g <- C.newRandom - (,,) <$> testNewQueueRec g sndSecure <*> testNtfCreds g <*> getSystemDate + (,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate testSMPStoreLog - ("SMP server store log, sndSecure = " <> show sndSecure) + ("SMP server store log, queueMode = " <> show qm) [ SLTC { name = "create new queue", saved = [CreateQueue rId qr], diff --git a/tests/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 5b66bb844..4433d2a4d 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -198,6 +198,7 @@ dummyRQ userId server connId rcvId = e2eDhSecret = Nothing, sndId = NoEntity, sndSecure = True, + shortLink = Nothing, status = New, dbQueueId = DBQueueId 0, primary = True, diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 25e2943ef..50c94f2fb 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -48,7 +49,8 @@ import UnliftIO.STM ntfServerTests :: ATransport -> Spec ntfServerTests t = do describe "Notifications server protocol syntax" $ ntfSyntaxTests t - describe "Notification subscriptions" $ testNotificationSubscription t + describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY + describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW ntfSyntaxTests :: ATransport -> Spec ntfSyntaxTests (ATransport t) = do @@ -93,10 +95,9 @@ v .-> key = let J.Object o = v in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o -testNotificationSubscription :: ATransport -> Spec -testNotificationSubscription (ATransport t) = - -- hangs on Ubuntu 20/22 - xit' "should create notification subscription and notify when message is received" $ do +testNotificationSubscription :: ATransport -> CreateQueueFunc -> Spec +testNotificationSubscription (ATransport t) createQueue = + it "should create notification subscription and notify when message is received" $ do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -106,8 +107,7 @@ testNotificationSubscription (ATransport t) = withAPNSMockServer $ \apns -> smpTest2' t $ \rh sh -> ntfTest t $ \nh -> do - -- create queue - (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub + ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) <- createQueue rh sPub nPub -- register and verify token RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- @@ -118,12 +118,9 @@ testNotificationSubscription (ATransport t) = Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code) RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK) - -- enable queue notifications - (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g - Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey) + -- ntf server subscribes to queue notifications let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash q = SMPQueueNtf srv nId - rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey) -- send message threadDelay 50000 @@ -169,3 +166,36 @@ testNotificationSubscription (ATransport t) = PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2 smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId + +type CreateQueueFunc = + forall c. + Transport c => + THandleSMP c 'TClient -> + SndPublicAuthKey -> + NtfPublicAuthKey -> + IO ((SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret), NotifierId, C.DhSecret 'C.X25519) + +createNtfQueueNKEY :: CreateQueueFunc +createNtfQueueNKEY h sPub nPub = do + g <- C.newRandom + (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue h sPub + -- enable queue notifications + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g + Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv h rKey ("3", rId, NKEY nPub rcvNtfPubDhKey) + let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey + pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) + +createNtfQueueNEW :: CreateQueueFunc +createNtfQueueNEW h sPub nPub = do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g + let cmd = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) (Just (NewNtfCreds nPub rcvNtfPubDhKey))) + Resp "abcd" NoEntity (IDS (QIK rId sId srvDh _sndSecure _linkId (Just (ServerNtfCreds nId rcvNtfSrvPubDhKey)))) <- + signSendRecv h rKey ("abcd", NoEntity, cmd) + let dhShared = C.dh' srvDh dhPriv + Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) + (rId', rId) #== "same queue ID" + let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey + pure ((sId, rId, rKey, dhShared), nId, rcvNtfDhSecret) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 4be81aedc..f67564865 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -36,7 +36,7 @@ import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity) +import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, QueueReqData (..), RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SQSType (..)) @@ -53,6 +53,7 @@ import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif +-- TODO [short links] secure and get links via proxy smpProxyTests :: SpecWith AStoreType smpProxyTests = do describe "server configuration" $ do @@ -177,7 +178,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 - SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False + SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") @@ -224,7 +225,7 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty 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 + (bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True @@ -280,7 +281,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = -- agent connections have to be set up in advance -- otherwise the CONF messages would get mixed with MSG prePair alice bob = do - (bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (bobId, (qInfo, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True @@ -331,7 +332,7 @@ agentViaProxyVersionError = withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do - (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (_bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () @@ -351,7 +352,7 @@ agentViaProxyRetryOffline = do let pqEnc = CR.PQEncOn withServer $ \_ -> do (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do - (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 824338452..d7e692ea4 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -80,12 +80,18 @@ serverTests = do testMsgExpireOnInterval testMsgNOTExpireOnInterval describe "Blocking queues" $ testBlockMessageQueue + describe "Short links" $ do + testInvQueueLinkData + testContactQueueLinkData pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) +pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Recipient +pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing) + pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg -pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure) +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId _srvNtfCreds) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} @@ -146,7 +152,7 @@ testCreateSecure = 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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, NoEntity) #== "creates queue" @@ -211,7 +217,7 @@ testCreateSndSecure = 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", NoEntity, NEW rPub dhPub Nothing SMSubscribe True) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, NoEntity) #== "creates queue" @@ -225,8 +231,8 @@ testCreateSndSecure = Resp "dabc" sId2 OK <- signSendRecv s sKey ("dabc", sId, SKEY sPub) (sId2, sId) #== "secures queue, same queue ID in response" - (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g - Resp "abcd" _ err4 <- signSendRecv s sKey ("abcd", sId, SKEY sPub') + (sPub', sKey') <- atomically $ C.generateAuthKeyPair C.SEd448 g + Resp "abcd" _ err4 <- signSendRecv s sKey' ("abcd", sId, SKEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" Resp "abcd" _ OK <- signSendRecv s sKey ("abcd", sId, SKEY sPub) @@ -258,7 +264,7 @@ testSndSecureProhibited = 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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing)) (rId1, NoEntity) #== "creates queue" (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g @@ -273,7 +279,7 @@ testCreateDelete = 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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, NoEntity) #== "creates queue" @@ -345,7 +351,7 @@ stressTest = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, New rPub dhPub) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -363,7 +369,7 @@ testAllowNewQueues = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub) pure () testDuplex :: SpecWith (ATransport, AStoreType) @@ -373,7 +379,7 @@ testDuplex = 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", NoEntity, NEW arPub aDhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", NoEntity, New arPub aDhPub) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -389,7 +395,7 @@ testDuplex = (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", NoEntity, NEW brPub bDhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, New brPub bDhPub) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode (unEntityId bSnd)) -- "reply_id ..." is ad-hoc, not a part of SMP protocol @@ -428,7 +434,7 @@ testSwitchSub = 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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -849,7 +855,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" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -884,7 +890,7 @@ testTiming = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -1032,7 +1038,7 @@ testBlockMessageQueue = (rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True) + Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub) (rId1, NoEntity) #== "creates queue" pure (rId, sId) @@ -1050,6 +1056,91 @@ testBlockMessageQueue = killThread server pure a +testInvQueueLinkData :: SpecWith (ATransport, AStoreType) +testInvQueueLinkData = + it "create and access queue short link data for 1-time invitation" $ \(ATransport t, msType) -> + smpTest2 t msType $ \r s -> do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + C.CbNonce corrId <- atomically $ C.randomCbNonce g + let sId = EntityId $ C.sha3_256 corrId + ld = (EncDataBytes "fixed data", EncDataBytes "user data") + qrd = QRMessaging $ Just (sId, ld) + -- sender ID must be derived from corrId + Resp "1" NoEntity (ERR (CMD PROHIBITED)) <- + signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing)) <- + signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + (sId', sId) #== "should return the same sender ID" + corrId' `shouldBe` CorrId corrId + -- can't read link data with LGET + Resp "2" lnkId' (ERR AUTH) <- sendRecv s ("", "2", lnkId, LGET) + lnkId' `shouldBe` lnkId + + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + + Resp "3a" _ err2 <- sendRecv s ("", "3a", lnkId, LKEY sPub) + (err2, ERR (CMD NO_AUTH)) #== "rejects LKEY without signature" + + Resp "3b" _ err2' <- sendRecv s (sampleSig, "3b", lnkId, LKEY sPub) + (err2', ERR AUTH) #== "rejects LKEY with wrong signature" + + Resp "4" _ err3 <- signSendRecv s sKey ("4", rId, LKEY sPub) + (err3, ERR AUTH) #== "rejects LKEY with recipients's ID" + + Resp "5" lnkId2 (LNK sId2 ld') <- signSendRecv s sKey ("5", lnkId, LKEY sPub) + (lnkId2, lnkId) #== "secures queue and returns link data, same link ID in response" + (sId2, sId) #== "same sender ID in response" + (ld', ld) #== "returns stored data" + + (sPub', sKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g + Resp "6" _ err4 <- signSendRecv s sKey' ("6", lnkId, LKEY sPub') + (err4, ERR AUTH) #== "rejects if secured with different key" + + Resp "7" _ (LNK sId3 ld2) <- signSendRecv s sKey ("7", lnkId, LKEY sPub) + sId3 `shouldBe` sId + ld2 `shouldBe` ld + +testContactQueueLinkData :: SpecWith (ATransport, AStoreType) +testContactQueueLinkData = + it "create and access queue short link data for contact address" $ \(ATransport t, msType) -> + smpTest2 t msType $ \r s -> do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + C.CbNonce corrId <- atomically $ C.randomCbNonce g + lnkId <- EntityId <$> atomically (C.randomBytes 24 g) + let sId = EntityId $ C.sha3_256 corrId + ld = (EncDataBytes "fixed data", EncDataBytes "user data") + qrd = QRContact $ Just (lnkId, (sId, ld)) + -- sender ID must be derived from corrId + Resp "1" NoEntity (ERR (CMD PROHIBITED)) <- + signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing)) <- + signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + (lnkId', lnkId) #== "should return the same link ID" + (sId', sId) #== "should return the same sender ID" + corrId' `shouldBe` CorrId corrId + -- can't secure queue and read link data with LKEY + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + Resp "2" _ (ERR AUTH) <- signSendRecv s sKey ("2", lnkId, LKEY sPub) + + Resp "3" _ err2 <- sendRecv s (sampleSig, "3", lnkId, LGET) + (err2, ERR (CMD HAS_AUTH)) #== "rejects LGET with signature" + + Resp "4" _ err3 <- sendRecv s ("", "4", rId, LGET) + (err3, ERR AUTH) #== "rejects LGET with recipients's ID" + + Resp "5" lnkId2 (LNK sId2 ld') <- sendRecv s ("", "5", lnkId, LGET) + (lnkId2, lnkId) #== "returns link data, same link ID in response" + (sId2, sId) #== "same sender ID in response" + (ld', ld) #== "returns stored data" + + Resp "6" _ (LNK sId3 ld2) <- sendRecv s ("", "6", lnkId, LGET) + sId3 `shouldBe` sId + ld2 `shouldBe` ld + samplePubKey :: C.APublicVerifyKey samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY=" @@ -1075,8 +1166,8 @@ serverSyntaxTests (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, '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) + it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "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/Test.hs b/tests/Test.hs index 14007eed8..1e29fa158 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} -import AgentTests (agentTests) +import AgentTests (agentCoreTests, agentTests) import CLITests import Control.Concurrent (threadDelay) import qualified Control.Exception as E @@ -83,10 +83,10 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests + describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) aroundAll_ (postgressBracket testServerDBConnectInfo) - $ describe "SMP server via TLS, postgres+jornal message store" $ do - describe "SMP syntax" $ serverSyntaxTests (transport @TLS) + $ describe "SMP server via TLS, postgres+jornal message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests #endif describe "SMP server via TLS, jornal message store" $ do From c1a6647f19787e9a60754604efb67ec305e2a35c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 29 Mar 2025 09:42:56 +0000 Subject: [PATCH 02/15] agent: join connection when 1-time invitation short link is already secured (#1496) * agent: join connection when 1-time invitation short link is already secured * do not pass short link to join * delete short link record after connection --- src/Simplex/Messaging/Agent.hs | 108 ++++++++++-------- src/Simplex/Messaging/Agent/Protocol.hs | 4 +- src/Simplex/Messaging/Agent/Store.hs | 3 +- .../Messaging/Agent/Store/AgentStore.hs | 52 +++++++-- .../Migrations/M20250322_short_links.hs | 1 + .../Migrations/M20250322_short_links.hs | 1 + .../Store/SQLite/Migrations/agent_schema.sql | 1 + src/Simplex/Messaging/Client.hs | 1 + src/Simplex/Messaging/Protocol.hs | 14 +-- src/Simplex/Messaging/Server.hs | 11 +- .../Messaging/Server/QueueStore/Postgres.hs | 12 +- .../Messaging/Server/QueueStore/STM.hs | 2 +- tests/AgentTests/FunctionalAPITests.hs | 51 ++++++++- 13 files changed, 180 insertions(+), 81 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bc6a02715..c05fcf8f6 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -178,7 +178,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations) import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) -import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) +import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -189,7 +189,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -705,6 +705,8 @@ newConnNoQueues c userId enableNtfs cMode pqSupport = do let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} withStore c $ \db -> createNewConn db g cData cMode +-- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, +-- and join should retry, the same as 1-time invitation joins. joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do withInvLock c (strEncode cReqUri) "joinConnAsync" $ do @@ -805,6 +807,7 @@ newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact) setConnShortLink' = undefined +-- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) getConnShortLink' c userId = \case CSLInvitation srv linkId linkKey -> do @@ -814,23 +817,24 @@ getConnShortLink' c userId = \case Just sl@InvShortLink {linkKey = lk} | linkKey == lk -> pure sl _ -> do (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey} + let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId = Nothing} createInvShortLink db sl pure sl let k = SL.invShortLinkKdf linkKey - secureGetQueueLink c userId invLink >>= decryptData srv linkKey k + ld@(sndId, _) <- secureGetQueueLink c userId invLink + withStore' c $ \db -> setInvShortLinkSndId db invLink sndId + decryptData srv linkKey k ld CSLContact srv _ linkKey -> do let (linkId, k) = SL.contactShortLinkKdf linkKey - getQueueLink c userId srv linkId >>= decryptData srv linkKey k + ld <- getQueueLink c userId srv linkId + decryptData srv linkKey k ld where decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) decryptData srv linkKey k (sndId, d) = do - r <- liftEither $ SL.decryptLinkData @c linkKey k d - checkSameQueue $ case fst r of CRInvitationUri crd _ -> crd; CRContactUri crd -> crd + r@(cReq, _) <- liftEither $ SL.decryptLinkData @c linkKey k d + unless ((srv, sndId) `sameQAddress` qAddress (connReqQueue cReq)) $ + throwE $ AGENT $ A_LINK "different address" pure r - where - checkSameQueue ConnReqUriData {crSmpQueues = SMPQueueUri {queueAddress = SMPQueueAddress srv' sndId' _ _} :| _} = - unless (srv == srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address" delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () delInvShortLink' = undefined @@ -952,52 +956,54 @@ newConnToAccept c connId enableNtfs invId pqSup = do newConnToJoin c userId connId enableNtfs connReq pqSup _ -> throwE $ CMD PROHIBITED "newConnToAccept" --- TODO [short link] joining queue that was already secured with LKEY +-- Short link MUST be passed again to joinConnection so that the same sender key is used. +-- The alternative design would be to create connection ID and SndQueue when short link is read. joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do - srv <- getNextSMPServer c userId [qServer cReqQueue] + srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq] joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv - where - cReqQueue :: SMPQueueUri - cReqQueue = case cReq of - CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q - CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q -startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448) +connReqQueue :: ConnectionRequestUri c -> SMPQueueUri +connReqQueue = \case + CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q + CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q + +startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448, Bool) startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out -- e2ePubKey is always present, it's Maybe historically let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) - (sq', e2eSndParams) <- case sq_ of - Just sq@SndQueue {e2ePubKey = Just _k} -> do - e2eSndParams <- - withStore' c (\db -> getSndRatchet db connId v) >>= \case - Right r -> pure $ snd r - Left e -> do - atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) - createRatchet_ pqSupport e2eRcvParams - pure (sq, e2eSndParams) - _ -> do - q <- lift $ fst <$> newSndQueue userId "" qInfo - e2eSndParams <- createRatchet_ pqSupport e2eRcvParams - withStore c $ \db -> runExceptT $ do - sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ - pure (sq', e2eSndParams) + g <- asks random + maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - pure (cData, sq', e2eSndParams) + case sq_ of + Just sq@SndQueue {e2ePubKey = Just _k} -> do + e2eSndParams <- withStore c $ \db -> + getSndRatchet db connId v >>= \case + Right r -> pure $ Right $ snd r + Left e -> do + nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) + runExceptT $ createRatchet_ db g maxSupported pqSupport e2eRcvParams + pure (cData, sq, e2eSndParams, False) + _ -> do + let Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {smpServer, senderId}} = qInfo + sndKeys_ <- withStore' c $ \db -> getInvShortLinkKeys db smpServer senderId + (q, _) <- lift $ newSndQueue userId "" qInfo sndKeys_ + withStore c $ \db -> runExceptT $ do + e2eSndParams <- createRatchet_ db g maxSupported pqSupport e2eRcvParams + sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ + pure (cData, sq', e2eSndParams, isJust sndKeys_) Nothing -> throwE $ AGENT A_VERSION where - createRatchet_ pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do - g <- asks random + createRatchet_ db g maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) (_, rcDHRs) <- atomically $ C.generateKeyPair g - rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams - maxSupported <- asks $ maxVersion . e2eEncryptVRange . config + rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - withStore' c $ \db -> createSndRatchet db connId rc e2eSndParams + liftIO $ createSndRatchet db connId rc e2eSndParams pure e2eSndParams connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) @@ -1042,8 +1048,9 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup + (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode + >>= (when hasLink (delInvSL c connId srv sq) $>) joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do @@ -1052,6 +1059,11 @@ joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMo pure False Nothing -> throwE $ AGENT A_VERSION +delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SndQueue -> AM () +delInvSL c connId srv sq = + withStore' c (\db -> deleteInvShortLink db (protoServer srv) (queueId sq)) `catchE` \e -> + liftIO $ nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e)) + joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do SomeConn cType conn <- withStore c (`getConn` connId) @@ -1062,8 +1074,9 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport + (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode + >>= (when hasLink (delInvSL c connId srv sq) $>) joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" @@ -2861,7 +2874,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do - (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo + (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo Nothing sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} @@ -3053,7 +3066,7 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _ enqueueConfirmation c cData sq' ownConnInfo Nothing where upgradeConn = do - (sq, _) <- lift $ newSndQueue userId connId qInfo' + (sq, _) <- lift $ newSndQueue userId connId qInfo' Nothing withStore c $ \db -> upgradeRcvConnToDuplex db connId sq secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured @@ -3175,11 +3188,11 @@ 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, C.PublicKeyX25519) -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> Maybe (C.AAuthKeyPair) -> AM' (NewSndQueue, C.PublicKeyX25519) +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) sndKeys_ = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random - (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g + (sndPublicKey, sndPrivateKey) <- maybe (atomically $ C.generateAuthKeyPair a g) pure sndKeys_ (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g let sq = SndQueue @@ -3192,7 +3205,8 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd sndPrivateKey, e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, e2ePubKey = Just e2ePubKey, - status = New, + -- setting status to Secured prevents SKEY when queue was already secured with LKEY + status = if isJust sndKeys_ then Secured else New, dbQueueId = DBNewQueue, primary = True, dbReplaceQueueId = Nothing, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index a7640fe0f..e596b3e5d 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1302,7 +1302,9 @@ data ContactConnType = CCTContact | CCTGroup deriving (Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) -- TODO [short link] parser, parsing tests -data AConnectionLink = ACLFull AConnectionRequestUri | ACLShort AConnShortLink +data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m) + +data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m) instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 7375ed41b..a04422780 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -155,7 +155,8 @@ data InvShortLink = InvShortLink linkId :: SMP.LinkId, linkKey :: LinkKey, sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries - sndPublicKey :: SndPublicAuthKey + sndPublicKey :: SndPublicAuthKey, + sndId :: Maybe SMP.SenderId } deriving (Show) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index f19b02af1..9548b296c 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -90,7 +90,10 @@ module Simplex.Messaging.Agent.Store.AgentStore unacceptInvitation, deleteInvitation, getInvShortLink, + getInvShortLinkKeys, + deleteInvShortLink, createInvShortLink, + setInvShortLinkSndId, -- Messages updateRcvIds, createRcvMsg, @@ -768,33 +771,64 @@ getInvShortLink db server linkId = DB.query db [sql| - SELECT link_key, snd_private_key + SELECT link_key, snd_private_key, snd_id FROM inv_short_links WHERE host = ? AND port = ? AND link_id = ? |] (host server, port server, linkId) where - toInvShortLink :: (LinkKey, C.APrivateAuthKey) -> InvShortLink - toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk)) = + toInvShortLink :: (LinkKey, C.APrivateAuthKey, Maybe SenderId) -> InvShortLink + toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk), sndId) = let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk - in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey} + in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId} + +getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe C.AAuthKeyPair) +getInvShortLinkKeys db srv sndId = + maybeFirstRow toSndKeys $ + DB.query + db + [sql| + SELECT snd_private_key + FROM inv_short_links + WHERE host = ? AND port = ? AND snd_id = ? + |] + (host srv, port srv, sndId) + where + toSndKeys :: Only C.APrivateAuthKey -> C.AAuthKeyPair + toSndKeys (Only privKey@(C.APrivateAuthKey a pk)) = (C.APublicAuthKey a $ C.publicKey pk, privKey) + +deleteInvShortLink :: DB.Connection -> SMPServer -> SenderId -> IO () +deleteInvShortLink db srv sndId = + DB.execute db "DELETE FROM inv_short_links WHERE host = ? AND port = ? AND snd_id = ?" (host srv, port srv, sndId) createInvShortLink :: DB.Connection -> InvShortLink -> IO () -createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey} = do +createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId} = do serverKeyHash_ <- createServer_ db server DB.execute db [sql| INSERT INTO inv_short_links - (host, port, server_key_hash, link_id, link_key, snd_private_key) - VALUES (?,?,?,?,?,?) + (host, port, server_key_hash, link_id, link_key, snd_private_key, snd_id) + VALUES (?,?,?,?,?,?,?) ON CONFLICT (host, port, link_id) DO UPDATE SET server_key_hash = EXCLUDED.server_key_hash, link_key = EXCLUDED.link_key, - snd_private_key = EXCLUDED.snd_private_key + snd_private_key = EXCLUDED.snd_private_key, + snd_id = EXCLUDED.snd_id |] - (host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey) + (host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey, sndId) + +setInvShortLinkSndId :: DB.Connection -> InvShortLink -> SenderId -> IO () +setInvShortLinkSndId db InvShortLink {server, linkId} sndId = + DB.execute + db + [sql| + UPDATE inv_short_links + SET snd_id = ? + WHERE host = ? AND port = ? AND link_id = ? + |] + (sndId, host server, port server, linkId) updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds db connId = do diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs index 4948eac82..774ad50d6 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs @@ -25,6 +25,7 @@ CREATE TABLE inv_short_links( link_id BYTEA NOT NULL, link_key BYTEA NOT NULL, snd_private_key BYTEA NOT NULL, + snd_id BYTEA, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs index b79ce24e0..70a15b8cc 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs @@ -23,6 +23,7 @@ CREATE TABLE inv_short_links( link_id BLOB NOT NULL, link_key BLOB NOT NULL, snd_private_key BLOB NOT NULL, + snd_id BLOB, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); 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 89d1d271a..5db250ad0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -434,6 +434,7 @@ CREATE TABLE inv_short_links( link_id BLOB NOT NULL, link_key BLOB NOT NULL, snd_private_key BLOB NOT NULL, + snd_id BLOB, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 4aebc107e..5352658b2 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -107,6 +107,7 @@ module Simplex.Messaging.Client TBQueueInfo (..), getTBQueueInfo, getProtocolClientQueuesInfo, + nonBlockingWriteTBQueue, ) where diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index dfe596cf6..6ae012027 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -302,14 +302,14 @@ data SParty :: Party -> Type where SRecipient :: SParty Recipient SSender :: SParty Sender SNotifier :: SParty Notifier - SLinkClient :: SParty LinkClient + SSenderLink :: SParty LinkClient SProxiedClient :: SParty ProxiedClient instance TestEquality SParty where testEquality SRecipient SRecipient = Just Refl testEquality SSender SSender = Just Refl testEquality SNotifier SNotifier = Just Refl - testEquality SLinkClient SLinkClient = Just Refl + testEquality SSenderLink SSenderLink = Just Refl testEquality SProxiedClient SProxiedClient = Just Refl testEquality _ _ = Nothing @@ -323,7 +323,7 @@ instance PartyI Sender where sParty = SSender instance PartyI Notifier where sParty = SNotifier -instance PartyI LinkClient where sParty = SLinkClient +instance PartyI LinkClient where sParty = SSenderLink instance PartyI ProxiedClient where sParty = SProxiedClient @@ -860,8 +860,8 @@ instance ProtocolMsgTag CmdTag where "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ - "LKEY" -> Just $ CT SLinkClient LKEY_ - "LGET" -> Just $ CT SLinkClient LGET_ + "LKEY" -> Just $ CT SSenderLink LKEY_ + "LGET" -> Just $ CT SSenderLink LGET_ "PRXY" -> Just $ CT SProxiedClient PRXY_ "PFWD" -> Just $ CT SProxiedClient PFWD_ "RFWD" -> Just $ CT SSender RFWD_ @@ -1587,8 +1587,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) - CT SLinkClient tag -> - Cmd SLinkClient <$> case tag of + CT SSenderLink tag -> + Cmd SSenderLink <$> case tag of LKEY_ -> LKEY <$> _smpP LGET_ -> pure LGET CT SProxiedClient tag -> diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 199f202fd..1aa6b0d64 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1068,8 +1068,8 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing - Cmd SLinkClient (LKEY k) -> verifySecure SLinkClient k - Cmd SLinkClient LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SLinkClient + Cmd SSenderLink (LKEY k) -> verifySecure SSenderLink k + Cmd SSenderLink LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink -- NSUB will not be accepted without authorization Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier Cmd SProxiedClient _ -> pure $ VRVerified Nothing @@ -1247,13 +1247,12 @@ client SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody PING -> pure (corrId, NoEntity, PONG) RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock - Cmd SLinkClient command -> Just <$> case command of + Cmd SSenderLink command -> Just <$> case command of LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr Cmd SNotifier NSUB -> Just <$> subscribeNotifications Cmd SRecipient command -> Just <$> case command of - -- TODO [short links] idempotent NEW NEW nqr@NewQueueReq {auth_} -> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH)) where @@ -1698,8 +1697,8 @@ client allowed = case cmd' of Cmd SSender SEND {} -> True Cmd SSender (SKEY _) -> True - Cmd SLinkClient (LKEY _) -> True - Cmd SLinkClient LGET -> True + Cmd SSenderLink (LKEY _) -> True + Cmd SSenderLink LGET -> True _ -> False verified = \case VRVerified q -> Right (q, (corrId', entId', cmd')) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 89464938d..5de63d367 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -84,6 +84,7 @@ data PostgresQueueStore q = PostgresQueueStore queues :: TMap RecipientId q, -- this map only cashes the queues that were attempted to send messages to, senders :: TMap SenderId RecipientId, + links :: TMap LinkId RecipientId, -- this map only cashes the queues that were attempted to be subscribed to, notifiers :: TMap NotifierId RecipientId, notifierLocks :: TMap NotifierId Lock, @@ -99,9 +100,10 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath queues <- TM.emptyIO senders <- TM.emptyIO + links <- TM.emptyIO notifiers <- TM.emptyIO notifierLocks <- TM.emptyIO - pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, notifiers, notifierLocks, deletedTTL} + pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, deletedTTL} where err e = do logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e @@ -146,10 +148,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where atomically $ TM.insert rId sq queues atomically $ TM.insert (senderId qr) rId senders forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers + forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr pure sq where - PostgresQueueStore {queues, senders, notifiers} = st + PostgresQueueStore {queues, senders, links, notifiers} = st -- Not doing duplicate checks in maps as the probability of duplicates is very low. -- It needs to be reconsidered when IDs are supplied by the users. -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier] @@ -159,12 +162,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where getQueue_ st mkQ party qId = case party of SRecipient -> getRcvQueue qId SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue - -- TODO [short links] use map of link IDs - queue will be added there on creation in case there is data - SLinkClient -> mask loadLinkQueue + SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>)) where - PostgresQueueStore {queues, senders, notifiers} = st + PostgresQueueStore {queues, senders, links, notifiers} = st getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right) loadRcvQueue = do (rId, qRec) <- loadQueue " WHERE recipient_id = ?" diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index e3efe9309..dcd7fd5a0 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -102,7 +102,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where SRecipient -> TM.lookupIO qId queues SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) - SLinkClient -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues) + SSenderLink -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues) where STMQueueStore {queues, senders, notifiers, links} = st diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 869f3ef6f..63e6e3f49 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -309,8 +309,9 @@ functionalAPITests ps = do it "should restore confirmation after client restart" $ testAllowConnectionClientRestart ps describe "Short connection links" $ do - it "create and get 1-time short link" $ testInviationShortLink ps - it "create and get contact short link" $ testContactShortLink ps + it "should connect via 1-time short link" $ testInviationShortLink ps + it "should connect via 1-time short link with async join" $ testInviationShortLinkAsync ps + it "should connect via contact short link" $ testContactShortLink ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -1082,7 +1083,7 @@ testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1095,12 +1096,41 @@ testInviationShortLink ps = runExceptT (getConnShortLink c 1 shortLink) >>= \case Left (SMP _ AUTH) -> pure () r -> liftIO $ expectationFailure ("unexpected result " <> show r) + runRight $ do + aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn + sndSecure <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure `shouldBe` True + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId + +testInviationShortLinkAsync :: HasCallStack => (ATransport, AStoreType) -> IO () +testInviationShortLinkAsync ps = + withAgentClients2 $ \a b -> withSmpServer ps $ do + let userData = "some user data" + (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + runRight $ do + aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe + get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (_contactId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1113,6 +1143,19 @@ testContactShortLink ps = (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq userData3 `shouldBe` userData + runRight $ do + (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe + liftIO $ sndSecure `shouldBe` False + ("", _, REQ invId _ "bob's connInfo") <- get a + bId <- A.prepareConnectionToAccept a True invId PQSupportOn + sndSecure' <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure' `shouldBe` True + ("", _, CONF confId _ "alice's connInfo") <- get b + allowConnection b aId confId "bob's connInfo" + get a ##> ("", bId, INFO "bob's connInfo") + get a ##> ("", bId, CON) + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do From 04cbed90fb9d98f38544ffb5a3a61fe260aa69e5 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 30 Mar 2025 11:17:25 +0100 Subject: [PATCH 03/15] agent: set/update and delete contact short link data (#1499) * agent: set/update and delete contact short link data * delete contact link data, tests * comments * type signature for GHC 8.10.7 --- src/Simplex/Messaging/Agent.hs | 115 ++++++++++++------ src/Simplex/Messaging/Agent/Client.hs | 22 +--- .../Messaging/Agent/Store/AgentStore.hs | 26 ++-- src/Simplex/Messaging/Crypto/ShortLink.hs | 20 ++- src/Simplex/Messaging/Server.hs | 10 +- .../Messaging/Server/QueueStore/Postgres.hs | 2 +- tests/AgentTests/FunctionalAPITests.hs | 56 ++++++++- tests/ServerTests.hs | 28 +++++ 8 files changed, 202 insertions(+), 77 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index c05fcf8f6..2cedf5fbd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -56,7 +56,10 @@ module Simplex.Messaging.Agent deleteConnectionAsync, deleteConnectionsAsync, createConnection, + setContactShortLink, + deleteContactShortLink, getConnShortLink, + deleteLocalInvShortLink, changeConnectionUser, prepareConnectionToJoin, prepareConnectionToAccept, @@ -189,7 +192,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolType (..), ProtocolTypeI (..), QueueLinkData, SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -347,21 +350,23 @@ createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enab {-# INLINE createConnection #-} -- | Create or update user's contact connection short link --- TODO [short links] -setConnShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact) -setConnShortLink c = withAgentEnv c .: setConnShortLink' c -{-# INLINE setConnShortLink #-} +setContactShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact) +setContactShortLink c = withAgentEnv c .: setContactShortLink' c +{-# INLINE setContactShortLink #-} + +deleteContactShortLink :: AgentClient -> ConnId -> AE () +deleteContactShortLink c = withAgentEnv c . deleteContactShortLink' c +{-# INLINE deleteContactShortLink #-} -- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo) getConnShortLink c = withAgentEnv c .: getConnShortLink' c {-# INLINE getConnShortLink #-} --- | This irreversible deletes short link data, and it won't be retrievable again --- TODO [short links] -delInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE () -delInvShortLink c = withAgentEnv c . delInvShortLink' c -{-# INLINE delInvShortLink #-} +-- | This irreversibly deletes short link data, and it won't be retrievable again +deleteLocalInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE () +deleteLocalInvShortLink c = withAgentEnv c . deleteLocalInvShortLink' c +{-# INLINE deleteLocalInvShortLink #-} -- | Changes the user id associated with a connection changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE () @@ -801,11 +806,46 @@ newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do srv <- getSMPServer c userId connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) - (connId,) <$> newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv + (connId,) <$> newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv `catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e -setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact) -setConnShortLink' = undefined +setContactShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact) +setContactShortLink' c connId userData = + withConnLock c connId "setContactShortLink" $ + withStore c (`getConn` connId) >>= \case + SomeConn _ (ContactConnection _ rq) -> do + (lnkId, linkKey, d) <- prepareLinkData rq + addQueueLink c rq lnkId d + pure $ CSLContact (qServer rq) CCTContact linkKey + _ -> throwE $ CMD PROHIBITED "setContactShortLink: not contact address" + where + prepareLinkData :: RcvQueue -> AM (SMP.LinkId, LinkKey, QueueLinkData) + prepareLinkData rq@RcvQueue {server, sndId, e2ePrivKey, shortLink} = do + g <- asks random + AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config + case shortLink of + Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} -> do + let (linkId, k) = SL.contactShortLinkKdf shortLinkKey + unless (shortLinkId == linkId) $ throwE $ INTERNAL "setContactShortLink: link ID is not derived from link" + d <- liftIO $ SL.encryptData g k $ SL.encodeSignUserData linkPrivSigKey smpAgentVRange userData + pure (linkId, shortLinkKey, (linkEncFixedData, d)) + Nothing -> do + sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g + let qUri = SMPQueueUri vr $ SMPQueueAddress server sndId (C.publicKey e2ePrivKey) False + connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] Nothing + (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData + (linkId, k) = SL.contactShortLinkKdf linkKey + srvData <- liftIO $ SL.encryptLinkData g k linkData + let slCreds = ShortLinkCreds linkId linkKey privSigKey (fst srvData) + withStore' c $ \db -> updateShortLinkCreds db rq slCreds + pure (linkId, linkKey, srvData) + +deleteContactShortLink' :: AgentClient -> ConnId -> AM () +deleteContactShortLink' c connId = + withConnLock c connId "deleteContactShortLink" $ + withStore c (`getConn` connId) >>= \case + SomeConn _ (ContactConnection _ rq) -> deleteQueueLink c rq + _ -> throwE $ CMD PROHIBITED "deleteContactShortLink: not contact address" -- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) @@ -829,15 +869,15 @@ getConnShortLink' c userId = \case ld <- getQueueLink c userId srv linkId decryptData srv linkKey k ld where - decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) + decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) decryptData srv linkKey k (sndId, d) = do r@(cReq, _) <- liftEither $ SL.decryptLinkData @c linkKey k d unless ((srv, sndId) `sameQAddress` qAddress (connReqQueue cReq)) $ throwE $ AGENT $ A_LINK "different address" pure r -delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () -delInvShortLink' = undefined +deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () +deleteLocalInvShortLink' c (CSLInvitation srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do @@ -849,13 +889,8 @@ changeConnectionUser' c oldUserId connId newUserId = do where updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId -newRcvConnSrv :: ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c) -newRcvConnSrv c userId connId enableNtfs cMode = - fmap fst .:: newRcvConnSrv_ c userId connId enableNtfs cMode Nothing -{-# INLINE newRcvConnSrv #-} - -newRcvConnSrv_ :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) -newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do +newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) +newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () @@ -898,12 +933,12 @@ newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys g <- asks random nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g - AgentConfig {smpClientVRange = vr, smpAgentVRange = agentVRange} <- asks config + AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config let sndId = SMP.EntityId $ C.sha3_256 corrId sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure connReq <- createConnReq qUri - let (linkKey, linkData) = SL.encodeSignLinkData sigKeys agentVRange connReq userData + let (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData qd <- case cMode of SCMContact -> do let (linkId, k) = SL.contactShortLinkKdf linkKey @@ -956,8 +991,6 @@ newConnToAccept c connId enableNtfs invId pqSup = do newConnToJoin c userId connId enableNtfs connReq pqSup _ -> throwE $ CMD PROHIBITED "newConnToAccept" --- Short link MUST be passed again to joinConnection so that the same sender key is used. --- The alternative design would be to create connection ID and SndQueue when short link is read. joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq] @@ -968,7 +1001,7 @@ connReqQueue = \case CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q -startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448, Bool) +startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448, Maybe SMP.LinkId) startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do @@ -986,15 +1019,17 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = Left e -> do nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) runExceptT $ createRatchet_ db g maxSupported pqSupport e2eRcvParams - pure (cData, sq, e2eSndParams, False) + pure (cData, sq, e2eSndParams, Nothing) _ -> do let Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {smpServer, senderId}} = qInfo - sndKeys_ <- withStore' c $ \db -> getInvShortLinkKeys db smpServer senderId + invLink_ <- withStore' c $ \db -> getInvShortLinkKeys db smpServer senderId + let lnkId_ = fst <$> invLink_ + sndKeys_ = snd <$> invLink_ (q, _) <- lift $ newSndQueue userId "" qInfo sndKeys_ withStore c $ \db -> runExceptT $ do e2eSndParams <- createRatchet_ db g maxSupported pqSupport e2eRcvParams sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ - pure (cData, sq', e2eSndParams, isJust sndKeys_) + pure (cData, sq', e2eSndParams, lnkId_) Nothing -> throwE $ AGENT A_VERSION where createRatchet_ db g maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do @@ -1048,20 +1083,20 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup + (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode - >>= (when hasLink (delInvSL c connId srv sq) $>) + >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do - cReq <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv + (cReq, _) <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv void $ sendInvitation c userId connId qInfo vrsn cReq cInfo pure False Nothing -> throwE $ AGENT A_VERSION -delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SndQueue -> AM () -delInvSL c connId srv sq = - withStore' c (\db -> deleteInvShortLink db (protoServer srv) (queueId sq)) `catchE` \e -> +delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SMP.LinkId -> AM () +delInvSL c connId srv lnkId = + withStore' c (\db -> deleteInvShortLink db (protoServer srv) lnkId) `catchE` \e -> liftIO $ nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e)) joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured @@ -1074,9 +1109,9 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport + (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode - >>= (when hasLink (delInvSL c connId srv sq) $>) + >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" @@ -1364,7 +1399,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do - cReq <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv + (cReq, _) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv notify $ INV (ACR cMode cReq) JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index ae80dc459..0ea7e1e1a 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1066,7 +1066,7 @@ withSMPClient c q cmdStr action = do sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg = - sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly + fst <$> sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly where sendViaProxy smp proxySess = do atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts @@ -1077,20 +1077,6 @@ sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags ms sendSMPMessage smp spKey_ senderId msgFlags msg sendOrProxySMPCommand :: - AgentClient -> - UserId -> - SMPServer -> - ConnId -> - ByteString -> - SMP.SenderId -> - (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) -> - (SMPClient -> ExceptT SMPClientError IO ()) -> - AM (Maybe SMPServer) -sendOrProxySMPCommand c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly = - fst <$> sendOrProxySMPCommand_ c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly -{-# INLINE sendOrProxySMPCommand #-} - -sendOrProxySMPCommand_ :: forall a. AgentClient -> UserId -> @@ -1101,7 +1087,7 @@ sendOrProxySMPCommand_ :: (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) -> (SMPClient -> ExceptT SMPClientError IO a) -> AM (Maybe SMPServer, a) -sendOrProxySMPCommand_ c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do +sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do tSess <- mkTransportSession c userId destSrv connId ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess) where @@ -1698,14 +1684,14 @@ deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} = secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData) secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} = - snd <$> sendOrProxySMPCommand_ c userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly + snd <$> sendOrProxySMPCommand c userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly where secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData) getQueueLink c userId server lnkId = - snd <$> sendOrProxySMPCommand_ c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly + snd <$> sendOrProxySMPCommand c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly where getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId getDirectly smp = getSMPQueueLink smp lnkId diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 9548b296c..3b7f69d14 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -94,6 +94,7 @@ module Simplex.Messaging.Agent.Store.AgentStore deleteInvShortLink, createInvShortLink, setInvShortLinkSndId, + updateShortLinkCreds, -- Messages updateRcvIds, createRcvMsg, @@ -782,24 +783,24 @@ getInvShortLink db server linkId = let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId} -getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe C.AAuthKeyPair) +getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.AAuthKeyPair)) getInvShortLinkKeys db srv sndId = maybeFirstRow toSndKeys $ DB.query db [sql| - SELECT snd_private_key + SELECT link_id, snd_private_key FROM inv_short_links WHERE host = ? AND port = ? AND snd_id = ? |] (host srv, port srv, sndId) where - toSndKeys :: Only C.APrivateAuthKey -> C.AAuthKeyPair - toSndKeys (Only privKey@(C.APrivateAuthKey a pk)) = (C.APublicAuthKey a $ C.publicKey pk, privKey) + toSndKeys :: (LinkId, C.APrivateAuthKey) -> (LinkId, C.AAuthKeyPair) + toSndKeys (linkId, privKey@(C.APrivateAuthKey a pk)) = (linkId, (C.APublicAuthKey a $ C.publicKey pk, privKey)) -deleteInvShortLink :: DB.Connection -> SMPServer -> SenderId -> IO () -deleteInvShortLink db srv sndId = - DB.execute db "DELETE FROM inv_short_links WHERE host = ? AND port = ? AND snd_id = ?" (host srv, port srv, sndId) +deleteInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO () +deleteInvShortLink db srv lnkId = + DB.execute db "DELETE FROM inv_short_links WHERE host = ? AND port = ? AND link_id = ?" (host srv, port srv, lnkId) createInvShortLink :: DB.Connection -> InvShortLink -> IO () createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId} = do @@ -830,6 +831,17 @@ setInvShortLinkSndId db InvShortLink {server, linkId} sndId = |] (sndId, host server, port server, linkId) +updateShortLinkCreds :: DB.Connection -> RcvQueue -> ShortLinkCreds -> IO () +updateShortLinkCreds db RcvQueue {server, rcvId} ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} = + DB.execute + db + [sql| + UPDATE rcv_queues + SET link_id = ?, link_key = ?, link_priv_sig_key = ?, link_enc_fixed_data = ? + WHERE host = ? AND port = ? AND rcv_id = ? + |] + (shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData, host server, port server, rcvId) + updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds db connId = do (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index 786d89ec8..b617196d4 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -31,17 +31,25 @@ encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeS encodeSignLinkData (sigKey, pk) agentVRange connReq userData = let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq} ud = smpEncode UserLinkData {agentVRange, userData} - in (LinkKey (C.sha3_256 fd), (sign fd, sign ud)) - where - sign s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s + in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk ud)) + +encodeSignUserData :: C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString +encodeSignUserData pk agentVRange userData = + encodeSign pk $ smpEncode UserLinkData {agentVRange, userData} + +encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString +encodeSign pk s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s -- TODO [short links] possibly use padded encryption for fixed and for user data encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> IO QueueLinkData encryptLinkData g k = bimapM encrypt encrypt where - encrypt s = do - nonce <- atomically $ C.randomCbNonce g - pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s + encrypt = encryptData g k + +encryptData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> IO EncDataBytes +encryptData g k s = do + nonce <- atomically $ C.randomCbNonce g + pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo) decryptLinkData linkKey k (encFD, encUD) = do diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 1aa6b0d64..cebcb4735 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1264,11 +1264,13 @@ client ACK msgId -> withQueue $ acknowledgeMsg msgId KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey LSET lnkId d -> - withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ - OK <$$ addQueueLinkData (queueStore ms) q lnkId d + withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of + Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH + _ -> OK <$$ addQueueLinkData (queueStore ms) q lnkId d LDEL -> - withQueue $ \q _ -> liftIO $ (corrId,entId,) . either ERR (const OK) <$> - deleteQueueLinkData (queueStore ms) q + withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of + Just _ -> OK <$$ deleteQueueLinkData (queueStore ms) q + Nothing -> pure $ Right OK NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_ diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 5de63d367..6aca44640 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -219,7 +219,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where Nothing -> addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId)) Just (lnkId', _) | lnkId' == lnkId -> - addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data != ?)") (d :. (lnkId, rId, fst d)) + addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data = ?)") (d :. (lnkId, rId, fst d)) _ -> throwE AUTH where rId = recipientId sq diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 63e6e3f49..35301c687 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -312,6 +312,7 @@ functionalAPITests ps = do it "should connect via 1-time short link" $ testInviationShortLink ps it "should connect via 1-time short link with async join" $ testInviationShortLinkAsync ps it "should connect via contact short link" $ testContactShortLink ps + it "should add short link to existing contact and connect" $ testAddContactShortLink ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -1130,7 +1131,7 @@ testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (_contactId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (contactId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1156,6 +1157,59 @@ testContactShortLink ps = get a ##> ("", bId, CON) get b ##> ("", aId, CON) exchangeGreetings a bId b aId + -- update user data + let updatedData = "updated user data" + shortLink' <- runRight $ setContactShortLink a contactId updatedData + shortLink' `shouldBe` shortLink + (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + connReq4 `shouldBe` connReq + updatedData' `shouldBe` updatedData + -- one more time + shortLink2 <- runRight $ setContactShortLink a contactId updatedData + shortLink2 `shouldBe` shortLink + -- delete short link + runRight_ $ deleteContactShortLink a contactId + Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink + pure () + +testAddContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () +testAddContactShortLink ps = + withAgentClients3 $ \a b c -> withSmpServer ps $ do + (contactId, (connReq, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe + let userData = "some user data" + shortLink <- runRight $ setContactShortLink a contactId userData + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + -- same user can get contact link again + (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + connReq2 `shouldBe` connReq + userData2 `shouldBe` userData + -- another user can get the same contact link + (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + connReq3 `shouldBe` connReq + userData3 `shouldBe` userData + runRight $ do + (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe + liftIO $ sndSecure `shouldBe` False + ("", _, REQ invId _ "bob's connInfo") <- get a + bId <- A.prepareConnectionToAccept a True invId PQSupportOn + sndSecure' <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure' `shouldBe` True + ("", _, CONF confId _ "alice's connInfo") <- get b + allowConnection b aId confId "bob's connInfo" + get a ##> ("", bId, INFO "bob's connInfo") + get a ##> ("", bId, CON) + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId + -- update user data + let updatedData = "updated user data" + shortLink' <- runRight $ setContactShortLink a contactId updatedData + shortLink' `shouldBe` shortLink + (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + connReq4 `shouldBe` connReq + updatedData' `shouldBe` updatedData testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 8fd798a6b..b52057b7c 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1102,6 +1102,13 @@ testInvQueueLinkData = sId3 `shouldBe` sId ld2 `shouldBe` ld + let newLD = (EncDataBytes "fixed data", EncDataBytes "updated user data") + Resp "8" rId' (ERR AUTH) <- signSendRecv r rKey ("8", rId, LSET lnkId newLD) + rId' `shouldBe` rId + + Resp "9" rId2 (ERR AUTH) <- signSendRecv r rKey ("9", rId, LDEL) + rId2 `shouldBe` rId + testContactQueueLinkData :: SpecWith (ATransport, AStoreType) testContactQueueLinkData = it "create and access queue short link data for contact address" $ \(ATransport t, msType) -> @@ -1141,6 +1148,27 @@ testContactQueueLinkData = sId3 `shouldBe` sId ld2 `shouldBe` ld + let newLD = (EncDataBytes "fixed data", EncDataBytes "updated user data") + Resp "7" rId' OK <- signSendRecv r rKey ("7", rId, LSET lnkId newLD) + rId' `shouldBe` rId + + Resp "8" _ (LNK sId4 ld3) <- sendRecv s ("", "8", lnkId, LGET) + sId4 `shouldBe` sId + ld3 `shouldBe` newLD + + badLnkId <- EntityId <$> atomically (C.randomBytes 24 g) + Resp "9" _ (ERR AUTH) <- signSendRecv r rKey ("9", rId, LSET badLnkId newLD) + + let badLD = (EncDataBytes "changed fixed data", EncDataBytes "updated user data 2") + Resp "10" _ (ERR AUTH) <- signSendRecv r rKey ("10", rId, LSET lnkId badLD) + + Resp "11" rId2 OK <- signSendRecv r rKey ("11", rId, LDEL) + rId2 `shouldBe` rId + Resp "11a" _ OK <- signSendRecv r rKey ("11a", rId, LDEL) + + Resp "12" lnkId3 (ERR AUTH) <- sendRecv s ("", "12", lnkId, LGET) + lnkId3 `shouldBe` lnkId + samplePubKey :: C.APublicVerifyKey samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY=" From 56bec06856eda552f015f03cd1eab30cacd00762 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 30 Mar 2025 19:56:16 +0100 Subject: [PATCH 04/15] smp protocol: remove creating notifications from NEW command, new ideas for notifications (#1500) --- rfcs/2025-03-16-smp-queues.md | 4 +- rfcs/2025-03-30-ios-notifications-3.md | 93 ++++++++++++++++++++++++++ src/Simplex/Messaging/Agent.hs | 16 +++-- src/Simplex/Messaging/Agent/Client.hs | 24 +++---- src/Simplex/Messaging/Client.hs | 7 +- src/Simplex/Messaging/Crypto.hs | 8 ++- src/Simplex/Messaging/Protocol.hs | 70 +++++++++++-------- src/Simplex/Messaging/Server.hs | 28 +++++--- src/Simplex/Messaging/Transport.hs | 2 +- tests/NtfServerTests.hs | 31 ++++----- tests/SMPProxyTests.hs | 2 +- tests/ServerTests.hs | 26 +++---- 12 files changed, 216 insertions(+), 95 deletions(-) create mode 100644 rfcs/2025-03-30-ios-notifications-3.md diff --git a/rfcs/2025-03-16-smp-queues.md b/rfcs/2025-03-16-smp-queues.md index d3d06d444..5b46b383b 100644 --- a/rfcs/2025-03-16-smp-queues.md +++ b/rfcs/2025-03-16-smp-queues.md @@ -84,7 +84,7 @@ data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey -- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists. data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, QueueLinkData)) --- SenderId should be computed client-side as sha3-256(correlation_id), +-- SenderId should be computed client-side as the first 24 bytes of sha3-384(correlation_id), -- The server must verify it and reject if it is not. type QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes) @@ -152,7 +152,7 @@ LGET :: Command Sender LNK :: SenderId -> QueueLinkData -> BrokerMsg ``` -To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as `sha3-256(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID. +To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID. To allow retries and to avoid regenerating all queue data, NEW command must be idempotent, and `correlation_id` must be preserved in command for queue creation, so that the same `correlation_id` and all other data is used in retries. `correlation_id` should be removed after queue creation success. diff --git a/rfcs/2025-03-30-ios-notifications-3.md b/rfcs/2025-03-30-ios-notifications-3.md new file mode 100644 index 000000000..441525767 --- /dev/null +++ b/rfcs/2025-03-30-ios-notifications-3.md @@ -0,0 +1,93 @@ +# New notifications protocol + +## Problem + +iOS notifications have these problems: +- iOS notification service crashes exceeding memory limit. This is being addressed by changes in GHC RTS. +- there is a large number of connections, because each member in a group requires individual connection. This will improve with chat relays when each group would require 2-3 connections. +- some notification may be not shown if notification with reply/mention is skipped, and instead some other message is delivered, which may be muted. This would not improve without some changes, as notifications may be skipped anyway. +- client devices delay communication with ntf server because it is done in background, and by that time the app may be suspended. +- notification server represents a bottleneck, as it has to be owned by the app vendor, and the current design when ntf server subscribes to notifications scales very badly. + +This RFC is based on the previous [RFC related to notifications](./2024-09-25-ios-notifications-2.md). + +## Solution + +As notification server has to know client token and currently it associates subscriptions with this token anyway, we are not gaining any privacy and security by using per-subscription keys - both authorization and encryption keys of notification subscription can be dropped. + +We still need to store the list of queue IDs associated with the token on the notification server, but we do not need any per-queue keys on the notification server, and we don't need subscriptions - it's effectively a simple set of IDs, with no other information. + +In this case, when queue is created the client would supply notifier ID - it has to be derived from correlation ID, to prevent existense check (see previous RFC). As we also supply sender ID, instead of deriving it as sha3-192 of correlation ID, they both can be derived as sha3-384 and split to two IDs - 24 bytes each. + +The notification server will maintain a rotating list of server keys with the latest key communicated to the client every time the token is registered and checked. The keys would expire after, say, 1 week or 1 month, and removed from notification server on expiration. + +The packet containing association between notifier queue ID and token will be crypto_box encrypted using key agreement between identified notification server master key and an ephemeral per packet (effectively, per-queue) client-key. + +Deleting the queue may also include encrypted packet that would verify that the client deleted the queue. + +Instead of notification server subscribing to the notifications creating a lot of traffic for the queues without messages, the SMP server would push notifications via NTF server connection (whether via NTF or via SMP protocol). This could be used as a mechanism to migrate existing queues when with the next subscription the notification server would communicate it's address to SMP server and this association would be stored together with the queue. + +## Protocol design + +Additional/changed SMP commands: + +```haskell +-- register notification server +-- should be signed with server key +NSRV :: NtfServerCreds -> Command NtfServer + +-- response +NSID :: NtfServerId -> BrokerMsg + +-- to communicate which server is responsible for the queue +-- should be signed with queue key +NSUB :: Maybe NtfServerId -> Command Notifier + +-- subscribe to notificaions from all queues associated with the server +-- should be signed with server key +-- entity ID - NtfServerId +NSSUB :: Command NtfServer + +data NtfServerCreds = NtfServerCreds + { server :: NtfServer, + -- NTF server certificate chain that should match fingerpring in address + cert :: X.CertificateChain, + -- server autorizatio key to sign server subscription requests + authKey :: X.SignedExact X.PubKey + } + +-- entity ID is recipient ID +NSKEY :: NtfSubscription -> Command Recipient + +data NtfSubscription = NtfSubscription + -- key to encrypt notifications e2e with the client + { ntfPubDbKey :: RcvNtfPublicDhKey, + ntfServer :: NtfServer, + -- should be linked to correlation ID to prevent existense check + -- the ID sent to notification server could be its hash? + ntfId :: NotifierId, + encNtfTokenAssoc :: EncDataBytes + } + +-- before the encryption - equivalent to NSUB command, but without key to authorize requests to specific queue +data NtfTokenAssoc = NtfTokenAssoc + { signature :: SignatureEd25519, + tknId :: NtfTokenId, + ntfQueue :: SMPQueueNtf + } +``` + +SMP server will need to maintain the list of Ntf servers and their credentials, and when NSSUB arrives to make only one subscription. When message arrives it would deliver notification to the correct connection via queue / ntf server association. + +Ntf server needs to maintain three indices to the same data: +- `(smpServer, queueId) -> tokenId` - to deliver notification to the correct token +- `tokenId -> [smpServer -> [queueId]]` - to remove all queues when token is removed, and to store/update these associations effficiently - store log may have one compact line per token (after compacting), or per token/server combination. +- `[smpServer]` - array of SMP servers to subscribe to. + +## Mention notifications + +Currently we are marking messages with T (true) for messages that require notifications and F (false) for messages that don't require. Sender does not know whether the recipient has notifications disabled, enabled or in mentions-only mode. + +The proposal is to: +- add additional values to this metadata, e.g. 2 (priority) and 3 (high priority) (and T/F could be sent as 0/1 respectively) - that is, to deliver notifications even if notifications are generally disabled (they can still be further filtered by the client). +- instead of deleting notification credentials when notifications are disabled - which is costly - communicate to SMP server the change of notificaion priority level, e.g. the client could set minimal notification priority to deliver notifications, where 0 would mean disabling it completely, 1 enable for all, 2 for priority 2+, 3 for priority 3. The downside here is that it could be used for timing correlation of queues in the group, but it already can be used on bulk deletions of ntf credentials for these queues and when sending messages. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 2cedf5fbd..5d9a7ceef 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -908,8 +908,9 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri) createRcvQueue nonce_ qd e2eKeys = do AgentConfig {smpClientVRange = vr} <- asks config - let ntfCreds_ = Nothing -- TODO [short links] - (rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode ntfCreds_ nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e + -- TODO [notifications] send correct NTF credentials here + -- let ntfCreds_ = Nothing + (rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `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 @@ -934,7 +935,8 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config - let sndId = SMP.EntityId $ C.sha3_256 corrId + -- TODO [notifications] the remaining 24 bytes are reserved for notifier ID + let sndId = SMP.EntityId $ B.take 24 $ C.sha3_384 corrId sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure connReq <- createConnReq qUri @@ -1117,8 +1119,8 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do - -- TODO [short links] ntf credentials - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode Nothing + -- TODO [notifications] send correct NTF credentials here + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing atomically $ incSMPServerStat c userId (qServer rq) connCreated let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq @@ -1886,8 +1888,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth - -- TODO [short links] send correct NTF credentials here - (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe Nothing + -- TODO [notifications] send correct NTF credentials here + (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' lift $ addNewQueueSubscription c rq'' tSess sessId diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 0ea7e1e1a..2355cdefa 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -267,7 +267,6 @@ import Simplex.Messaging.Protocol SubscriptionMode (..), QueueReqData (..), QueueLinkData, - NewNtfCreds, UserProtocol, VersionRangeSMPC, VersionSMPC, @@ -1232,7 +1231,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing + -- TODO [notifications] + SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing liftError (testErr TSSecureQueue) $ case queueMode of Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey @@ -1343,12 +1343,12 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode getSessionMode = fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} --- TODO [short links] add ntf credentials to RcvQueue -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> Maybe NewNtfCreds -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue c userId connId srv vRange cMode subMode ntfCreds = do +-- TODO [notifications] +newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c userId connId srv vRange cMode subMode = do let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing e2eKeys <- atomically . C.generateKeyPair =<< asks random - newRcvQueue_ c userId connId srv vRange qrd subMode ntfCreds Nothing e2eKeys + newRcvQueue_ c userId connId srv vRange qrd subMode Nothing e2eKeys data ClntQueueReqData = CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData))) @@ -1365,18 +1365,18 @@ queueReqData = \case CQRMessaging d -> QRMessaging $ srvReq <$> d CQRContact d -> QRContact $ srvReq <$> d -newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe NewNtfCreds -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode ntfCreds nonce_ (e2eDhKey, e2ePrivKey) = do +newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, privDhKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv NoEntity "NEW" tSess <- mkTransportSession c userId srv connId - -- TODO [short links] serverNtfCreds - r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serverNtfCreds}) <- + -- TODO [notifications] + r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode}) <- withClient c tSess $ \(SMPConnectedClient smp _) -> - (thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds + (thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] shortLink <- mkShortLinkCreds r let rq = @@ -1398,7 +1398,7 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode dbReplaceQueueId = Nothing, rcvSwchStatus = Nothing, smpClientVersion = maxVersion vRange, - clientNtfCreds = Nothing, -- TODO [short links] + clientNtfCreds = Nothing, deleteErrors = 0 } qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 5352658b2..7c18a0aa1 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -719,10 +719,11 @@ createSMPQueue :: Maybe BasicAuth -> SubscriptionMode -> QueueReqData -> - Maybe NewNtfCreds -> + -- TODO [notifications] + -- Maybe NewNtfCreds -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds = - sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case +createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd = + sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 88b882432..39fc65330 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -171,6 +171,7 @@ module Simplex.Messaging.Crypto sha256Hash, sha512Hash, sha3_256, + sha3_384, -- * Message padding / un-padding canPad, @@ -211,7 +212,7 @@ import Crypto.Cipher.AES (AES256) import qualified Crypto.Cipher.Types as AES import qualified Crypto.Cipher.XSalsa as XSalsa import qualified Crypto.Error as CE -import Crypto.Hash (Digest, SHA256 (..), SHA3_256, SHA512 (..), hash, hashDigestSize) +import Crypto.Hash (Digest, SHA3_256, SHA3_384, SHA256 (..), SHA512 (..), hash, hashDigestSize) import qualified Crypto.KDF.HKDF as H import qualified Crypto.MAC.Poly1305 as Poly1305 import qualified Crypto.PubKey.Curve25519 as X25519 @@ -978,6 +979,11 @@ sha3_256 :: ByteString -> ByteString sha3_256 = BA.convert . (hash :: ByteString -> Digest SHA3_256) {-# INLINE sha3_256 #-} +-- | SHA3-384 digest. +sha3_384 :: ByteString -> ByteString +sha3_384 = BA.convert . (hash :: ByteString -> Digest SHA3_384) +{-# INLINE sha3_384 #-} + -- | AEAD-GCM encryption with associated data. -- -- Used as part of double ratchet encryption. diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 6ae012027..fde0f8e68 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -65,7 +65,6 @@ module Simplex.Messaging.Protocol EncFixedDataBytes, EncUserDataBytes, EncDataBytes (..), - NewNtfCreds (..), Party (..), Cmd (..), DirectParty, @@ -73,7 +72,6 @@ module Simplex.Messaging.Protocol SParty (..), PartyI (..), QueueIdsKeys (..), - ServerNtfCreds (..), ProtocolErrorType (..), ErrorType (..), CommandError (..), @@ -457,8 +455,9 @@ data NewQueueReq = NewQueueReq rcvDhKey :: RcvPublicDhKey, auth_ :: Maybe BasicAuth, subMode :: SubscriptionMode, - queueReqData :: Maybe QueueReqData, - ntfCreds :: Maybe NewNtfCreds + queueReqData :: Maybe QueueReqData + -- TODO [notifications] + -- ntfCreds :: Maybe NewNtfCreds } deriving (Show) @@ -502,7 +501,8 @@ instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s) {-# INLINE toField #-} -data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show) +-- TODO [notifications] +-- data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show) instance StrEncoding SubscriptionMode where strEncode = \case @@ -533,9 +533,10 @@ instance Encoding QueueReqData where 'C' -> QRContact <$> smpP _ -> fail "bad QueueReqData" -instance Encoding NewNtfCreds where - smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey) - smpP = NewNtfCreds <$> smpP <*> smpP +-- TODO [notifications] +-- instance Encoding NewNtfCreds where +-- smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey) +-- smpP = NewNtfCreds <$> smpP <*> smpP type SenderCanSecure = Bool @@ -1243,17 +1244,19 @@ data QueueIdsKeys = QIK sndId :: SenderId, rcvPublicDhKey :: RcvPublicDhKey, queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion) - linkId :: Maybe LinkId, - serverNtfCreds :: Maybe ServerNtfCreds + linkId :: Maybe LinkId + -- TODO [notifications] + -- serverNtfCreds :: Maybe ServerNtfCreds } deriving (Eq, Show) -data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey - deriving (Eq, Show) +-- TODO [notifications] +-- data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey +-- deriving (Eq, Show) -instance Encoding ServerNtfCreds where - smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey) - smpP = ServerNtfCreds <$> smpP <*> smpP +-- instance Encoding ServerNtfCreds where +-- smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey) +-- smpP = ServerNtfCreds <$> smpP <*> smpP -- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- @@ -1481,8 +1484,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 NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds} - | v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds) + NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData} + | v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData) | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData)) | otherwise -> new <> auth <> e subMode where @@ -1556,18 +1559,19 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= shortLinksSMPVersion -> NEW <$> new smpP smpP smpP - | v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP) (pure Nothing) - | otherwise -> NEW <$> new auth (pure Nothing) (pure Nothing) + | v >= shortLinksSMPVersion -> NEW <$> new smpP smpP + | v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP) + | otherwise -> NEW <$> new auth (pure Nothing) where - new p1 p2 p3 = do + new p1 p2 = do rcvAuthKey <- _smpP rcvDhKey <- smpP auth_ <- p1 subMode <- smpP queueReqData <- p2 - ntfCreds <- p3 - pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds} + -- TODO [notifications] + -- ntfCreds <- p3 + pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData} -- ntfCreds auth = optional (A.char 'A' *> smpP) qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing SUB_ -> pure SUB @@ -1605,8 +1609,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where type Tag BrokerMsg = BrokerMsgTag encodeProtocol v = \case - IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serverNtfCreds} - | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId <> e serverNtfCreds + IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId} + | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId | v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode) | otherwise -> ids where @@ -1640,13 +1644,21 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where where bodyP = EncRcvMsgBody . unTail <$> smpP IDS_ - | v >= shortLinksSMPVersion -> ids smpP smpP smpP - | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing - | otherwise -> ids nothing nothing nothing + | v >= shortLinksSMPVersion -> ids smpP smpP + | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing + | otherwise -> ids nothing nothing where qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact nothing = pure Nothing - ids p1 p2 p3 = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p1 <*> p2 <*> p3) + ids p1 p2 = do + rcvId <- _smpP + sndId <- smpP + rcvPublicDhKey <- smpP + queueMode <- p1 + linkId <- p2 + -- TODO [notifications] + -- serverNtfCreds <- p3 + pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId} LNK_ -> LNK <$> _smpP <*> smpP NID_ -> NID <$> _smpP <*> smpP NMSG_ -> NMSG <$> _smpP <*> smpP diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index cebcb4735..8cf730e06 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1278,15 +1278,18 @@ client QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr where createQueue :: NewQueueReq -> M (Transmission BrokerMsg) - createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds} = time "NEW" $ do + createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData} = time "NEW" $ do g <- asks random idSize <- asks $ queueIdBytes . config updatedAt <- Just <$> liftIO getSystemDate (rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g - ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do - (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g - pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey) + -- TODO [notifications] + -- ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do + -- (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g + -- pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey) let randId = EntityId <$> atomically (C.randomBytes idSize g) + -- TODO [notifications] the remaining 24 bytes are reserver for notifier ID + sndId' = B.take 24 $ C.sha3_384 (bs corrId) tryCreate 0 = pure $ ERR INTERNAL tryCreate n = do (sndId, clntIds, queueData) <- case queueReqData of @@ -1296,13 +1299,14 @@ client -- The condition that client-provided sender ID must match hash of correlation ID -- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check -- if queue with this ID still exists. - if clntIds && unEntityId sndId /= C.sha3_256 (bs corrId) + if clntIds && unEntityId sndId /= sndId' then pure $ ERR $ CMD PROHIBITED else do rcvId <- randId - ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do - notifierId <- randId - pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey) + -- TODO [notifications] + -- ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do + -- notifierId <- randId + -- pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey) let queueMode = queueReqMode <$> queueReqData qr = QueueRec @@ -1312,7 +1316,8 @@ client senderKey = Nothing, queueMode, queueData, - notifier = fst <$> ntf, + -- TODO [notifications] + notifier = Nothing, -- fst <$> ntf, status = EntityActive, updatedAt } @@ -1325,11 +1330,12 @@ client stats <- asks serverStats incStat $ qCreated stats incStat $ qCount stats - when (isJust ntf) $ incStat $ ntfCreated stats + -- TODO [notifications] + -- when (isJust ntf) $ incStat $ ntfCreated stats case subMode of SMOnlyCreate -> pure () SMSubscribe -> void $ subscribeQueue q qr - pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serverNtfCreds = snd <$> ntf} + pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData} -- , serverNtfCreds = snd <$> ntf (corrId,entId,) <$> tryCreate (3 :: Int) checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 0480f28f9..e815d6f36 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -148,7 +148,7 @@ smpBlockSize = 16384 -- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024) -- 12 - BLOCKED error for blocked queues (1/11/2025) -- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025) --- 15 - short links, include creating NTF credentials in NEW command +-- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025) data SMPVersion diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 50c94f2fb..b2e868cc2 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -50,7 +50,7 @@ ntfServerTests :: ATransport -> Spec ntfServerTests t = do describe "Notifications server protocol syntax" $ ntfSyntaxTests t describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY - describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW + -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW ntfSyntaxTests :: ATransport -> Spec ntfSyntaxTests (ATransport t) = do @@ -185,17 +185,18 @@ createNtfQueueNKEY h sPub nPub = do let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) -createNtfQueueNEW :: CreateQueueFunc -createNtfQueueNEW h sPub nPub = do - g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g - let cmd = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) (Just (NewNtfCreds nPub rcvNtfPubDhKey))) - Resp "abcd" NoEntity (IDS (QIK rId sId srvDh _sndSecure _linkId (Just (ServerNtfCreds nId rcvNtfSrvPubDhKey)))) <- - signSendRecv h rKey ("abcd", NoEntity, cmd) - let dhShared = C.dh' srvDh dhPriv - Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) - (rId', rId) #== "same queue ID" - let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey - pure ((sId, rId, rKey, dhShared), nId, rcvNtfDhSecret) +-- TODO [notifications] +-- createNtfQueueNEW :: CreateQueueFunc +-- createNtfQueueNEW h sPub nPub = do +-- g <- C.newRandom +-- (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g +-- (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g +-- (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g +-- let cmd = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) (Just (NewNtfCreds nPub rcvNtfPubDhKey))) +-- Resp "abcd" NoEntity (IDS (QIK rId sId srvDh _sndSecure _linkId (Just (ServerNtfCreds nId rcvNtfSrvPubDhKey)))) <- +-- signSendRecv h rKey ("abcd", NoEntity, cmd) +-- let dhShared = C.dh' srvDh dhPriv +-- Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) +-- (rId', rId) #== "same queue ID" +-- let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey +-- pure ((sId, rId, rKey, dhShared), nId, rcvNtfDhSecret) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index f67564865..e39cb3449 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -178,7 +178,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 - SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing + SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index b52057b7c..00351befa 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -88,10 +88,10 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType B pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Recipient -pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing) +pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing))) pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg -pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId _srvNtfCreds) +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} @@ -264,7 +264,7 @@ testSndSecureProhibited = 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", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing)) + Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)))) (rId1, NoEntity) #== "creates queue" (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g @@ -1064,14 +1064,14 @@ testInvQueueLinkData = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g C.CbNonce corrId <- atomically $ C.randomCbNonce g - let sId = EntityId $ C.sha3_256 corrId + let sId = EntityId $ B.take 24 $ C.sha3_384 corrId ld = (EncDataBytes "fixed data", EncDataBytes "user data") qrd = QRMessaging $ Just (sId, ld) -- sender ID must be derived from corrId Resp "1" NoEntity (ERR (CMD PROHIBITED)) <- - signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) - Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing)) <- - signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd))) + Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId))) <- + signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd))) (sId', sId) #== "should return the same sender ID" corrId' `shouldBe` CorrId corrId -- can't read link data with LGET @@ -1118,14 +1118,14 @@ testContactQueueLinkData = (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g C.CbNonce corrId <- atomically $ C.randomCbNonce g lnkId <- EntityId <$> atomically (C.randomBytes 24 g) - let sId = EntityId $ C.sha3_256 corrId + let sId = EntityId $ B.take 24 $ C.sha3_384 corrId ld = (EncDataBytes "fixed data", EncDataBytes "user data") qrd = QRContact $ Just (lnkId, (sId, ld)) -- sender ID must be derived from corrId Resp "1" NoEntity (ERR (CMD PROHIBITED)) <- - signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) - Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing)) <- - signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing)) + signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd))) + Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId'))) <- + signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd))) (lnkId', lnkId) #== "should return the same link ID" (sId', sId) #== "should return the same sender ID" corrId' `shouldBe` CorrId corrId @@ -1194,8 +1194,8 @@ serverSyntaxTests (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), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) - it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) + it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "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) From 94ee3cecedd6ed5b4412d6eeb1f432ef0dfceb8c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 31 Mar 2025 16:54:29 +0100 Subject: [PATCH 05/15] agent: replace sndSecure with queueMode in queue URIs and records (#1502) * agent: replace sndSecure with queueMode in queue URIs and records * fix test --- src/Simplex/Messaging/Agent.hs | 43 +++++++++---- src/Simplex/Messaging/Agent/Client.hs | 10 ++- src/Simplex/Messaging/Agent/Protocol.hs | 62 +++++++++++++------ src/Simplex/Messaging/Agent/Store.hs | 6 +- .../Messaging/Agent/Store/AgentStore.hs | 26 ++++---- .../Migrations/M20250322_short_links.hs | 16 +++++ .../Migrations/M20250322_short_links.hs | 16 +++++ .../Store/SQLite/Migrations/agent_schema.sql | 4 +- src/Simplex/Messaging/Protocol.hs | 9 +-- .../Messaging/Server/QueueStore/Postgres.hs | 10 ++- .../Messaging/Server/QueueStore/QueueInfo.hs | 14 +---- tests/AgentTests/ConnectionRequestTests.hs | 24 +++---- tests/AgentTests/FunctionalAPITests.hs | 42 ++++++++----- tests/AgentTests/NotificationTests.hs | 12 ++-- tests/AgentTests/SQLiteTests.hs | 10 +-- tests/AgentTests/SchemaDump.hs | 4 +- tests/CoreTests/TRcvQueuesTests.hs | 4 +- 17 files changed, 197 insertions(+), 115 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 5d9a7ceef..1084881ad 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -192,7 +192,27 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolType (..), ProtocolTypeI (..), QueueLinkData, SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) +import Simplex.Messaging.Protocol + ( BrokerMsg, + Cmd (..), + ErrorType (AUTH), + MsgBody, + MsgFlags (..), + NtfServer, + ProtoServerWithAuth (..), + ProtocolType (..), + ProtocolTypeI (..), + QueueLinkData, + QueueMode (..), + SMPMsgMeta, + SParty (..), + SProtocolType (..), + SndPublicAuthKey, + SubscriptionMode (..), + UserProtocol, + VersionSMPC, + senderCanSecure, + ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -831,7 +851,7 @@ setContactShortLink' c connId userData = pure (linkId, shortLinkKey, (linkEncFixedData, d)) Nothing -> do sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g - let qUri = SMPQueueUri vr $ SMPQueueAddress server sndId (C.publicKey e2ePrivKey) False + let qUri = SMPQueueUri vr $ SMPQueueAddress server sndId (C.publicKey e2ePrivKey) (Just QMContact) connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] Nothing (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData (linkId, k) = SL.contactShortLinkKdf linkKey @@ -937,8 +957,8 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config -- TODO [notifications] the remaining 24 bytes are reserved for notifier ID let sndId = SMP.EntityId $ B.take 24 $ C.sha3_384 corrId - sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True - qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure + qm = case cMode of SCMContact -> QMContact; SCMInvitation -> QMMessaging + qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey (Just qm) connReq <- createConnReq qUri let (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData qd <- case cMode of @@ -1647,7 +1667,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, sndSecure} (Worker {doWork}, qLock) = do +runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userId, server, queueMode} (Worker {doWork}, qLock) = do AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do atomically $ endAgentOperation c AOSndNetwork @@ -1733,7 +1753,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI Right proxySrv_ -> do case msgType of AM_CONN_INFO - | sndSecure -> notify (CON pqEncryption) >> setStatus Active + | senderCanSecure queueMode -> notify (CON pqEncryption) >> setStatus Active | otherwise -> setStatus Confirmed AM_CONN_INFO_REPLY -> setStatus Confirmed AM_RATCHET_INFO -> pure () @@ -2558,7 +2578,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> TVar [ATransmission] -> AM () processSMP - rq@RcvQueue {rcvId = rId, sndSecure, e2ePrivKey, e2eDhSecret, status} + rq@RcvQueue {rcvId = rId, queueMode, e2ePrivKey, e2eDhSecret, status} conn cData@ConnData {connId, connAgentVersion, ratchetSyncState = rss} smpMsg @@ -2587,7 +2607,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) -> 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 + | senderCanSecure queueMode -> 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 @@ -3133,7 +3153,7 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo} agentSecureSndQueue :: AgentClient -> ConnData -> SndQueue -> AM SndQueueSecured -agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {sndSecure, status} +agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status} | sndSecure && status == New = do secureSndQueue c sq withStore' c $ \db -> setSndQueueStatus db sq Secured @@ -3142,6 +3162,7 @@ agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {sndSecure, status | sndSecure && status == Secured = pure initiatorRatchetOnConf | otherwise = pure False where + sndSecure = senderCanSecure queueMode initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage @@ -3226,7 +3247,7 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_ newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> Maybe (C.AAuthKeyPair) -> AM' (NewSndQueue, C.PublicKeyX25519) -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) sndKeys_ = do +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, queueMode, dhPublicKey = rcvE2ePubDhKey})) sndKeys_ = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random (sndPublicKey, sndPrivateKey) <- maybe (atomically $ C.generateAuthKeyPair a g) pure sndKeys_ @@ -3237,7 +3258,7 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd connId, server = smpServer, sndId = senderId, - sndSecure, + queueMode, sndPublicKey, sndPrivateKey, e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 2355cdefa..240b25f7e 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1390,7 +1390,7 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode e2ePrivKey, e2eDhSecret = Nothing, sndId, - sndSecure, + queueMode, shortLink, status = New, dbQueueId = DBNewQueue, @@ -1401,9 +1401,7 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode clientNtfCreds = Nothing, deleteErrors = 0 } - qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure - -- TODO [short links] maybe switch to queue mode? - sndSecure = senderCanSecure queueMode + qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey queueMode pure (rq, qUri, tSess, sessionId thParams') where mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds) @@ -1621,8 +1619,8 @@ logSecret' = B64.encode . B.take 3 {-# INLINE logSecret' #-} sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) -sendConfirmation c sq@SndQueue {userId, server, connId, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do - let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing) +sendConfirmation c sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do + let (privHdr, spKey) = if senderCanSecure queueMode 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 connId "" spKey sndId (MsgFlags {notification = True}) msg diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index e596b3e5d..dcf9e0329 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -207,6 +207,7 @@ import Simplex.Messaging.Protocol MsgId, NMsgMeta, ProtocolServer (..), + QueueMode (..), SMPClientVersion, SMPServer, SMPServerWithAuth, @@ -222,6 +223,8 @@ import Simplex.Messaging.Protocol sameSrvAddr, sndAuthKeySMPClientVersion, srvHostnamesSMPClientVersion, + shortLinksSMPClientVersion, + senderCanSecure, pattern ProtoServerWithAuth, pattern SMPServer, ) @@ -1166,16 +1169,20 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: deriving (Eq, Show) instance Encoding SMPQueueInfo where - smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) - | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure) - | clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey) + smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}) + | clientVersion >= shortLinksSMPClientVersion = addrEnc <> smpEncode queueMode + | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = addrEnc <> smpEncode sndSecure + | clientVersion > initialSMPClientVersion = addrEnc | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey) + where + addrEnc = smpEncode (clientVersion, smpServer, senderId, dhPublicKey) + sndSecure = senderCanSecure queueMode smpP = do clientVersion <- smpP smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP (senderId, dhPublicKey) <- smpP - sndSecure <- fromMaybe False <$> optional smpP - pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} + queueMode <- smpP <|> optional ((\ss -> if ss then QMMessaging else QMContact) <$> smpP) + pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode} -- 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 @@ -1202,7 +1209,7 @@ data SMPQueueAddress = SMPQueueAddress { smpServer :: SMPServer, senderId :: SMP.SenderId, dhPublicKey :: C.PublicKeyX25519, - sndSecure :: Bool -- TODO [short links] replace with queueMode? + queueMode :: Maybe QueueMode } deriving (Eq, Show) @@ -1229,42 +1236,57 @@ 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, sndSecure}) + strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, queueMode}) | 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)] <> [("k", "s") | sndSecure] + queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> queueModeParam <> sndSecureParam + where + queueModeParam = case queueMode of + Just QMMessaging -> [("q", "m")] + Just QMContact -> [("q", "c")] + Nothing -> [] + sndSecureParam = [("k", "s") | senderCanSecure queueMode && minVersion vr < shortLinksSMPClientVersion] 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, sndSecure) <- versioned <|> unversioned + (vr, hs, dhPublicKey, queueMode) <- 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, sndSecure} + pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode} where - unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput + unversioned = (versionToRange initialSMPClientVersion,[],,Nothing) <$> 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 - let sndSecure = queryParamStr "k" query == Just "s" - pure (vr, maybe [] thList_ hs_, dhKey, sndSecure) + let queueMode = case queryParamStr "q" query of + Just "m" -> Just QMMessaging + Just "c" -> Just QMContact + _ | queryParamStr "k" query == Just "s" -> Just QMMessaging + _ -> Nothing + pure (vr, maybe [] thList_ hs_, dhKey, queueMode) instance Encoding SMPQueueUri where - smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) - | maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure = - smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure) - | otherwise = - smpEncode (clientVRange, smpServer, senderId, dhPublicKey) + smpEncode (SMPQueueUri clientVRange@(VersionRange minV maxV) SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}) + -- The condition is for minVersion as earlier clients won't be able to support it. + -- The alternative would be to encode both queueMode and sndSecure + | minV >= shortLinksSMPClientVersion = addrEnc <> smpEncode queueMode + -- Earlier versions won't be able to ignore sndSecure, so we don't include it when it is False + | minV >= sndAuthKeySMPClientVersion || (maxV >= sndAuthKeySMPClientVersion && sndSecure) = addrEnc <> smpEncode sndSecure + | otherwise = addrEnc + where + addrEnc = smpEncode (clientVRange, smpServer, senderId, dhPublicKey) + sndSecure = senderCanSecure queueMode smpP = do (clientVRange, smpServer, senderId, dhPublicKey) <- smpP - sndSecure <- fromMaybe False <$> optional smpP - pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} + queueMode <- smpP <|> optional ((\ss -> if ss then QMMessaging else QMContact) <$> smpP) + pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode} data ConnectionRequestUri (m :: ConnectionMode) where CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index a04422780..79e194cf1 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -43,10 +43,10 @@ import Simplex.Messaging.Protocol NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, + QueueMode, RcvDhSecret, RcvNtfDhSecret, RcvPrivateAuthKey, - SenderCanSecure, SndPrivateAuthKey, SndPublicAuthKey, VersionSMPC, @@ -92,7 +92,7 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue -- | sender queue ID sndId :: SMP.SenderId, -- | sender can secure the queue - sndSecure :: SenderCanSecure, + queueMode :: Maybe QueueMode, -- | short link ID and credentials shortLink :: Maybe ShortLinkCreds, -- | queue status @@ -172,7 +172,7 @@ data StoredSndQueue (q :: QueueStored) = SndQueue -- | sender queue ID sndId :: SMP.SenderId, -- | sender can secure the queue - sndSecure :: SenderCanSecure, + queueMode :: Maybe QueueMode, -- | key pair used by the sender to authorize transmissions -- TODO combine keys to key pair so that types match sndPublicKey :: SndPublicAuthKey, diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 3b7f69d14..237787590 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -1971,12 +1971,12 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do [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, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash, + snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash, link_id, link_key, link_priv_sig_key, link_enc_fixed_data ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] ( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) - :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_) + :. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_) :. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink) ) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} @@ -1993,14 +1993,14 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do db [sql| INSERT INTO snd_queues - (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, + (host, port, snd_id, queue_mode, 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 (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) ON CONFLICT (host, port, snd_id) DO UPDATE SET host=EXCLUDED.host, port=EXCLUDED.port, snd_id=EXCLUDED.snd_id, - snd_secure=EXCLUDED.snd_secure, + queue_mode=EXCLUDED.queue_mode, conn_id=EXCLUDED.conn_id, snd_public_key=EXCLUDED.snd_public_key, snd_private_key=EXCLUDED.snd_private_key, @@ -2013,7 +2013,7 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do smp_client_version=EXCLUDED.smp_client_version, server_key_hash=EXCLUDED.server_key_hash |] - ((host server, port server, sndId, BI sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) + ((host server, port server, sndId, queueMode, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} @@ -2144,7 +2144,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.snd_secure, q.status, + q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, 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, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data @@ -2154,13 +2154,13 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, Maybe QueueMode) :. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) :. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) -> RcvQueue toRcvQueue - ( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) + ( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) :. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) @@ -2173,7 +2173,7 @@ toRcvQueue shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of (Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById db connId dbRcvId = @@ -2194,7 +2194,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, q.snd_secure, + c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.queue_mode, 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 @@ -2203,18 +2203,18 @@ sndQueueQuery = |] toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, BoolInt) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode) :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> SndQueue toSndQueue - ( (userId, keyHash, connId, host, port, sndId, BI sndSecure) + ( (userId, keyHash, connId, host, port, sndId, queueMode) :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) :. (dbQueueId, BI primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) ) = let server = SMPServer host port keyHash 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} + in SndQueue {userId, connId, server, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) getSndQueueById db connId dbSndId = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs index 774ad50d6..be627ea0a 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs @@ -17,6 +17,14 @@ ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BYTEA; CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id); +ALTER TABLE rcv_queues ADD COLUMN queue_mode TEXT; +UPDATE rcv_queues SET queue_mode = 'M' WHERE snd_secure = 1; +ALTER TABLE rcv_queues DROP COLUMN snd_secure; + +ALTER TABLE snd_queues ADD COLUMN queue_mode TEXT; +UPDATE snd_queues SET queue_mode = 'M' WHERE snd_secure = 1; +ALTER TABLE snd_queues DROP COLUMN snd_secure; + CREATE TABLE inv_short_links( inv_short_link_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, host TEXT NOT NULL, @@ -44,4 +52,12 @@ ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data; DROP INDEX idx_inv_short_links_link_id; DROP TABLE inv_short_links; + +ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +UPDATE rcv_queues SET snd_secure = 1 WHERE queue_mode = 'M'; +ALTER TABLE rcv_queues DROP COLUMN queue_mode; + +ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +UPDATE snd_queues SET snd_secure = 1 WHERE queue_mode = 'M'; +ALTER TABLE snd_queues DROP COLUMN queue_mode; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs index 70a15b8cc..c6cbd423b 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs @@ -15,6 +15,14 @@ ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BLOB; CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id); +ALTER TABLE rcv_queues ADD COLUMN queue_mode TEXT; +UPDATE rcv_queues SET queue_mode = 'M' WHERE snd_secure = 1; +ALTER TABLE rcv_queues DROP COLUMN snd_secure; + +ALTER TABLE snd_queues ADD COLUMN queue_mode TEXT; +UPDATE snd_queues SET queue_mode = 'M' WHERE snd_secure = 1; +ALTER TABLE snd_queues DROP COLUMN snd_secure; + CREATE TABLE inv_short_links( inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT, host TEXT NOT NULL, @@ -41,4 +49,12 @@ ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data; DROP INDEX idx_inv_short_links_link_id; DROP TABLE inv_short_links; + +ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +UPDATE rcv_queues SET snd_secure = 1 WHERE queue_mode = 'M'; +ALTER TABLE rcv_queues DROP COLUMN queue_mode; + +ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +UPDATE snd_queues SET snd_secure = 1 WHERE queue_mode = 'M'; +ALTER TABLE snd_queues DROP COLUMN queue_mode; |] 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 5db250ad0..fde671d7a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -55,12 +55,12 @@ CREATE TABLE rcv_queues( server_key_hash BLOB, switch_status TEXT, deleted INTEGER NOT NULL DEFAULT 0, - snd_secure INTEGER NOT NULL DEFAULT 0, last_broker_ts TEXT, link_id BLOB, link_key BLOB, link_priv_sig_key BLOB, link_enc_fixed_data BLOB, + queue_mode TEXT, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -83,7 +83,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, + queue_mode TEXT, PRIMARY KEY(host, port, snd_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index fde0f8e68..b486a7a38 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -57,7 +57,6 @@ module Simplex.Messaging.Protocol ProtocolEncoding (..), Command (..), SubscriptionMode (..), - SenderCanSecure, NewQueueReq (..), QueueReqData (..), QueueMode (..), @@ -171,6 +170,7 @@ module Simplex.Messaging.Protocol legacyStrEncodeServer, srvHostnamesSMPClientVersion, sndAuthKeySMPClientVersion, + shortLinksSMPClientVersion, sameSrvAddr, sameSrvAddr', noAuthSrv, @@ -262,8 +262,11 @@ srvHostnamesSMPClientVersion = VersionSMPC 2 sndAuthKeySMPClientVersion :: VersionSMPC sndAuthKeySMPClientVersion = VersionSMPC 3 +shortLinksSMPClientVersion :: VersionSMPC +shortLinksSMPClientVersion = VersionSMPC 4 + currentSMPClientVersion :: VersionSMPC -currentSMPClientVersion = VersionSMPC 3 +currentSMPClientVersion = VersionSMPC 4 supportedSMPClientVRange :: VersionRangeSMPC supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion @@ -538,8 +541,6 @@ instance Encoding QueueReqData where -- smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey) -- smpP = NewNtfCreds <$> smpP <*> smpP -type SenderCanSecure = Bool - newtype EncTransmission = EncTransmission ByteString deriving (Show) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 6aca44640..186a1574d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -44,6 +44,7 @@ import Data.List (intersperse) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) import qualified Database.PostgreSQL.Simple as DB @@ -57,6 +58,7 @@ import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Config @@ -66,13 +68,13 @@ import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (firstRow, ifM, tshow, (<$$>)) +import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, tshow, (<$$>)) import System.Exit (exitFailure) import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM #if !defined(dbPostgres) -import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String #endif @@ -527,6 +529,10 @@ instance ToField EntityId where toField (EntityId s) = toField $ Binary s deriving newtype instance FromField EntityId #if !defined(dbPostgres) +instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 + +instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode + instance ToField (C.DhSecret 'C.X25519) where toField = toField . Binary . C.dhBytes' instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder strDecode diff --git a/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs index dbb716c53..9cebd8af7 100644 --- a/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs +++ b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs @@ -10,18 +10,12 @@ import qualified Data.Aeson.TH as JQ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Lazy.Char8 as LB import Data.Text (Text) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) -import Simplex.Messaging.Util ((<$?>)) - -#if defined(dbServerPostgres) -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) -import Simplex.Messaging.Util (eitherToMaybe) -#endif +import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) data QueueInfo = QueueInfo { qiSnd :: Bool, @@ -63,11 +57,9 @@ instance Encoding QueueMode where 'C' -> pure QMContact _ -> fail "bad QueueMode" -#if defined(dbServerPostgres) instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode -#endif $(JQ.deriveJSON (enumJSON $ dropPrefix "Q") ''QSubThread) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 5ac090b8b..4a8b52cd5 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -22,7 +22,7 @@ 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 (EntityId (..), ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), ProtocolServer (..), QueueMode (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Version import Test.Hspec @@ -39,11 +39,11 @@ queueAddr = { smpServer = srv, senderId = EntityId "\223\142z\251", dhPublicKey = testDhKey, - sndSecure = False + queueMode = Nothing } queueAddrSK :: SMPQueueAddress -queueAddrSK = queueAddr {sndSecure = True} +queueAddrSK = queueAddr {queueMode = Just QMMessaging} queueAddr1 :: SMPQueueAddress queueAddr1 = queueAddr {smpServer = srv1} @@ -62,16 +62,16 @@ 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" +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&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" +queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&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 +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr queueV1 :: SMPQueueUri queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr @@ -85,10 +85,10 @@ 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 = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr queueNewStr' :: ByteString -queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> testDhKeyStr +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> testDhKeyStr queueNewNoPort :: SMPQueueUri queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} @@ -97,7 +97,7 @@ 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 +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr queueNew1NoPort :: SMPQueueUri queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} @@ -217,14 +217,14 @@ connectionRequestTests = describe "connection request parsing / serializing" $ do 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") + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-4&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) + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr) + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-4&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") diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 35301c687..43cfd0d1e 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -95,13 +95,13 @@ import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQ import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) -import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) +import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -202,7 +202,7 @@ pattern Rcvd :: AgentMsgId -> AEvent 'AEConn pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}] smpCfgVPrev :: ProtocolClientConfig SMPVersion -smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} +smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} ntfCfgVPrev :: ProtocolClientConfig NTFVersion ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} @@ -501,18 +501,18 @@ testMatrix2 ps runTest = do it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 1 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 1 $ runTest PQSupportOff False False testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2Stress ps runTest = do it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn False True it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False + it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 1 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 1 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 1 $ runTest PQSupportOff False False where aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval} @@ -521,9 +521,9 @@ testMatrix2Stress ps runTest = do testBasicMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testBasicMatrix2 ps runTest = do it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True - it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False - it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False - it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 1 $ runTest False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 1 $ runTest False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 1 $ runTest False testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 ps runTest = do @@ -1131,7 +1131,8 @@ testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (contactId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (contactId, (connReq0, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + Right connReq <- pure $ strDecode (strEncode connReq0) (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1175,7 +1176,8 @@ testContactShortLink ps = testAddContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testAddContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do - (contactId, (connReq, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe + (contactId, (connReq0, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe + Right connReq <- pure $ strDecode (strEncode connReq0) let userData = "some user data" shortLink <- runRight $ setContactShortLink a contactId userData (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink @@ -2498,8 +2500,8 @@ testWaitDeliveryTimeout2 ps = testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ATransport, AStoreType) -> IO () testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} - withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> - withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do + withAgent 1 cfg' initAgentServers testDB $ \a -> + withAgent 2 cfg' initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a @@ -2533,6 +2535,12 @@ testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) exchangeGreetingsMsgId 4 a bId b aId + where + cfg' = + agentCfgVPrevPQ + { smpClientVRange = V.mkVersionRange initialSMPClientVersion srvHostnamesSMPClientVersion, -- before SKEY + smpCfg = smpCfgVPrev {serverVRange = V.mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} -- before SKEY + } testJoinConnectionAsyncReplyError :: HasCallStack => (ATransport, AStoreType) -> IO () testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index da85d25aa..ea0ebd29b 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -175,15 +175,15 @@ testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> testNtfMatrix ps@(_, msType) runTest = do describe "next and current" $ do it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest - it "curr servers; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "curr servers; prev clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg ps 1 cfgVPrev' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest it "prev servers; curr clients" $ runNtfTestCfg ps 1 cfgVPrev' ntfServerCfgVPrev agentCfg agentCfg runTest -- servers can be upgraded in any order - it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg ps 1 cfgVPrev' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest -- one of two clients can be upgraded - it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest - it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest where cfg' = cfgMS msType cfgVPrev' = cfgVPrev msType diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 7be9ac465..fb6c72996 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -52,7 +52,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String (StrEncoding (..)) -import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), QueueMode (..), pattern VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import System.Random import Test.Hspec @@ -226,7 +226,7 @@ rcvQueue1 = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = EntityId "2345", - sndSecure = True, + queueMode = Just QMMessaging, shortLink = Nothing, status = New, dbQueueId = DBNewQueue, @@ -245,7 +245,7 @@ sndQueue1 = connId = "conn1", server = smpServer1, sndId = EntityId "3456", - sndSecure = True, + queueMode = Just QMMessaging, sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, @@ -405,7 +405,7 @@ testUpgradeRcvConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = EntityId "2345", - sndSecure = True, + queueMode = Just QMMessaging, sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, @@ -439,7 +439,7 @@ testUpgradeSndConnToDuplex = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = EntityId "4567", - sndSecure = True, + queueMode = Just QMMessaging, shortLink = Nothing, status = New, dbQueueId = DBNewQueue, diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 0b6f4ebc1..376a13cb4 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -115,7 +115,9 @@ testUsersMigrationOld = do skipComparisonForDownMigrations :: [String] skipComparisonForDownMigrations = [ -- on down migration idx_messages_internal_snd_id_ts index moves down to the end of the file - "m20230814_indexes" + "m20230814_indexes", + -- snd_secure and last_broker_ts columns swap order on down migration + "m20250322_short_links" ] getSchema :: FilePath -> FilePath -> IO String diff --git a/tests/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 4433d2a4d..4098fd0f4 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -17,7 +17,7 @@ import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId) import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..)) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer, QueueMode (..), pattern NoEntity, pattern VersionSMPC) import Test.Hspec import UnliftIO @@ -197,7 +197,7 @@ dummyRQ userId server connId rcvId = e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, sndId = NoEntity, - sndSecure = True, + queueMode = Just QMMessaging, shortLink = Nothing, status = New, dbQueueId = DBQueueId 0, From 2c5530c9f0d0e30bdcdb29947599d818533523bf Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 1 Apr 2025 22:32:49 +0100 Subject: [PATCH 06/15] agent: binary protocol encoding for connection request (#1503) * agent: binary protocol encoding for connection request * enable tests * test --- src/Simplex/Messaging/Agent/Protocol.hs | 54 +++++++++++++++++++--- src/Simplex/Messaging/Crypto/Ratchet.hs | 39 ++++++++++++++-- tests/AgentTests/ConnectionRequestTests.hs | 27 +++++++++++ tests/AgentTests/FunctionalAPITests.hs | 5 +- 4 files changed, 111 insertions(+), 14 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index dcf9e0329..f27ffbcd2 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -690,19 +690,23 @@ instance Eq AConnectionMode where cmInvitation :: AConnectionMode cmInvitation = ACM SCMInvitation +{-# INLINE cmInvitation #-} cmContact :: AConnectionMode cmContact = ACM SCMContact +{-# INLINE cmContact #-} deriving instance Show AConnectionMode connMode :: SConnectionMode m -> ConnectionMode connMode SCMInvitation = CMInvitation connMode SCMContact = CMContact +{-# INLINE connMode #-} connMode' :: ConnectionMode -> AConnectionMode connMode' CMInvitation = cmInvitation connMode' CMContact = cmContact +{-# INLINE connMode' #-} class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m @@ -1054,10 +1058,27 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData strP = connReqUriP' (Just SSSimplex) --- TODO [short links] do not use StrEncoding instance instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where - smpEncode = smpEncode . Large . strEncode - smpP = strDecode . unLarge <$?> smpP + smpEncode = \case + CRInvitationUri crData e2eParams -> smpEncode (CMInvitation, crData, e2eParams) + CRContactUri crData -> smpEncode (CMContact, crData) + smpP = (\(ACR _ cr) -> checkConnMode cr) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AConnectionRequestUri where + smpEncode (ACR _ cr) = smpEncode cr + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> ACR SCMInvitation <$> (CRInvitationUri <$> smpP <*> smpP) + CMContact -> ACR SCMContact . CRContactUri <$> smpP + +instance Encoding ConnReqUriData where + smpEncode ConnReqUriData {crAgentVRange, crSmpQueues, crClientData} = + smpEncode (crAgentVRange, crSmpQueues, Large . encodeUtf8 <$> crClientData) + smpP = do + (crAgentVRange, crSmpQueues, clientData) <- smpP + pure ConnReqUriData {crScheme = SSSimplex, crAgentVRange, crSmpQueues, crClientData = safeDecodeUtf8 . unLarge <$> clientData} connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m) connReqUriP' overrideScheme = do @@ -1122,6 +1143,16 @@ instance StrEncoding AConnectionMode where strEncode (ACM cMode) = strEncode $ connMode cMode strP = connMode' <$> strP +instance Encoding ConnectionMode where + smpEncode = \case + CMInvitation -> "I" + CMContact -> "C" + smpP = + A.anyChar >>= \case + 'I' -> pure CMInvitation + 'C' -> pure CMContact + _ -> fail "bad connection mode" + connModeT :: Text -> Maybe ConnectionMode connModeT = \case "INV" -> Just CMInvitation @@ -1170,7 +1201,7 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: instance Encoding SMPQueueInfo where smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}) - | clientVersion >= shortLinksSMPClientVersion = addrEnc <> smpEncode queueMode + | clientVersion >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = addrEnc <> smpEncode sndSecure | clientVersion > initialSMPClientVersion = addrEnc | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey) @@ -1181,7 +1212,7 @@ instance Encoding SMPQueueInfo where clientVersion <- smpP smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP (senderId, dhPublicKey) <- smpP - queueMode <- smpP <|> optional ((\ss -> if ss then QMMessaging else QMContact) <$> smpP) + queueMode <- queueModeP pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode} -- This instance seems contrived and there was a temptation to split a common part of both types. @@ -1276,7 +1307,7 @@ instance Encoding SMPQueueUri where smpEncode (SMPQueueUri clientVRange@(VersionRange minV maxV) SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}) -- The condition is for minVersion as earlier clients won't be able to support it. -- The alternative would be to encode both queueMode and sndSecure - | minV >= shortLinksSMPClientVersion = addrEnc <> smpEncode queueMode + | minV >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode -- Earlier versions won't be able to ignore sndSecure, so we don't include it when it is False | minV >= sndAuthKeySMPClientVersion || (maxV >= sndAuthKeySMPClientVersion && sndSecure) = addrEnc <> smpEncode sndSecure | otherwise = addrEnc @@ -1285,9 +1316,12 @@ instance Encoding SMPQueueUri where sndSecure = senderCanSecure queueMode smpP = do (clientVRange, smpServer, senderId, dhPublicKey) <- smpP - queueMode <- smpP <|> optional ((\ss -> if ss then QMMessaging else QMContact) <$> smpP) + queueMode <- queueModeP pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode} +queueModeP :: Parser (Maybe QueueMode) +queueModeP = Just <$> smpP <|> optional ((\case True -> QMMessaging; _ -> QMContact) <$> smpP) + data ConnectionRequestUri (m :: ConnectionMode) where CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation -- contact connection request does NOT contain E2E encryption parameters for double ratchet - @@ -1374,6 +1408,12 @@ sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUr where same (q, q') = sameQAddress (qAddress q) (qAddress q') +checkConnMode :: forall t m m'. (ConnectionModeI m, ConnectionModeI m') => t m' -> Either String (t m) +checkConnMode c = case testEquality (sConnectionMode @m) (sConnectionMode @m') of + Just Refl -> Right c + Nothing -> Left "bad connection mode" +{-# INLINE checkConnMode #-} + data ConnReqUriData = ConnReqUriData { crScheme :: ServiceScheme, crAgentVRange :: VersionRangeSMPA, diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 8c79503c8..576e78c03 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -306,11 +306,13 @@ instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri | otherwise = case kem of RKParamsProposed k -> [("kem_key", strEncode k)] RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)] - strP = toParamsURI <$?> strP - where - toParamsURI = \case - AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing - AE2ERatchetParamsUri _ ps -> checkRatchetKEMState ps + strP = toE2ERatchetParamsUri <$?> strP + {-# INLINE strP #-} + +toE2ERatchetParamsUri :: RatchetKEMStateI s => AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a) +toE2ERatchetParamsUri = \case + AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing + AE2ERatchetParamsUri _ ps -> checkRatchetKEMState ps instance AlgorithmI a => StrEncoding (AE2ERatchetParamsUri a) where strEncode (AE2ERatchetParamsUri _ ps) = strEncode ps @@ -340,6 +342,33 @@ instance StrEncoding AnyE2ERatchetParamsUri where Nothing -> ARKP SRKSProposed $ RKParamsProposed k Just ct -> ARKP SRKSAccepted $ RKParamsAccepted ct k +instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParamsUri s a) where + smpEncode (E2ERatchetParamsUri vr k1 k2 kem_) = smpEncode (vr, k1, k2, kem_) + {-# INLINE smpEncode #-} + smpP = toE2ERatchetParamsUri <$?> smpP + {-# INLINE smpP #-} + +instance AlgorithmI a => Encoding (AE2ERatchetParamsUri a) where + smpEncode (AE2ERatchetParamsUri _ ps) = smpEncode ps + {-# INLINE smpEncode #-} + smpP = (\(AnyE2ERatchetParamsUri s _ ps) -> AE2ERatchetParamsUri s <$> checkAlgorithm ps) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AnyE2ERatchetParamsUri where + smpEncode (AnyE2ERatchetParamsUri _ _ ps) = smpEncode ps + {-# INLINE smpEncode #-} + smpP = do + vr <- smpP @VersionRangeE2E + APublicDhKey a k1 <- smpP + APublicDhKey a' k2 <- smpP + case testEquality a a' of + Nothing -> fail "bad e2e params: different key algorithms" + Just Refl -> + let result = \case + Just (ARKP s kem) -> AnyE2ERatchetParamsUri s a $ E2ERatchetParamsUri vr k1 k2 (Just kem) + Nothing -> AnyE2ERatchetParamsUri SRKSProposed a $ E2ERatchetParamsUri vr k1 k2 Nothing + in result <$> smpP + type RcvE2ERatchetParams a = E2ERatchetParams 'RKSProposed a type SndE2ERatchetParams a = AE2ERatchetParams a diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 4a8b52cd5..5465bca1b 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -21,6 +21,7 @@ import Network.HTTP.Types (urlEncode) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (EntityId (..), ProtocolServer (..), QueueMode (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) @@ -253,3 +254,29 @@ connectionRequestTests = 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-7&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") + it "should serialize / parse queue address, connection invitations and contact addresses as binary" $ do + smpEncodingTest queue + smpEncodingTest queueSK + smpEncodingTest queue1 + smpEncodingTest queueNew + smpEncodingTest queueNew1 + smpEncodingTest queueNewNoPort + smpEncodingTest queueNew1NoPort + smpEncodingTest queueV1 + smpEncodingTest queueV1NoPort + smpEncodingTest connectionRequest + smpEncodingTest connectionRequestSK + smpEncodingTest connectionRequest1 + smpEncodingTest connectionRequest2queues + smpEncodingTest connectionRequestNew + smpEncodingTest connectionRequestNew1 + smpEncodingTest connectionRequest2queuesNew + smpEncodingTest connectionRequestClientDataEmpty + smpEncodingTest contactAddress + smpEncodingTest contactAddress2queues + smpEncodingTest contactAddressNew + smpEncodingTest contactAddress2queuesNew + smpEncodingTest contactAddressV2 + smpEncodingTest contactAddressClientData + where + smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a \ No newline at end of file diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 43cfd0d1e..2904f9576 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -93,6 +93,7 @@ import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), 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 import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange) @@ -1132,7 +1133,7 @@ testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" (contactId, (connReq0, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe - Right connReq <- pure $ strDecode (strEncode connReq0) + Right connReq <- pure $ smpDecode (smpEncode connReq0) (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1177,7 +1178,7 @@ testAddContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testAddContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do (contactId, (connReq0, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe - Right connReq <- pure $ strDecode (strEncode connReq0) + Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = "some user data" shortLink <- runRight $ setContactShortLink a contactId userData (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink From 7ec0ae3bb5d21fdcaf8a404d1638d1e119c7a3dd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 3 Apr 2025 16:31:22 +0100 Subject: [PATCH 07/15] agent: types and encodings to use from the app (#1504) * agent: types and encodings to use from the app * use action forks --- .github/workflows/build.yml | 8 ++-- .github/workflows/docker-image.yml | 6 +-- src/Simplex/Messaging/Agent.hs | 20 +++++---- src/Simplex/Messaging/Agent/Protocol.hs | 60 +++++++++++++++++++++++-- tests/AgentTests/EqInstances.hs | 4 -- tests/AgentTests/FunctionalAPITests.hs | 25 ++++++----- tests/SMPProxyTests.hs | 8 ++-- 7 files changed, 92 insertions(+), 39 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 911bf5e66..451de173b 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -46,10 +46,10 @@ jobs: uses: actions/checkout@v3 - name: Set up Docker Buildx - uses: docker/setup-buildx-action@v3 + uses: simplex-chat/docker-setup-buildx-action@v3 - name: Build and cache Docker image - uses: docker/build-push-action@v6 + uses: simplex-chat/docker-build-push-action@v6 with: context: . load: true @@ -127,7 +127,7 @@ jobs: - name: Build changelog if: startsWith(github.ref, 'refs/tags/v') id: build_changelog - uses: mikepenz/release-changelog-builder-action@v5 + uses: simplex-chat/release-changelog-builder-action@v5 with: configuration: .github/changelog_conf.json failOnError: true @@ -138,7 +138,7 @@ jobs: - name: Create release if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7' - uses: softprops/action-gh-release@v2 + uses: simplex-chat/action-gh-release@v2 with: body: | See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md). diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index efd74552f..6e3e25e82 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -22,14 +22,14 @@ jobs: uses: actions/checkout@v4 - name: Log in to Docker Hub - uses: docker/login-action@v3 + uses: simplex-chat/docker-login-action@v3 with: username: ${{ secrets.DOCKERHUB_USERNAME }} password: ${{ secrets.DOCKERHUB_PASSWORD }} - name: Extract metadata for Docker image id: meta - uses: docker/metadata-action@v5 + uses: simplex-chat/docker-metadata-action@v5 with: images: ${{ secrets.DOCKERHUB_USERNAME }}/${{ matrix.app }} flavor: | @@ -40,7 +40,7 @@ jobs: type=semver,pattern=v{{major}} - name: Build and push Docker image - uses: docker/build-push-action@v6 + uses: simplex-chat/docker-build-push-action@v6 with: push: true build-args: | diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1084881ad..44b95a48b 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -365,7 +365,7 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' {-# INLINE deleteConnectionsAsync #-} -- | Create SMP agent connection (NEW command) -createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c))) +createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, CreatedConnLink c) createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs {-# INLINE createConnection #-} @@ -400,10 +400,12 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne -- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall. prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs +{-# INLINE prepareConnectionToJoin #-} -- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID). prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs +{-# INLINE prepareConnectionToAccept #-} -- | Join SMP agent connection (JOIN command). joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured @@ -822,7 +824,7 @@ switchConnectionAsync' c corrId connId = pure . connectionStats $ DuplexConnection cData rqs' sqs _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex" -newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c))) +newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, CreatedConnLink c) newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do srv <- getSMPServer c userId connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) @@ -909,7 +911,7 @@ changeConnectionUser' c oldUserId connId newUserId = do where updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId -newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) +newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c) newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" @@ -923,7 +925,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s Nothing -> do let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing (_, qUri) <- createRcvQueue Nothing qd e2eKeys - (,Nothing) <$> createConnReq qUri + (`CCLink` Nothing) <$> createConnReq qUri where createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri) createRcvQueue nonce_ qd e2eKeys = do @@ -971,21 +973,21 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s srvData <- liftIO $ SL.encryptLinkData g k linkData pure $ CQRMessaging $ Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)} pure (nonce, qUri, connReq, qd) - connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c)) + connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (CreatedConnLink c) connReqWithShortLink qUri cReq qUri' shortLink = case shortLink of Just ShortLinkCreds {shortLinkId, shortLinkKey} | qUri == qUri' -> let link = case cReq of CRContactUri _ -> CSLContact srv CCTContact shortLinkKey CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey - in pure (cReq, Just link) + in pure $ CCLink cReq (Just link) | otherwise -> throwE $ INTERNAL "different rcv queue address" Nothing -> let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData) cReq' = case cReq of CRContactUri crData -> CRContactUri (updated crData) CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams - in pure (cReq', Nothing) + in pure $ CCLink cReq' Nothing newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of @@ -1111,7 +1113,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do - (cReq, _) <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv + CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing (CR.IKNoPQ pqSup) subMode srv void $ sendInvitation c userId connId qInfo vrsn cReq cInfo pure False Nothing -> throwE $ AGENT A_VERSION @@ -1421,7 +1423,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do - (cReq, _) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv + CCLink cReq _ <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv notify $ INV (ACR cMode cReq) JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index f27ffbcd2..043f38688 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -112,7 +112,11 @@ module Simplex.Messaging.Agent.Protocol ServiceScheme, FixedLinkData (..), UserLinkData (..), + ConnectionLink (..), + AConnectionLink (..), ConnShortLink (..), + AConnShortLink (..), + CreatedConnLink (..), ContactConnType (..), LinkKey (..), sameConnReqContact, @@ -175,7 +179,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Clock.System (SystemTime) import Data.Type.Equality -import Data.Typeable () +import Data.Typeable (Typeable) import Data.Word (Word16, Word32) import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_) import Simplex.FileTransfer.Description @@ -1129,6 +1133,13 @@ instance ToJSON AConnectionRequestUri where toJSON = strToJSON toEncoding = strToJEncoding +instance ConnectionModeI m => FromJSON (ConnShortLink m) where + parseJSON = strParseJSON "ConnShortLink" + +instance ConnectionModeI m => ToJSON (ConnShortLink m) where + toJSON = strToJSON + toEncoding = strToJEncoding + -- debug :: Show a => String -> a -> a -- debug name value = unsafePerformIO (putStrLn $ name <> ": " <> show value) `seq` value -- {-# INLINE debug #-} @@ -1345,6 +1356,8 @@ data ConnShortLink (m :: ConnectionMode) where CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact +deriving instance Eq (ConnShortLink m) + deriving instance Show (ConnShortLink m) newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data) @@ -1353,15 +1366,49 @@ newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data) instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s -data ContactConnType = CCTContact | CCTGroup deriving (Show) +instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode + +instance (Typeable c, ConnectionModeI c) => FromField (ConnectionLink c) where fromField = blobFieldDecoder strDecode + +instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField . Binary . strEncode + +instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode + +data ContactConnType = CCTContact | CCTGroup deriving (Eq, Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) --- TODO [short link] parser, parsing tests data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m) + deriving (Eq, Show) + +data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connShortLink :: Maybe (ConnShortLink m)} + deriving (Eq, Show) data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m) +deriving instance Show AConnectionLink + +instance ConnectionModeI m => StrEncoding (ConnectionLink m) where + strEncode = \case + CLFull cr -> strEncode cr + CLShort sl -> strEncode sl + strP = (\(ACL _ cl) -> checkConnMode cl) <$?> strP + {-# INLINE strP #-} + +instance StrEncoding AConnectionLink where + strEncode (ACL _ cl) = strEncode cl + {-# INLINE strEncode #-} + strP = + (\(ACR m cr) -> ACL m (CLFull cr)) <$> strP + <|> (\(ACSL m sl) -> ACL m (CLShort sl)) <$> strP + +instance ConnectionModeI m => ToJSON (ConnectionLink m) where + toEncoding = strToJEncoding + toJSON = strToJSON + +instance ConnectionModeI m => FromJSON (ConnectionLink m) where + parseJSON = strParseJSON "ConnectionLink" + instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i" @@ -1695,3 +1742,10 @@ $(J.deriveJSON (sumTypeJSON id) ''AgentErrorType) $(J.deriveJSON (enumJSON $ dropPrefix "QD") ''QueueDirection) $(J.deriveJSON (enumJSON $ dropPrefix "SP") ''SwitchPhase) + +instance ConnectionModeI m => FromJSON (CreatedConnLink m) where + parseJSON = $(J.mkParseJSON defaultJSON ''CreatedConnLink) + +instance ConnectionModeI m => ToJSON (CreatedConnLink m) where + toEncoding = $(J.mkToEncoding defaultJSON ''CreatedConnLink) + toJSON = $(J.mkToJSON defaultJSON ''CreatedConnLink) diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index 14ad526a5..0b7890ae7 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -28,10 +28,6 @@ deriving instance Eq ClientNtfCreds deriving instance Eq ShortLinkCreds -deriving instance Eq ContactConnType - -deriving instance Eq (ConnShortLink m) - deriving instance Show ProxiedRelay deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 2904f9576..f08ed48a6 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -60,7 +60,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad import Control.Monad.Except import Control.Monad.Reader -import Data.Bifunctor (first, second) +import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -252,8 +252,9 @@ inAnyOrder g rs = withFrozenCallStack $ do expected r rp = rp r createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c) -createConnection c userId enableNtfs cMode clientData = - fmap (second fst) . A.createConnection c userId enableNtfs cMode Nothing clientData (IKNoPQ PQSupportOn) +createConnection c userId enableNtfs cMode clientData subMode = do + (connId, CCLink cReq _) <- A.createConnection c userId enableNtfs cMode Nothing clientData (IKNoPQ PQSupportOn) subMode + pure (connId, cReq) joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured) joinConnection c userId enableNtfs cReq connInfo subMode = do @@ -615,7 +616,7 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured @@ -817,7 +818,7 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe + (_, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection @@ -861,7 +862,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do - (_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe + (_, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo sentMessages abPQEnc alice bobId bob bAliceId (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo @@ -914,7 +915,7 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () testRejectContactRequest :: HasCallStack => IO () testRejectContactRequest = withAgentClients2 $ \alice bob -> runRight_ $ do - (addrConnId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe + (addrConnId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection @@ -1085,7 +1086,7 @@ testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1113,7 +1114,7 @@ testInviationShortLinkAsync :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLinkAsync ps = withAgentClients2 $ \a b -> withSmpServer ps $ do let userData = "some user data" - (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1132,7 +1133,7 @@ testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (contactId, (connReq0, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1177,7 +1178,7 @@ testContactShortLink ps = testAddContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testAddContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do - (contactId, (connReq0, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe + (contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = "some user data" shortLink <- runRight $ setContactShortLink a contactId userData @@ -1901,7 +1902,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do - (bobId, (qInfo, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (CR.IKNoPQ pqSupport) SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (CR.IKNoPQ pqSupport) SMSubscribe aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index e39cb3449..b9958b28c 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -225,7 +225,7 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty 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, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True @@ -281,7 +281,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = -- agent connections have to be set up in advance -- otherwise the CONF messages would get mixed with MSG prePair alice bob = do - (bobId, (qInfo, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (bobId, CCLink qInfo Nothing) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True @@ -332,7 +332,7 @@ agentViaProxyVersionError = withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do - (_bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (_bobId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () @@ -352,7 +352,7 @@ agentViaProxyRetryOffline = do let pqEnc = CR.PQEncOn withServer $ \_ -> do (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do - (bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True From a2a4b80af405b1f869913118e8b3c0b569411c3a Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 5 Apr 2025 07:45:39 +0100 Subject: [PATCH 08/15] agent: padded encryption for link data, shorten/restore short links, tests (#1505) * agent: padded encryption for link data, tests * lambda * test short links via proxy * tests: server persistence with short links * rfc: group links * shorten, restore, test short links encoding * rfc --- rfcs/2025-04-04-short-links-for-groups.md | 103 +++++++++++++ src/Simplex/Messaging/Agent.hs | 8 +- src/Simplex/Messaging/Agent/Protocol.hs | 38 ++++- src/Simplex/Messaging/Crypto/ShortLink.hs | 41 +++-- src/Simplex/Messaging/Server/StoreLog.hs | 10 +- tests/AgentTests/ConnectionRequestTests.hs | 25 ++- tests/AgentTests/EqInstances.hs | 1 - tests/AgentTests/FunctionalAPITests.hs | 171 +++++++++++++++------ tests/AgentTests/ShortLinkTests.hs | 85 +++++++++- tests/CoreTests/MsgStoreTests.hs | 15 +- tests/CoreTests/StoreLogTests.hs | 24 +++ tests/SMPAgentClient.hs | 12 +- tests/SMPClient.hs | 11 ++ tests/SMPProxyTests.hs | 11 +- 14 files changed, 463 insertions(+), 92 deletions(-) create mode 100644 rfcs/2025-04-04-short-links-for-groups.md diff --git a/rfcs/2025-04-04-short-links-for-groups.md b/rfcs/2025-04-04-short-links-for-groups.md new file mode 100644 index 000000000..45f00d708 --- /dev/null +++ b/rfcs/2025-04-04-short-links-for-groups.md @@ -0,0 +1,103 @@ +# Using short links as group links + +## Problem + +To use the short links for groups these problems has to be / can be solved: +1. recognizing link as a group link. +2. permanent link with the ability to change chat relays. +3. binding owners signatures to the link. +4. allowing to add/remove owners, both to share ownership and for reliability in case of one owner losing keys/access. + +While current short links solve problems 1-3 (via contact type, and via extension of user data in the link), the problem 4 is solved only partially. + +We could include the current list of root owners in the user data, and we could send any history of ownership changes from this baseline as a short blockchain on joining the group, we still requrie one master owner to retain access to the queue associated with the group. + +## Possible solution approaches + +1. "Kick this can down the road" - ignore this problem until there is a namespace, and a group name can be associated with multiple queues. + +Pros: simple and reasonable, and it suggests postponing multisig for owners too. The users can still see the list of owners and their keys in user data of the link, and receive admin roster signed by owners on joining. + +Cons: if this "master owner" loses the access to the device, no further changes to group profile will be possible. + +2. The queue access can be shared by sharing the key and recipient IDs with all owners. + +The problems: +- preventing MITM attack between owners (this protect exists for other solutions too). +- protecting these credentials from chat relays. So somehow there should be direct key agreement between members allowing to send e2e encrypted message inaccessible to chat relays. + +Pros: simpler than alternatives, and still provides protection against losing the key. +Cons: +- quite clunky, and requires the new primitive anyway (e2e encryption). +- no multisig + +This could possibly be evolved into the requirement to have a direct connection with other owners, and verifying the security code before they have access to group. + +3. Allow "joint management" of SMP queues. + +SMP servers can support multiple recipients for contact queues:\ +- subscription would be possible to the "subscriber recipient". +- all other changes (update data, change subscriber recipient, add or remove recipients) would require multiple recipient signatures on SMP command in line with n-of-m multisig rules, that the command sender would have to collect out-of-band (from SMP protocol point of view). + +Pros: allows joint ownership, and protects from losing access to master owner device. +Cons: +- complicates queue abstraction with approach that is not needed for most queues. +- still retains the server as a single point of failure. + +4. Introduce "group" as a new type of entity managed by SMP servers. + +SMP servers would provide a separate set of commands for managing group records that would include in an encrypted container: +- the group profile +- the list of chat relay links +- the list of owner member IDs with their public keys +- multisig rules +- alternative group entity locations +- possibly, a globally unique group identity (as the hash of the initial/seed group data). + +While the server domain would be used as the hostname in group link, it may contain alternative hosts (not just hostnames of the same server), both in the link and in the group record data. + +Pros: separates additional complexity to where it is needed, allowing reliability and redundancy for group ownership. +Cons: complexity, coupling between SMP and chat protocol. + +## Design ideas for group as a separate entity type + +The last solution approach seems both the most long-term and also provides the best functionality, so maybe it could be an extensible base. + +Its advantage is that it does not require e2e encryption between owners, as only public keys are shared (although MITM is still possible without verification, mitigated by using multiple chat relays). + +The proposal is to have a new entity "asset", and a queue mode "asset". This entity represents a reference to some kind of digital asset, not part of SMP spec. Each link is managed by multiple owners, each represented with "asset" queue. + +The change from the current design is simple - splitting the link and data from the queue table/record into a separate table, so that the same link can be referenced by multiple queues with different owner IDs. Any of the linked asset queue recipients can modify link data and delete link. The protocol encoding could support multisig, but it can be added later with a separate protocol version. But it would alread allow having multiple owners for link. + +It is also probably correct to require that Ed25519 is used for recipient/owner authorization (and not X25519 authenticators that are used for senders). + +Question 1: should the same signature key be used for signing server commands and owner-owner comms? There may be a benefit in having two different keys, and in contexts visible to both server and owners use server key, and in contexts visible to owners only use signature key inside data. + +Question 2: should non-owners see server keys of owners? If not, does it suggest a third owner-only data blob? Or should the server simply maintain the currently signed ownership agreement? Or even the history of the agreement changes? + +Question 3: how would the owner validate the correctness of ownership changes - where this chain will be maintained? Should it maybe be replicated to all owners' "asset" queues? Or will it be a separate "chain" that will be truncated once all owners acknowledge the change? Almost like a separate queue? + +The protocol change required would be to make sender ID optional in LNK response. Alternatively, link could have its own sender ID and broadcast messages to link owners, and a rule whether messages can be sent without key, and whether this link can be secured with SKEY. Depending on queue type it would be: + +- "messaging" queue: can secure, can send messages. +- "contact" queue: cannot secure (only owner can secure), can send unsigned messages. +- "asset" queue: cannot secure, cannot send unsigned messages. + +To allow multiple delegates the queue could allow multiple send keys. In case of delegates (chat relays), we could require that only Ed25519 keys are used (for non-repudiation). + +The additional commands required would be to add, get and delete link owners: +- invite owner (OADD): adds some random server-generated new owner ID to link - this token with the current owner's signature will be included in NEW command (the signed token to be passed out of band). Separate table? +- remove owner (ODEL): remove owner from link by owner ID (both before and after new owner accepted ownership). +- get owners (OGET): get current owner IDs and their public keys. +- how would notification be delivered to the owner when s/he is removed? Some event? Possibly all changes are delivered as messages to each "owner's" asset queue, probably with longer expiration periods? + +While initially we don't need to build support for multisig in UX, it can be easily added later with this design. + +The flow then would be, for new "asset" queue with link - it is created as usual, with "NEW" command, and queueMode QMAsset that is passed linkId and link data. + +When additional owners want to be added to the group, they would have to create "link" type queue without link ID (thus preventing non-consensual ownership transfer). The flow would be this: +- group owner(s) offer to become additional owner with the specific new multisig rule, this is sent as a message in chat with signed ID from `OADD` command. +- the proposed owner will validate that this offer is signed according to the current multisig rule, by loading queue data and current owners (possibly via its ID from `OADD` command, that would also secure this owner ID). +- if the proposed owner accepts it, s/he will create a new "asset" queue linking it with the same link ID - the server would also accept signed owner ID as a confirmation. + +Alternatively, it could be an out-of-band exchange first, when existing owner sends an offer, the new owner accepts it and returns the key (and signed offer), and then this key is sent to the server by the old owner, returning owner ID to the new owner. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 44b95a48b..ee700af2e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -849,7 +849,7 @@ setContactShortLink' c connId userData = Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} -> do let (linkId, k) = SL.contactShortLinkKdf shortLinkKey unless (shortLinkId == linkId) $ throwE $ INTERNAL "setContactShortLink: link ID is not derived from link" - d <- liftIO $ SL.encryptData g k $ SL.encodeSignUserData linkPrivSigKey smpAgentVRange userData + d <- liftError id $ SL.encryptUserData g k $ SL.encodeSignUserData linkPrivSigKey smpAgentVRange userData pure (linkId, shortLinkKey, (linkEncFixedData, d)) Nothing -> do sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g @@ -857,7 +857,7 @@ setContactShortLink' c connId userData = connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] Nothing (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData (linkId, k) = SL.contactShortLinkKdf linkKey - srvData <- liftIO $ SL.encryptLinkData g k linkData + srvData <- liftError id $ SL.encryptLinkData g k linkData let slCreds = ShortLinkCreds linkId linkKey privSigKey (fst srvData) withStore' c $ \db -> updateShortLinkCreds db rq slCreds pure (linkId, linkKey, srvData) @@ -966,11 +966,11 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s qd <- case cMode of SCMContact -> do let (linkId, k) = SL.contactShortLinkKdf linkKey - srvData <- liftIO $ SL.encryptLinkData g k linkData + srvData <- liftError id $ SL.encryptLinkData g k linkData pure $ CQRContact $ Just CQRData {linkKey, privSigKey, srvReq = (linkId, (sndId, srvData))} SCMInvitation -> do let k = SL.invShortLinkKdf linkKey - srvData <- liftIO $ SL.encryptLinkData g k linkData + srvData <- liftError id $ SL.encryptLinkData g k linkData pure $ CQRMessaging $ Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)} pure (nonce, qUri, connReq, qd) connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (CreatedConnLink c) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 043f38688..eced35c08 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -154,6 +154,8 @@ module Simplex.Messaging.Agent.Protocol aMessageType, extraSMPServerHosts, updateSMPServerHosts, + shortenShortLink, + restoreShortLink, ) where @@ -166,6 +168,7 @@ import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isDigit) +import Data.Foldable (find) import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind (Type) @@ -1415,10 +1418,11 @@ instance ConnectionModeI m => StrEncoding (ConnShortLink m) where CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g" where encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType = - "https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> B64.encodeUnpadded kh <> "@" <> hosts <> B64.encodeUnpadded linkUri + "https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> khStr <> hosts <> B64.encodeUnpadded linkUri where port' = if null port then "" else B.pack (':' : port) hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/" + khStr = if B.null kh then "" else B64.encodeUnpadded kh <> "@" strP = do ACSL m l <- strP case testEquality m $ sConnectionMode @m of @@ -1431,7 +1435,7 @@ instance StrEncoding AConnShortLink where h <- "https://" *> strP port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure "" linkType <- A.char '/' *> A.anyChar - keyHash <- optional (A.char '/') *> A.char '#' *> strP <* A.char '@' + keyHash <- optional (A.char '/') *> A.char '#' *> (strP <* A.char '@' <|> pure (C.KeyHash "")) TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ []) linkUri <- strP let srv = SMPServer (h :| hs) port keyHash @@ -1449,6 +1453,36 @@ instance StrEncoding AConnShortLink where | B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k) | otherwise = fail "bad ConnShortLink: incorrect key length" +-- the servers passed to this function should be all preset servers, not servers configured by the user. +shortenShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m +shortenShortLink presetSrvs = \case + CSLInvitation srv lnkId linkKey -> CSLInvitation (shortServer srv) lnkId linkKey + CSLContact srv ct linkKey -> CSLContact (shortServer srv) ct linkKey + where + shortServer srv@(SMPServer hs@(h :| _) p kh) = + if isPresetServer then SMPServer [h] "" (C.KeyHash "") else srv + where + isPresetServer = case findPresetServer srv presetSrvs of + Just (SMPServer hs' p' kh') -> + all (`elem` hs') hs + && (p == p' || (null p' && (p == "443" || p == "5223"))) + && kh == kh' + Nothing -> False + +-- the servers passed to this function should be all preset servers, not servers configured by the user. +restoreShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m +restoreShortLink presetSrvs = \case + CSLInvitation srv lnkId linkKey -> CSLInvitation (fullServer srv) lnkId linkKey + CSLContact srv ct linkKey -> CSLContact (fullServer srv) ct linkKey + where + fullServer = \case + s@(SMPServer [_] "" (C.KeyHash "")) -> fromMaybe s $ findPresetServer s presetSrvs + s -> s + +findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer +findPresetServer ProtocolServer {host = h :| _} = find (\ProtocolServer {host = h' :| _} -> h == h') +{-# INLINE findPresetServer #-} + sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) = L.length qs == L.length qs' && all same (L.zip qs qs') diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index b617196d4..0c269bc20 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -5,9 +5,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module Simplex.Messaging.Crypto.ShortLink where +module Simplex.Messaging.Crypto.ShortLink + ( contactShortLinkKdf, + invShortLinkKdf, + encodeSignLinkData, + encodeSignUserData, + encryptLinkData, + encryptUserData, + decryptLinkData, + ) +where import Control.Concurrent.STM +import Control.Monad.Except +import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import Data.Bitraversable (bimapM) @@ -18,6 +29,13 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol (EntityId (..), LinkId, EncDataBytes (..), QueueLinkData) +import Simplex.Messaging.Util (liftEitherWith) + +fixedDataPaddedLength :: Int +fixedDataPaddedLength = 2008 -- 2048 - 24 (nonce) - 16 (auth tag) + +userDataPaddedLength :: Int +userDataPaddedLength = 13784 -- 13824 - 24 - 16 contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey) contactShortLinkKdf (LinkKey k) = @@ -40,16 +58,19 @@ encodeSignUserData pk agentVRange userData = encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString encodeSign pk s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s --- TODO [short links] possibly use padded encryption for fixed and for user data -encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> IO QueueLinkData -encryptLinkData g k = bimapM encrypt encrypt +encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> ExceptT AgentErrorType IO QueueLinkData +encryptLinkData g k = bimapM (encrypt fixedDataPaddedLength) (encrypt userDataPaddedLength) where - encrypt = encryptData g k + encrypt len = encryptData g k len -encryptData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> IO EncDataBytes -encryptData g k s = do - nonce <- atomically $ C.randomCbNonce g - pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s +encryptUserData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes +encryptUserData g k s = encryptData g k userDataPaddedLength s + +encryptData :: TVar ChaChaDRG -> C.SbKey -> Int -> ByteString -> ExceptT AgentErrorType IO EncDataBytes +encryptData g k len s = do + nonce <- liftIO $ atomically $ C.randomCbNonce g + ct <- liftEitherWith cryptoError $ C.sbEncrypt k nonce s len + pure $ EncDataBytes $ smpEncode nonce <> ct decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo) decryptLinkData linkKey k (encFD, encUD) = do @@ -65,7 +86,7 @@ decryptLinkData linkKey k (encFD, encUD) = do where decrypt (EncDataBytes d) = do (nonce, Tail ct) <- decode d - (sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecryptNoPad k nonce ct) + (sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct) (,s) <$> msgErr (C.decodeSignature sigBytes) decode :: Encoding a => ByteString -> Either AgentErrorType a decode = msgErr . smpDecode diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 5ed894d9e..104a89fe8 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -116,7 +116,7 @@ instance StrEncoding QueueRec where toQueueMode <$> (" sndSecure=" *> strP) <|> Just <$> (" queue_mode=" *> smpP) <|> pure Nothing -- unknown queue mode, we cannot imply that it is contact address - queueData <- optional $ (,) <$> (" link_id" *> strP) <*> (" queue_data" *> strP) + queueData <- optional $ (,) <$> (" link_id=" *> strP) <*> (" queue_data=" *> strP) notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP status <- (" status=" *> strP) <|> pure EntityActive @@ -127,8 +127,8 @@ instance StrEncoding QueueRec where instance StrEncoding SLRTag where strEncode = \case CreateQueue_ -> "CREATE" - CreateLink_ -> "CREATE_LINK" - DeleteLink_ -> "DELETE_LINK" + CreateLink_ -> "LINK" + DeleteLink_ -> "LDELETE" SecureQueue_ -> "SECURE" AddNotifier_ -> "NOTIFIER" SuspendQueue_ -> "SUSPEND" @@ -141,8 +141,8 @@ instance StrEncoding SLRTag where strP = A.choice [ "CREATE" $> CreateQueue_, - "CREATE_LINK" $> CreateLink_, - "DELETE_LINK" $> DeleteLink_, + "LINK" $> CreateLink_, + "LDELETE" $> DeleteLink_, "SECURE" $> SecureQueue_, "NOTIFIER" $> AddNotifier_, "SUSPEND" $> SuspendQueue_, diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 5465bca1b..458760a80 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -278,5 +278,28 @@ connectionRequestTests = smpEncodingTest contactAddress2queuesNew smpEncodingTest contactAddressV2 smpEncodingTest contactAddressClientData + it "should serialize / parse short links" $ do + CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/c#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact srv CCTGroup (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/g#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/c#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLInvitation srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/i#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLInvitation shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + it "should shorten / restore short links" $ do + shortenShortLink [srv] (CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + shortenShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv2] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") where - smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a \ No newline at end of file + smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a + +shortSrv :: SMPServer +shortSrv = SMPServer "smp.simplex.im" "" (C.KeyHash "") + +srv2 :: SMPServer +srv2 = SMPServer "smp2.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "" (C.KeyHash "\215m\248\251") diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index 0b7890ae7..6cc303513 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -6,7 +6,6 @@ module AgentTests.EqInstances where import Data.Type.Equality import Simplex.Messaging.Agent.Store -import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Client (ProxiedRelay (..)) instance Eq SomeConn where diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f08ed48a6..179653a9f 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -78,7 +78,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -89,7 +89,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) import Simplex.Messaging.Agent.Store.Interface import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig) 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 @@ -311,10 +311,14 @@ functionalAPITests ps = do it "should restore confirmation after client restart" $ testAllowConnectionClientRestart ps describe "Short connection links" $ do - it "should connect via 1-time short link" $ testInviationShortLink ps - it "should connect via 1-time short link with async join" $ testInviationShortLinkAsync ps - it "should connect via contact short link" $ testContactShortLink ps - it "should add short link to existing contact and connect" $ testAddContactShortLink ps + describe "should connect via 1-time short link" $ testProxyMatrix ps testInviationShortLink + describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync + describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink + describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink + describe "server restart" $ do + it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps + it "should connect via contact short link after restart" $ testContactShortLinkRestart ps + it "should connect via added contact short link after restart" $ testAddContactShortLinkRestart ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -500,8 +504,8 @@ canCreateQueue allowNew (srvAuth, _) (clntAuth, _) = testMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 ps runTest = do - it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 1 $ runTest PQSupportOff False False it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff False False @@ -509,8 +513,8 @@ testMatrix2 ps runTest = do testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2Stress ps runTest = do - it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn False True + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg initAgentServersProxy 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 initAgentServersProxy 1 $ runTest PQSupportOn False True it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 1 $ runTest PQSupportOff False False it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 1 $ runTest PQSupportOff False False @@ -529,17 +533,22 @@ testBasicMatrix2 ps runTest = do testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 ps runTest = do - it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True it "ratchet current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False it "ratchet prev" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False testServerMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec -testServerMatrix2 ps@(t, ASType qs _ms) runTest = do +testServerMatrix2 ps runTest = do it "1 server" $ withSmpServer ps $ runTest initAgentServers - it "2 servers" $ withSmpServer ps $ withSmpServerConfigOn t (cfgJ2QS qs) testPort2 $ \_ -> runTest initAgentServers2 + it "2 servers" $ withSmpServers2 ps $ runTest initAgentServers2 + +testProxyMatrix :: HasCallStack => (ATransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec +testProxyMatrix ps runTest = do + it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 initAgentServers initAgentServers2 $ runTest False + it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 initAgentServersProxy initAgentServersProxy2 $ runTest True testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True @@ -557,7 +566,7 @@ pqMatrix2_ pqInv ps 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 ps . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 + runTest = withSmpServerProxy ps . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 testPQMatrix3 :: HasCallStack => @@ -578,7 +587,7 @@ testPQMatrix3 ps test = do withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId - servers = initAgentServersProxy SPMAlways SPFProhibit + servers = initAgentServersProxy runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers @@ -595,6 +604,12 @@ withAgentClientsCfgServers2 aCfg bCfg servers runTest = withAgent 2 bCfg servers testDB2 $ \b -> runTest a b +withAgentClientsServers2 :: HasCallStack => InitialAgentServers -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsServers2 aServers bServers runTest = + withAgent 1 agentCfg aServers testDB $ \a -> + withAgent 2 agentCfg bServers testDB2 $ \b -> + runTest a b + withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers {-# INLINE withAgentClientsCfg2 #-} @@ -1082,9 +1097,9 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do disposeAgentClient alice2 disposeAgentClient bob -testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () -testInviationShortLink ps = - withAgentClients3 $ \a b c -> withSmpServer ps $ do +testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testInviationShortLink viaProxy a b = + withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = "some user data" (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink @@ -1108,30 +1123,29 @@ testInviationShortLink ps = get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsViaProxy viaProxy a bId b aId -testInviationShortLinkAsync :: HasCallStack => (ATransport, AStoreType) -> IO () -testInviationShortLinkAsync ps = - withAgentClients2 $ \a b -> withSmpServer ps $ do - let userData = "some user data" - (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink - strDecode (strEncode shortLink) `shouldBe` Right shortLink - connReq' `shouldBe` connReq - userData' `shouldBe` userData - runRight $ do - aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe - get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False - ("", _, CONF confId _ "bob's connInfo") <- get a - allowConnection a bId confId "alice's connInfo" - get a ##> ("", bId, CON) - get b ##> ("", aId, INFO "alice's connInfo") - get b ##> ("", aId, CON) - exchangeGreetings a bId b aId +testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testInviationShortLinkAsync viaProxy a b = do + let userData = "some user data" + (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + runRight $ do + aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe + get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetingsViaProxy viaProxy a bId b aId -testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () -testContactShortLink ps = - withAgentClients3 $ \a b c -> withSmpServer ps $ do +testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testContactShortLink viaProxy a b = + withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = "some user data" (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) @@ -1159,7 +1173,7 @@ testContactShortLink ps = get a ##> ("", bId, INFO "bob's connInfo") get a ##> ("", bId, CON) get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsViaProxy viaProxy a bId b aId -- update user data let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData @@ -1175,9 +1189,9 @@ testContactShortLink ps = Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink pure () -testAddContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () -testAddContactShortLink ps = - withAgentClients3 $ \a b c -> withSmpServer ps $ do +testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testAddContactShortLink viaProxy a b = + withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do (contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = "some user data" @@ -1206,7 +1220,7 @@ testAddContactShortLink ps = get a ##> ("", bId, INFO "bob's connInfo") get a ##> ("", bId, CON) get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsViaProxy viaProxy a bId b aId -- update user data let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData @@ -1215,6 +1229,59 @@ testAddContactShortLink ps = connReq4 `shouldBe` connReq updatedData' `shouldBe` updatedData +testInviationShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do + let userData = "some user data" + (bId, CCLink connReq (Just shortLink)) <- withSmpServer ps $ + runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate + withSmpServer ps $ do + runRight_ $ subscribeConnection a bId + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + +testContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do + let userData = "some user data" + (contactId, CCLink connReq0 (Just shortLink)) <- withSmpServer ps $ + runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate + Right connReq <- pure $ smpDecode (smpEncode connReq0) + let updatedData = "updated user data" + withSmpServer ps $ do + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + -- update user data + shortLink' <- runRight $ setContactShortLink a contactId updatedData + shortLink' `shouldBe` shortLink + withSmpServer ps $ do + (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + connReq4 `shouldBe` connReq + updatedData' `shouldBe` updatedData + +testAddContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do + let userData = "some user data" + ((contactId, CCLink connReq0 Nothing), shortLink) <- withSmpServer ps $ runRight $ do + r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate + (r,) <$> setContactShortLink a contactId userData + Right connReq <- pure $ smpDecode (smpEncode connReq0) + let updatedData = "updated user data" + withSmpServer ps $ do + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + -- update user data + shortLink' <- runRight $ setContactShortLink a contactId updatedData + shortLink' `shouldBe` shortLink + withSmpServer ps $ do + (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + connReq4 `shouldBe` connReq + updatedData' `shouldBe` updatedData + testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB @@ -3483,16 +3550,22 @@ exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> Agen exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetingsMsgId_ pqEnc msgId alice bobId bob aliceId = do +exchangeGreetingsMsgId_ = exchangeGreetingsViaProxyMsgId_ False + +exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () +exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 + +exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () +exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc msgId alice bobId bob aliceId = do msgId1 <- A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello" liftIO $ msgId1 `shouldBe` (msgId, pqEnc) - get alice ##> ("", bobId, SENT msgId) + get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == msgId && viaProxy == isJust srv_; _ -> False get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == msgId && pq == pqEnc; _ -> False ackMessage bob aliceId msgId Nothing msgId2 <- A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too" let msgId' = msgId + 1 liftIO $ msgId2 `shouldBe` (msgId', pqEnc) - get bob ##> ("", aliceId, SENT msgId') + get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == msgId' && viaProxy == isJust srv_; _ -> False get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == msgId' && pq == pqEnc; _ -> False ackMessage alice bobId msgId' Nothing diff --git a/tests/AgentTests/ShortLinkTests.hs b/tests/AgentTests/ShortLinkTests.hs index d46ab6135..3fd1033fd 100644 --- a/tests/AgentTests/ShortLinkTests.hs +++ b/tests/AgentTests/ShortLinkTests.hs @@ -6,16 +6,22 @@ module AgentTests.ShortLinkTests (shortLinkTests) where import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) import Control.Concurrent.STM -import Simplex.Messaging.Agent.Protocol (supportedSMPAgentVRange) +import Control.Monad.Except +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), supportedSMPAgentVRange) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.ShortLink as SL import Test.Hspec --- TODO [short tests] tests failures shortLinkTests :: Spec shortLinkTests = do - it "should encrypt and decrypt invitation short link data" testInvShortLink - it "should encrypt and decrypt contact short link data" testContactShortLink + describe "invitation short link" $ do + it "should encrypt and decrypt link data" testInvShortLink + it "should fail to decrypt invitation data with bad hash" testInvShortLinkBadDataHash + describe "contact short link" $ do + it "should encrypt and decrypt data" testContactShortLink + it "should encrypt updated user data" testUpdateContactShortLink + it "should fail to decrypt contact data with bad hash" testContactShortLinkBadDataHash + it "should fail to decrypt contact data with bad signature" testContactShortLinkBadSignature testInvShortLink :: IO () testInvShortLink = do @@ -25,12 +31,27 @@ testInvShortLink = do let userData = "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData k = SL.invShortLinkKdf linkKey - srvData <- SL.encryptLinkData g k linkData + Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` invConnRequest userData' `shouldBe` userData +testInvShortLinkBadDataHash :: IO () +testInvShortLinkBadDataHash = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData + -- different key + linkKey <- LinkKey <$> atomically (C.randomBytes 32 g) + let k = SL.invShortLinkKdf linkKey + Right srvData <- runExceptT $ SL.encryptLinkData g k linkData + -- decryption fails + SL.decryptLinkData @'CMInvitation linkKey k srvData + `shouldBe` Left (AGENT (A_LINK "link data hash")) + testContactShortLink :: IO () testContactShortLink = do -- encrypt @@ -39,8 +60,60 @@ testContactShortLink = do let userData = "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData (_linkId, k) = SL.contactShortLinkKdf linkKey - srvData <- SL.encryptLinkData g k linkData + Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` contactConnRequest userData' `shouldBe` userData + +testUpdateContactShortLink :: IO () +testUpdateContactShortLink = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData + (_linkId, k) = SL.contactShortLinkKdf linkKey + Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData + -- encrypt updated user data + let updatedUserData = "updated user data" + signed = SL.encodeSignUserData (snd sigKeys) supportedSMPAgentVRange updatedUserData + Right ud' <- runExceptT $ SL.encryptUserData g k signed + -- decrypt + Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k (fd, ud') + connReq `shouldBe` contactConnRequest + userData' `shouldBe` updatedUserData + +testContactShortLinkBadDataHash :: IO () +testContactShortLinkBadDataHash = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData + -- different key + linkKey <- LinkKey <$> atomically (C.randomBytes 32 g) + let (_linkId, k) = SL.contactShortLinkKdf linkKey + Right srvData <- runExceptT $ SL.encryptLinkData g k linkData + -- decryption fails + SL.decryptLinkData @'CMContact linkKey k srvData + `shouldBe` Left (AGENT (A_LINK "link data hash")) + +testContactShortLinkBadSignature :: IO () +testContactShortLinkBadSignature = do + -- encrypt + g <- C.newRandom + sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g + let userData = "some user data" + (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData + (_linkId, k) = SL.contactShortLinkKdf linkKey + Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData + -- encrypt updated user data + let updatedUserData = "updated user data" + -- another signature key + (_, pk) <- atomically $ C.generateKeyPair @'C.Ed25519 g + let signed = SL.encodeSignUserData pk supportedSMPAgentVRange updatedUserData + Right ud' <- runExceptT $ SL.encryptUserData g k signed + -- decryption fails + SL.decryptLinkData @'CMContact linkKey k (fd, ud') + `shouldBe` Left (AGENT (A_LINK "user data signature")) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index a110ec9d8..1b83526f1 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -31,7 +31,7 @@ import Data.Time.Clock (addUTCTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (EntityId (..), Message (..), RecipientId, SParty (..), noMsgFlags) +import Simplex.Messaging.Protocol (EntityId (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags) import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats) import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth, readWriteQueueStore) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch) @@ -111,9 +111,12 @@ deriving instance Eq (JournalState t) deriving instance Eq (SJournalType t) testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec) -testNewQueueRec g qm = do - rId <- atomically $ EntityId <$> C.randomBytes 24 g - senderId <- atomically $ EntityId <$> C.randomBytes 24 g +testNewQueueRec g qm = testNewQueueRecData g qm Nothing + +testNewQueueRecData :: TVar ChaChaDRG -> QueueMode -> Maybe (LinkId, QueueLinkData) -> IO (RecipientId, QueueRec) +testNewQueueRecData g qm queueData = do + rId <- rndId + senderId <- rndId (recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g let qr = @@ -123,12 +126,14 @@ testNewQueueRec g qm = do senderId, senderKey = Nothing, queueMode = Just qm, - queueData = Nothing, + queueData, notifier = Nothing, status = EntityActive, updatedAt = Nothing } pure (rId, qr) + where + rndId = atomically $ EntityId <$> C.randomBytes 24 g -- TODO constrain to STM stores testGetQueue :: MsgStoreClass s => s -> IO () diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index d05f689c1..00e945675 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -59,6 +59,12 @@ storeLogTests = ((rId, qr), ntfCreds, date) <- runIO $ do g <- C.newRandom (,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate + ((rId', qr'), lnkId, qd) <- runIO $ do + g <- C.newRandom + lnkId <- atomically $ EntityId <$> C.randomBytes 24 g + let qd = (EncDataBytes "fixed data", EncDataBytes "user data") + q <- testNewQueueRecData g qm (Just (lnkId, qd)) + pure (q, lnkId, qd) testSMPStoreLog ("SMP server store log, queueMode = " <> show qm) [ SLTC @@ -67,6 +73,24 @@ storeLogTests = compacted = [CreateQueue rId qr], state = M.fromList [(rId, qr)] }, + SLTC + { name = "create new queue with link data", + saved = [CreateQueue rId' qr'], + compacted = [CreateQueue rId' qr'], + state = M.fromList [(rId', qr')] + }, + SLTC + { name = "create new queue, add link data", + saved = [CreateQueue rId' qr' {queueData = Nothing}, CreateLink rId' lnkId qd], + compacted = [CreateQueue rId' qr'], + state = M.fromList [(rId', qr')] + }, + SLTC + { name = "create new queue with link data, delete data", + saved = [CreateQueue rId' qr', DeleteLink rId'], + compacted = [CreateQueue rId' qr' {queueData = Nothing}], + state = M.fromList [(rId', qr' {queueData = Nothing})] + }, SLTC { name = "secure queue", saved = [CreateQueue rId qr, SecureQueue rId testPublicAuthKey], diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index fc66f2ab1..2903de05c 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -20,7 +20,7 @@ import SMPClient (proxyVRangeV8, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer) import Simplex.Messaging.Transport @@ -71,10 +71,16 @@ initAgentServers = initAgentServers2 :: InitialAgentServers initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]} -initAgentServersProxy :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers -initAgentServersProxy smpProxyMode smpProxyFallback = +initAgentServersProxy :: InitialAgentServers +initAgentServersProxy = initAgentServersProxy_ SPMAlways SPFProhibit + +initAgentServersProxy_ :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers +initAgentServersProxy_ smpProxyMode smpProxyFallback = initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}} +initAgentServersProxy2 :: InitialAgentServers +initAgentServersProxy2 = initAgentServersProxy {smp = userServers [testSMPServer2]} + agentCfg :: AgentConfig agentCfg = defaultAgentConfig diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6ee05c27b..07dc60723 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -259,6 +259,11 @@ proxyCfgMS msType = proxyCfgJ2 :: ServerConfig proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 +proxyCfgJ2QS :: SQSType s -> ServerConfig +proxyCfgJ2QS = \case + SQSMemory -> journalCfg (proxyCfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 + SQSPostgres -> journalCfgDB (proxyCfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 + proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion @@ -305,6 +310,12 @@ withSmpServer ps = withSmpServerOn ps testPort withSmpServerProxy :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const +withSmpServers2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const + +withSmpServersProxy2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const + runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index b9958b28c..7ef66544e 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -53,7 +53,6 @@ import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif --- TODO [short links] secure and get links via proxy smpProxyTests :: SpecWith AStoreType smpProxyTests = do describe "server configuration" $ do @@ -258,7 +257,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b where msgId = subtract baseId . fst aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} - servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers srvs} + servers (srvs, smpProxyMode, _) = (initAgentServersProxy_ smpProxyMode SPFAllow) {smp = userServers srvs} agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () agentDeliverMessagesViaProxyConc agentServers msgs = @@ -325,7 +324,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = logDebug "run finished" pqEnc = CR.PQEncOn aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} - servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers srvs} + servers srvs = (initAgentServersProxy_ SPMAlways SPFAllow) {smp = userServers srvs} agentViaProxyVersionError :: IO () agentViaProxyVersionError = @@ -337,7 +336,7 @@ agentViaProxyVersionError = A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () where - servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs} + servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs} agentViaProxyRetryOffline :: IO () agentViaProxyRetryOffline = do @@ -409,7 +408,7 @@ agentViaProxyRetryOffline = do aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} baseId = 1 msgId = subtract baseId . fst - servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} + servers srv = initAgentServersProxy {smp = userServers [srv]} agentViaProxyRetryNoSession :: IO () agentViaProxyRetryNoSession = do @@ -429,7 +428,7 @@ agentViaProxyRetryNoSession = do pure () where withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 - servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} + servers srv = initAgentServersProxy {smp = userServers [srv]} testNoProxy :: AStoreType -> IO () testNoProxy msType = do From b7a9542213e47829c113d390fc49efeafb55ee92 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 10 Apr 2025 19:09:47 +0100 Subject: [PATCH 09/15] smp server: short links and owners for channels (#1506) * smp server: short links and owners for channels * types * support mutliple rcv keys * fix down migration, test/create server schema dump * reduce schema dump * parameterize type for link data by connection type * return full connection link data * test version * change short link encoding * test: print pg_dump output * server pages, link encoding * fix connection request when queue data and sender ID are created for old servers * test, change pattern * ci: install postgresql tools in runner (#1507) * ci: install postgresql tools in runner * ci: docker shell abort on error * fix pattern for ghc 8.10.7 * patch ConnReqUriData SMP encoding to preserve queue mode after decoding * test for RKEY * fix/test store log with RKEY --------- Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> --- .github/workflows/build.yml | 17 +- apps/smp-server/static/a/index.html | 1 + apps/smp-server/static/c/index.html | 1 + apps/smp-server/static/i/index.html | 1 + apps/smp-server/web/Static.hs | 13 +- rfcs/2025-04-04-short-links-for-groups.md | 108 +++++-- simplexmq.cabal | 11 +- src/Simplex/Messaging/Agent.hs | 25 +- src/Simplex/Messaging/Agent/Protocol.hs | 266 +++++++++++++----- src/Simplex/Messaging/Crypto.hs | 17 ++ src/Simplex/Messaging/Crypto/ShortLink.hs | 42 +-- src/Simplex/Messaging/Protocol.hs | 8 + src/Simplex/Messaging/Server.hs | 11 +- .../Messaging/Server/MsgStore/Journal.hs | 2 + src/Simplex/Messaging/Server/QueueStore.hs | 3 +- .../Messaging/Server/QueueStore/Postgres.hs | 48 ++-- .../Server/QueueStore/Postgres/Migrations.hs | 27 +- .../QueueStore/Postgres/server_schema.sql | 74 +++++ .../Messaging/Server/QueueStore/STM.hs | 9 + .../Messaging/Server/QueueStore/Types.hs | 2 + src/Simplex/Messaging/Server/StoreLog.hs | 19 +- .../Messaging/Server/StoreLog/ReadWrite.hs | 1 + tests/AgentTests/ConnectionRequestTests.hs | 121 +++++--- tests/AgentTests/EqInstances.hs | 9 + tests/AgentTests/FunctionalAPITests.hs | 124 ++++---- tests/AgentTests/SchemaDump.hs | 6 - tests/AgentTests/ShortLinkTests.hs | 15 +- tests/CoreTests/MsgStoreTests.hs | 5 +- tests/CoreTests/StoreLogTests.hs | 14 +- tests/ServerTests.hs | 34 +++ tests/ServerTests/SchemaDump.hs | 98 +++++++ tests/Test.hs | 7 +- 32 files changed, 870 insertions(+), 269 deletions(-) create mode 120000 apps/smp-server/static/a/index.html create mode 120000 apps/smp-server/static/c/index.html create mode 120000 apps/smp-server/static/i/index.html create mode 100644 src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql create mode 100644 tests/ServerTests/SchemaDump.hs diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 451de173b..8ee1d75ec 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -48,6 +48,19 @@ jobs: - name: Set up Docker Buildx uses: simplex-chat/docker-setup-buildx-action@v3 + - name: Install PostgreSQL 15 client tools + if: matrix.os == '22.04' + shell: bash + run: | + # Import the repository signing key + sudo install -d /usr/share/postgresql-common/pgdg + sudo curl -o /usr/share/postgresql-common/pgdg/apt.postgresql.org.asc --fail https://www.postgresql.org/media/keys/ACCC4CF8.asc + # Add the PostgreSQL APT repository + sudo sh -c 'echo "deb [signed-by=/usr/share/postgresql-common/pgdg/apt.postgresql.org.asc] https://apt.postgresql.org/pub/repos/apt $(lsb_release -cs)-pgdg main" > /etc/apt/sources.list.d/pgdg.list' + # Update repository and install postgresql tools + sudo apt update + sudo apt -y install postgresql-client-15 + - name: Build and cache Docker image uses: simplex-chat/docker-build-push-action@v6 with: @@ -82,7 +95,7 @@ jobs: build/${{ matrix.platform_name }}:latest - name: Build smp-server (postgresql) and tests - shell: docker exec -t builder sh {0} + shell: docker exec -t builder sh -eu {0} run: | cabal update cabal build --jobs=$(nproc) --enable-tests -fserver_postgres @@ -106,7 +119,7 @@ jobs: docker cp builder:/out/smp-server ./smp-server-postgres-ubuntu-${{ matrix.platform_name }} - name: Build everything else (standard) - shell: docker exec -t builder sh {0} + shell: docker exec -t builder sh -eu {0} run: | cabal build --jobs=$(nproc) mkdir -p /out diff --git a/apps/smp-server/static/a/index.html b/apps/smp-server/static/a/index.html new file mode 120000 index 000000000..fbab335f5 --- /dev/null +++ b/apps/smp-server/static/a/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/static/c/index.html b/apps/smp-server/static/c/index.html new file mode 120000 index 000000000..fbab335f5 --- /dev/null +++ b/apps/smp-server/static/c/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/static/i/index.html b/apps/smp-server/static/i/index.html new file mode 120000 index 000000000..fbab335f5 --- /dev/null +++ b/apps/smp-server/static/i/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index c4a3e84f7..8d85c4b7f 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -84,11 +84,16 @@ generateSite si onionHost sitePath = do B.writeFile (sitePath "index.html") $ serverInformation si onionHost createDirectoryIfMissing True $ sitePath "media" forM_ E.mediaContent $ \(path, bs) -> B.writeFile (sitePath "media" path) bs - createDirectoryIfMissing True $ sitePath "contact" - B.writeFile (sitePath "contact" "index.html") E.linkHtml - createDirectoryIfMissing True $ sitePath "invitation" - B.writeFile (sitePath "invitation" "index.html") E.linkHtml + createLinkPage "contact" + createLinkPage "invitation" + createLinkPage "a" + createLinkPage "c" + createLinkPage "i" logInfo $ "Generated static site contents at " <> tshow sitePath + where + createLinkPage path = do + createDirectoryIfMissing True $ sitePath path + B.writeFile (sitePath path "index.html") E.linkHtml serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs diff --git a/rfcs/2025-04-04-short-links-for-groups.md b/rfcs/2025-04-04-short-links-for-groups.md index 45f00d708..90938acec 100644 --- a/rfcs/2025-04-04-short-links-for-groups.md +++ b/rfcs/2025-04-04-short-links-for-groups.md @@ -59,45 +59,101 @@ While the server domain would be used as the hostname in group link, it may cont Pros: separates additional complexity to where it is needed, allowing reliability and redundancy for group ownership. Cons: complexity, coupling between SMP and chat protocol. -## Design ideas for group as a separate entity type +## Design for channel/group as a separate queue mode -The last solution approach seems both the most long-term and also provides the best functionality, so maybe it could be an extensible base. +Option 1. -Its advantage is that it does not require e2e encryption between owners, as only public keys are shared (although MITM is still possible without verification, mitigated by using multiple chat relays). +A queue mode "channel" when owners are represented by their individual queues (either a separate mode, or a submode of "channel", or just normal contact address queues). In this case sending message to channel queue would broadcast message to queue owners, without exposing even the number of owners. -The proposal is to have a new entity "asset", and a queue mode "asset". This entity represents a reference to some kind of digital asset, not part of SMP spec. Each link is managed by multiple owners, each represented with "asset" queue. +Pros: +- allows chat relays to send messages to all owners (e.g., channel can be secured with the list of snd keys, one per relay). +- quite easy to evolve from the current design. +- extensible. +Cons: +- close to "solution in search of a problem". +- does not require data model changes - channel queue would simply have a list of owner "recipient IDs", and each owner queue would also point to channel. -The change from the current design is simple - splitting the link and data from the queue table/record into a separate table, so that the same link can be referenced by multiple queues with different owner IDs. Any of the linked asset queue recipients can modify link data and delete link. The protocol encoding could support multisig, but it can be added later with a separate protocol version. But it would alread allow having multiple owners for link. +Option 2. -It is also probably correct to require that Ed25519 is used for recipient/owner authorization (and not X25519 authenticators that are used for senders). +Also a separate queue mode "channel", but instead of having a linked owner queues, it would simply maintain a list of owner keys to maintain the data. In this case, messages cannot be sent to this "queue" at all. -Question 1: should the same signature key be used for signing server commands and owner-owner comms? There may be a benefit in having two different keys, and in contexts visible to both server and owners use server key, and in contexts visible to owners only use signature key inside data. +Pros: +- simpler design. +- we could allow sending messages to it too, with the "main" owner receiving them. This could be negotiated in the protocol. +- it may be easier to migrate the current groups, as the admin link would be this queue (although for public groups in directory it would have to be recreated anyway). +- Possibly, when queue is created there should be a flag whether it should accept unsigned messages - then contact addresses would be created with unsigned messages ON, messages queues, once SKEY is universally supported, with unsigned messages OFF, and channel queues with unsigned messages OFF too for new public queues. +Cons: +- if no messages are accepted, this is not even a queue. +- no way to directly contact owners (maybe it is not a downside, as for relays there would be a communication channel anyway as part of the group). -Question 2: should non-owners see server keys of owners? If not, does it suggest a third owner-only data blob? Or should the server simply maintain the currently signed ownership agreement? Or even the history of the agreement changes? +Option 2 looks more simple and attractive, implementing server broadcast for SMP seems unnecessary, as while it could have been used for simple groups, it does not solve such problems as spam and pre-moderation anyway - it requires a higher level protocol. -Question 3: how would the owner validate the correctness of ownership changes - where this chain will be maintained? Should it maybe be replicated to all owners' "asset" queues? Or will it be a separate "chain" that will be truncated once all owners acknowledge the change? Almost like a separate queue? +The command to update owner keys would be `RKEY` with the list of keys, and we can make `NEW` accept multiple keys too, although the use case here is less clear. -The protocol change required would be to make sender ID optional in LNK response. Alternatively, link could have its own sender ID and broadcast messages to link owners, and a rule whether messages can be sent without key, and whether this link can be secured with SKEY. Depending on queue type it would be: +## Multiple owners managing queue data. -- "messaging" queue: can secure, can send messages. -- "contact" queue: cannot secure (only owner can secure), can send unsigned messages. -- "asset" queue: cannot secure, cannot send unsigned messages. +Option 1: Use the same keys in SMP as when signing queue data. -To allow multiple delegates the queue could allow multiple send keys. In case of delegates (chat relays), we could require that only Ed25519 keys are used (for non-repudiation). +Option 2: Use different keys. -The additional commands required would be to add, get and delete link owners: -- invite owner (OADD): adds some random server-generated new owner ID to link - this token with the current owner's signature will be included in NEW command (the signed token to be passed out of band). Separate table? -- remove owner (ODEL): remove owner from link by owner ID (both before and after new owner accepted ownership). -- get owners (OGET): get current owner IDs and their public keys. -- how would notification be delivered to the owner when s/he is removed? Some event? Possibly all changes are delivered as messages to each "owner's" asset queue, probably with longer expiration periods? +The value here could be that the server could validate these signatures too, and also maintain the chain of key changes. While tempting, it is probably unnecessary, and this chain of ownership is better to be maintained on chat relay level, as there are no size constraints on the size of this chain. Also, it is better for metadata privacy to not couple transport and chat protocol keys. -While initially we don't need to build support for multisig in UX, it can be easily added later with this design. +We still need to bind the mutable data updates to the "genesis" signature key (the one included in the immutable data). -The flow then would be, for new "asset" queue with link - it is created as usual, with "NEW" command, and queueMode QMAsset that is passed linkId and link data. +The proposed design: -When additional owners want to be added to the group, they would have to create "link" type queue without link ID (thus preventing non-consensual ownership transfer). The flow would be this: -- group owner(s) offer to become additional owner with the specific new multisig rule, this is sent as a message in chat with signed ID from `OADD` command. -- the proposed owner will validate that this offer is signed according to the current multisig rule, by loading queue data and current owners (possibly via its ID from `OADD` command, that would also secure this owner ID). -- if the proposed owner accepts it, s/he will create a new "asset" queue linking it with the same link ID - the server would also accept signed owner ID as a confirmation. +- when mutable data is signed by genesis key, then it is bound, and no changes is needed. +- mutable data may be signed by the key of the new owner, in which case mutable part itself must contain the binding. We could also use ring signature to sign the mutable data, concealing which owner signed the data - that would increase the signature size from 64 bytes to `32 * (n + 1)` bytes. -Alternatively, it could be an out-of-band exchange first, when existing owner sends an offer, the new owner accepts it and returns the key (and signed offer), and then this key is sent to the server by the old owner, returning owner ID to the new owner. +Current mutable data: + +```haskell +data UserLinkData = UserLinkData + { agentVRange :: VersionRangeSMPA, + userData :: ConnInfo + } +``` + +Proposed mutable data: + +```haskell +data UserLinkData = UserLinkData + { agentVRange :: VersionRangeSMPA, + owners :: [OwnerInfo] + userData :: ConnInfo + } + +type OwnerId = ByteString + +data OwnerInfo = OwnerInfo + { ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId + ownerKey :: PublicKeyEd25519, + -- owner signature of sender ID, + -- confirms that the owner agreed with being the owner, + -- prevents a member being added as an owner without consent. + ownerSig :: SignatureEd25519, + -- owner authorization, sig(ownerId || ownerKey, prevKey), where prevKey is either a "genesis key" or some other key previously signed by the genesis key. + authOwnerId :: OwnerId, -- null for "genesis" + authOwnerSig :: SignatureEd25519 + } +``` + +The size of the OwnerInfo record encoding is: +- ownerId: 1 + 12 +- ownerKey: 1 + 32 +- ownerSig: 1 + 64 +- ownerAuthId: 1 + 12 +- ownerAuthSig: 1 + 64 + +~189 bytes, so we should practically limit the number of owners to say 8 - 1 original + 7 addiitonal. Original creator could use a different key as a "genesis" key, to conceal creator identity from other members, and it needs to include the record with memberId anyway. + +The structure is simplified, and it does not allow arbitrary ownership changes. Its purpose is not to comprehensively manage ownership changes - while it is possible with a generic blockchain, it seems not appropriate at this stage, - but rather to ensure access continuity and that the server cannot modify the data (although nothing prevents the server from removing the data completely or from serving the previous version of the data). + +For example it would only allow any given owner to remove subsequenty added owners, preserving the group link and identity, but it won't allow removing owners that signed this owner authorization. So owners are not equal, with the creator having the highest rank and being able to remove all additional owners, and owners authorise by creator can remove all other owners but themselves and creator, and so on - they have to maintain the chain that authorized themselves, at least. We could explicitely include owner rank into OwnerInfo, or we could require that they are sorted by rank, or the rank can be simply derived from signatures. + +When additional owners want to be added to the group, they would have to provide any of the current owners: +- the key for SMP commands authorization - this will be passed to SMP server together with other keys. There could be either RKEY to pass all keys (some risk to miss some, or of race conditions), or RADD/RGET/RDEL to add and remove recipient keys, which has no risk of race conditions. +- the signature of the immutable data by their member key included in their profile. +- the current owner would then include their member key into the queue data, and update it with LSET command. In any case there should be some simple consensus protocol between owners for owner changes, and it has to be maintained as a blockchain by owners and by chat relays, as otherwise it may lead to race conditions with LSET command. + +Potentially, there could be one command to update keys and link data, so that they are consistent. diff --git a/simplexmq.cabal b/simplexmq.cabal index d1f30a2b9..677342ddc 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -482,6 +482,9 @@ test-suite simplexmq-test other-modules: AgentTests.SchemaDump AgentTests.SQLiteTests + if flag(server_postgres) + other-modules: + ServerTests.SchemaDump hs-source-dirs: tests apps/smp-server/web @@ -538,10 +541,12 @@ test-suite simplexmq-test cpp-options: -DdbPostgres else build-depends: - deepseq ==1.4.* - , memory - , process + memory , sqlcipher-simple + if !flag(client_postgres) || flag(server_postgres) + build-depends: + deepseq ==1.4.* + , process if flag(client_postgres) || flag(server_postgres) build-depends: postgresql-simple ==0.7.* diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index dd457ebb0..34d6bbc97 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -200,6 +200,7 @@ import Simplex.Messaging.Protocol MsgFlags (..), NtfServer, ProtoServerWithAuth (..), + ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), QueueLinkData, @@ -379,7 +380,7 @@ deleteContactShortLink c = withAgentEnv c . deleteContactShortLink' c {-# INLINE deleteContactShortLink #-} -- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries -getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo) +getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c) getConnShortLink c = withAgentEnv c .: getConnShortLink' c {-# INLINE getConnShortLink #-} @@ -838,7 +839,7 @@ setContactShortLink' c connId userData = SomeConn _ (ContactConnection _ rq) -> do (lnkId, linkKey, d) <- prepareLinkData rq addQueueLink c rq lnkId d - pure $ CSLContact (qServer rq) CCTContact linkKey + pure $ CSLContact SLSServer CCTContact (qServer rq) linkKey _ -> throwE $ CMD PROHIBITED "setContactShortLink: not contact address" where prepareLinkData :: RcvQueue -> AM (SMP.LinkId, LinkKey, QueueLinkData) @@ -870,9 +871,9 @@ deleteContactShortLink' c connId = _ -> throwE $ CMD PROHIBITED "deleteContactShortLink: not contact address" -- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. -getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) +getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c) getConnShortLink' c userId = \case - CSLInvitation srv linkId linkKey -> do + CSLInvitation _ srv linkId linkKey -> do g <- asks random invLink <- withStore' c $ \db -> do getInvShortLink db srv linkId >>= \case @@ -886,20 +887,22 @@ getConnShortLink' c userId = \case ld@(sndId, _) <- secureGetQueueLink c userId invLink withStore' c $ \db -> setInvShortLinkSndId db invLink sndId decryptData srv linkKey k ld - CSLContact srv _ linkKey -> do + CSLContact _ _ srv linkKey -> do let (linkId, k) = SL.contactShortLinkKdf linkKey ld <- getQueueLink c userId srv linkId decryptData srv linkKey k ld where - decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) + decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnLinkData c) decryptData srv linkKey k (sndId, d) = do r@(cReq, _) <- liftEither $ SL.decryptLinkData @c linkKey k d - unless ((srv, sndId) `sameQAddress` qAddress (connReqQueue cReq)) $ + let (srv', sndId') = qAddress (connReqQueue cReq) + unless (srv `sameSrvHost` srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address" pure r + sameSrvHost ProtocolServer {host = h :| _} ProtocolServer {host = hs} = h `elem` hs deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () -deleteLocalInvShortLink' c (CSLInvitation srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId +deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do @@ -978,12 +981,12 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s Just ShortLinkCreds {shortLinkId, shortLinkKey} | qUri == qUri' -> let link = case cReq of - CRContactUri _ -> CSLContact srv CCTContact shortLinkKey - CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey + CRContactUri _ -> CSLContact SLSServer CCTContact srv shortLinkKey + CRInvitationUri {} -> CSLInvitation SLSServer srv shortLinkId shortLinkKey in pure $ CCLink cReq (Just link) | otherwise -> throwE $ INTERNAL "different rcv queue address" Nothing -> - let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData) + let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri'] clientData) cReq' = case cReq of CRContactUri crData -> CRContactUri (updated crData) CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index eced35c08..419ca1d91 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -102,8 +102,6 @@ module Simplex.Messaging.Agent.Protocol ConnectionMode (..), SConnectionMode (..), AConnectionMode (..), - cmInvitation, - cmContact, ConnectionModeI (..), ConnectionRequestUri (..), AConnectionRequestUri (..), @@ -111,17 +109,22 @@ module Simplex.Messaging.Agent.Protocol CRClientData, ServiceScheme, FixedLinkData (..), - UserLinkData (..), + ConnLinkData (..), + OwnerAuth (..), + OwnerId, ConnectionLink (..), AConnectionLink (..), ConnShortLink (..), AConnShortLink (..), CreatedConnLink (..), ContactConnType (..), + ShortLinkScheme (..), LinkKey (..), sameConnReqContact, simplexChat, connReqUriP', + simplexConnReqUri, + simplexShortLink, AgentErrorType (..), CommandErrorType (..), ConnectionErrorType (..), @@ -156,6 +159,7 @@ module Simplex.Messaging.Agent.Protocol updateSMPServerHosts, shortenShortLink, restoreShortLink, + linkUserData, ) where @@ -167,7 +171,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (isDigit) +import Data.Char (toLower, toUpper) import Data.Foldable (find) import Data.Functor (($>)) import Data.Int (Int64) @@ -251,6 +255,7 @@ import UnliftIO.Exception (Exception) -- 4 - delivery receipts (7/13/2023) -- 5 - post-quantum double ratchet (3/14/2024) -- 6 - secure reply queues with provided keys (6/14/2024) +-- 7 - initialize ratchet on processing confirmation (7/18/2024) data SMPAgentVersion @@ -695,14 +700,6 @@ data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m) instance Eq AConnectionMode where ACM m == ACM m' = isJust $ testEquality m m' -cmInvitation :: AConnectionMode -cmInvitation = ACM SCMInvitation -{-# INLINE cmInvitation #-} - -cmContact :: AConnectionMode -cmContact = ACM SCMContact -{-# INLINE cmContact #-} - deriving instance Show AConnectionMode connMode :: SConnectionMode m -> ConnectionMode @@ -711,8 +708,8 @@ connMode SCMContact = CMContact {-# INLINE connMode #-} connMode' :: ConnectionMode -> AConnectionMode -connMode' CMInvitation = cmInvitation -connMode' CMContact = cmContact +connMode' CMInvitation = ACM SCMInvitation +connMode' CMContact = ACM SCMContact {-# INLINE connMode' #-} class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m @@ -1084,8 +1081,16 @@ instance Encoding ConnReqUriData where smpEncode ConnReqUriData {crAgentVRange, crSmpQueues, crClientData} = smpEncode (crAgentVRange, crSmpQueues, Large . encodeUtf8 <$> crClientData) smpP = do - (crAgentVRange, crSmpQueues, clientData) <- smpP + (crAgentVRange, smpQueues, clientData) <- smpP + -- This patch to compensate for the fact that queueMode QMContact won't be included in queue encoding, + -- until min SMP client version is >= 3 (sndAuthKeySMPClientVersion). + -- This is possible because SMP encoding of ConnReqUriData was not used prior to SMP client version 4. + let crSmpQueues = L.map patchQueueMode smpQueues pure ConnReqUriData {crScheme = SSSimplex, crAgentVRange, crSmpQueues, crClientData = safeDecodeUtf8 . unLarge <$> clientData} + where + patchQueueMode q@SMPQueueUri {queueAddress = a} = case a of + SMPQueueAddress {queueMode = Nothing} -> q {queueAddress = a {queueMode = Just QMContact}} :: SMPQueueUri + _ -> q connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m) connReqUriP' overrideScheme = do @@ -1342,6 +1347,11 @@ data ConnectionRequestUri (m :: ConnectionMode) where -- they are passed in AgentInvitation message CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact +simplexConnReqUri :: ConnectionRequestUri m -> ConnectionRequestUri m +simplexConnReqUri = \case + CRInvitationUri crData e2eParams -> CRInvitationUri crData {crScheme = SSSimplex} e2eParams + CRContactUri crData -> CRContactUri crData {crScheme = SSSimplex} + deriving instance Eq (ConnectionRequestUri m) deriving instance Show (ConnectionRequestUri m) @@ -1355,14 +1365,21 @@ instance Eq AConnectionRequestUri where deriving instance Show AConnectionRequestUri +data ShortLinkScheme = SLSSimplex | SLSServer deriving (Eq, Show) + data ConnShortLink (m :: ConnectionMode) where - CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation - CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact + CSLInvitation :: ShortLinkScheme -> SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation + CSLContact :: ShortLinkScheme -> ContactConnType -> SMPServer -> LinkKey -> ConnShortLink 'CMContact deriving instance Eq (ConnShortLink m) deriving instance Show (ConnShortLink m) +simplexShortLink :: ConnShortLink m -> ConnShortLink m +simplexShortLink = \case + CSLInvitation _ srv lnkId k -> CSLInvitation SLSSimplex srv lnkId k + CSLContact _ ct srv k -> CSLContact SLSSimplex ct srv k + newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data) deriving (Eq, Show) deriving newtype (FromField, StrEncoding) @@ -1377,7 +1394,7 @@ instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode -data ContactConnType = CCTContact | CCTGroup deriving (Eq, Show) +data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) @@ -1414,53 +1431,103 @@ instance ConnectionModeI m => FromJSON (ConnectionLink m) where instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case - CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i" - CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g" + CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k + CSLContact sch ct srv (LinkKey k) -> slEncode sch srv (toLower $ ctTypeChar ct) "" k where - encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType = - "https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> khStr <> hosts <> B64.encodeUnpadded linkUri + slEncode sch (SMPServer (h :| hs) port (C.KeyHash kh)) linkType lnkId k = + B.concat [authority, "/", B.singleton linkType, "#", lnkIdStr, B64.encodeUnpadded k, queryStr] where - port' = if null port then "" else B.pack (':' : port) - hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/" - khStr = if B.null kh then "" else B64.encodeUnpadded kh <> "@" - strP = do - ACSL m l <- strP - case testEquality m $ sConnectionMode @m of - Just Refl -> pure l - _ -> fail "bad short link mode" + (authority, paramHosts) = case sch of + SLSSimplex -> ("simplex:", h : hs) + SLSServer -> ("https://" <> strEncode h, hs) + lnkIdStr = if B.null lnkId then "" else B64.encodeUnpadded lnkId <> "/" + queryStr = if B.null query then "" else "?" <> query + query = + strEncode . QSP QEscape $ + [("h", strEncode (TransportHosts_ paramHosts)) | not (null paramHosts)] + <> [("p", B.pack port) | not (null port)] + <> [("c", B64.encodeUnpadded kh) | not (B.null kh)] + strP = (\(ACSL _ l) -> checkConnMode l) <$?> strP + {-# INLINE strP #-} instance StrEncoding AConnShortLink where strEncode (ACSL _ l) = strEncode l + {-# INLINE strEncode #-} strP = do - h <- "https://" *> strP - port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure "" - linkType <- A.char '/' *> A.anyChar - keyHash <- optional (A.char '/') *> A.char '#' *> (strP <* A.char '@' <|> pure (C.KeyHash "")) - TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ []) - linkUri <- strP - let srv = SMPServer (h :| hs) port keyHash - case linkType of - 'i' - | B.length linkUri == 56 -> - let (lnkId, k) = B.splitAt 24 linkUri - in pure $ ACSL SCMInvitation $ CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) - | otherwise -> fail "bad ConnShortLink: incorrect linkID and key length" - 'c' -> contactP srv CCTContact linkUri - 'g' -> contactP srv CCTGroup linkUri - _ -> fail "bad ConnShortLink: unknown link type" + (sch, h_) <- authorityP <* A.char '/' + ct_ <- contactTypeP <* optional (A.char '/') <* A.char '#' + case ct_ of + Nothing -> do + lnkId <- strP <* A.char '/' + k <- strP + srv <- serverQueryP h_ + pure $ ACSL SCMInvitation $ CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) + Just ct -> do + k <- strP + srv <- serverQueryP h_ + pure $ ACSL SCMContact $ CSLContact sch ct srv (LinkKey k) where - contactP srv ct k - | B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k) - | otherwise = fail "bad ConnShortLink: incorrect key length" + authorityP = + "simplex:" $> (SLSSimplex, Nothing) + <|> "https://" *> ((SLSServer,) . Just <$> strP) + <|> fail "bad short link scheme" + contactTypeP = do + Just <$> (A.anyChar >>= ctTypeP . toUpper) + <|> A.char 'i' $> Nothing + <|> fail "unknown short link type" + serverQueryP h_ = + optional (A.char '?' *> strP) >>= \case + Nothing -> maybe noServer (pure . SMPServerOnlyHost) h_ + Just query -> do + hs <- maybe noServer pure . L.nonEmpty . maybe id (:) h_ . maybe [] thList_ =<< queryParam_ "h" query + p <- maybe "" show <$> queryParam_ @Word16 "p" query + kh <- fromMaybe (C.KeyHash "") <$> queryParam_ "c" query + pure $ SMPServer hs p kh + noServer = fail "short link without server" + +instance ConnectionModeI m => Encoding (ConnShortLink m) where + smpEncode = \case + CSLInvitation _ srv lnkId (LinkKey k) -> smpEncode (CMInvitation, srv, lnkId, k) + CSLContact _ ct srv (LinkKey k) -> smpEncode (CMContact, ctTypeChar ct, srv, k) + smpP = (\(ACSL _ l) -> checkConnMode l) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AConnShortLink where + smpEncode (ACSL _ l) = smpEncode l + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> do + (srv, lnkId, k) <- smpP + pure $ ACSL SCMInvitation $ CSLInvitation SLSServer srv lnkId (LinkKey k) + CMContact -> do + ct <- ctTypeP =<< A.anyChar + (srv, k) <- smpP + pure $ ACSL SCMContact $ CSLContact SLSServer ct srv (LinkKey k) + +ctTypeP :: Char -> Parser ContactConnType +ctTypeP = \case + 'A' -> pure CCTContact + 'C' -> pure CCTChannel + 'G' -> pure CCTGroup + _ -> fail "unknown contact address type" +{-# INLINE ctTypeP #-} + +ctTypeChar :: ContactConnType -> Char +ctTypeChar = \case + CCTContact -> 'A' + CCTChannel -> 'C' + CCTGroup -> 'G' +{-# INLINE ctTypeChar #-} -- the servers passed to this function should be all preset servers, not servers configured by the user. shortenShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m shortenShortLink presetSrvs = \case - CSLInvitation srv lnkId linkKey -> CSLInvitation (shortServer srv) lnkId linkKey - CSLContact srv ct linkKey -> CSLContact (shortServer srv) ct linkKey + CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (shortServer srv) lnkId linkKey + CSLContact sch ct srv linkKey -> CSLContact sch ct (shortServer srv) linkKey where shortServer srv@(SMPServer hs@(h :| _) p kh) = - if isPresetServer then SMPServer [h] "" (C.KeyHash "") else srv + if isPresetServer then SMPServerOnlyHost h else srv where isPresetServer = case findPresetServer srv presetSrvs of Just (SMPServer hs' p' kh') -> @@ -1469,14 +1536,20 @@ shortenShortLink presetSrvs = \case && kh == kh' Nothing -> False +-- explicit bidirectional is used for ghc 8.10.7 compatibility, [h]/[] patterns are not reversible. +pattern SMPServerOnlyHost :: TransportHost -> SMPServer +pattern SMPServerOnlyHost h <- SMPServer [h] "" (C.KeyHash "") + where + SMPServerOnlyHost h = SMPServer [h] "" (C.KeyHash "") + -- the servers passed to this function should be all preset servers, not servers configured by the user. restoreShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m restoreShortLink presetSrvs = \case - CSLInvitation srv lnkId linkKey -> CSLInvitation (fullServer srv) lnkId linkKey - CSLContact srv ct linkKey -> CSLContact (fullServer srv) ct linkKey + CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (fullServer srv) lnkId linkKey + CSLContact sch ct srv linkKey -> CSLContact sch ct (fullServer srv) linkKey where fullServer = \case - s@(SMPServer [_] "" (C.KeyHash "")) -> fromMaybe s $ findPresetServer s presetSrvs + s@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs s -> s findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer @@ -1507,28 +1580,83 @@ type CRClientData = Text data FixedLinkData c = FixedLinkData { agentVRange :: VersionRangeSMPA, - sigKey :: C.PublicKeyEd25519, + rootKey :: C.PublicKeyEd25519, connReq :: ConnectionRequestUri c } -data UserLinkData = UserLinkData - { agentVRange :: VersionRangeSMPA, - userData :: ConnInfo +data ConnLinkData c where + InvitationLinkData :: VersionRangeSMPA -> ConnInfo -> ConnLinkData 'CMInvitation + ContactLinkData :: + { agentVRange :: VersionRangeSMPA, + -- direct connection via connReq in fixed data is allowed. + direct :: Bool, + -- additional owner keys to sign changes of mutable data. + owners :: [OwnerAuth], + -- alternative addresses of chat relays that receive requests for this contact address. + relays :: [ConnShortLink 'CMContact], + userData :: ConnInfo + } -> ConnLinkData 'CMContact + +data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m) + +linkUserData :: ConnLinkData c -> ConnInfo +linkUserData = \case + InvitationLinkData _ d -> d + ContactLinkData {userData} -> userData + +type OwnerId = ByteString + +data OwnerAuth = OwnerAuth + { ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId + ownerKey :: C.PublicKeyEd25519, + -- sender ID signed with ownerKey, + -- confirms that the owner accepts being the owner. + -- sender ID is used here as it is immutable for the queue, link data can be removed. + ownerSig :: C.Signature 'C.Ed25519, + -- null for root key authorization + authOwnerId :: OwnerId, + -- owner authorization, sig(ownerId || ownerKey, key(authOwnerId)), + -- where authOwnerId is either null for a root key or some other owner authorized by root key, etc. + -- Owner validation should detect and reject loops. + authOwnerSig :: C.Signature 'C.Ed25519 } -instance ConnectionModeI c => Encoding (FixedLinkData c) where - smpEncode FixedLinkData {agentVRange, sigKey, connReq} = - smpEncode (agentVRange, sigKey, connReq) +instance Encoding OwnerAuth where + smpEncode OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} = + smpEncode (ownerId, ownerKey, C.signatureBytes ownerSig, authOwnerId, C.signatureBytes authOwnerSig) smpP = do - (agentVRange, sigKey, connReq) <- smpP - pure FixedLinkData {agentVRange, sigKey, connReq} + (ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig) <- smpP + pure OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} -instance Encoding UserLinkData where - smpEncode UserLinkData {agentVRange, userData} = - smpEncode (agentVRange, Large userData) +instance ConnectionModeI c => Encoding (FixedLinkData c) where + smpEncode FixedLinkData {agentVRange, rootKey, connReq} = + smpEncode (agentVRange, rootKey, connReq) smpP = do - (agentVRange, Large userData) <- smpP - pure UserLinkData {agentVRange, userData} + (agentVRange, rootKey, connReq) <- smpP + pure FixedLinkData {agentVRange, rootKey, connReq} + +instance ConnectionModeI c => Encoding (ConnLinkData c) where + smpEncode = \case + InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData) + ContactLinkData {agentVRange, direct, owners, relays, userData} -> + B.concat [smpEncode (CMContact, agentVRange, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData] + smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AConnLinkData where + smpEncode (ACLD _ d) = smpEncode d + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> do + (vr, userData) <- smpP + pure $ ACLD SCMInvitation $ InvitationLinkData vr userData + CMContact -> do + (agentVRange, direct) <- smpP + owners <- smpListP + relays <- smpListP + userData <- smpP + pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData} -- | SMP queue status. data QueueStatus diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 39fc65330..e3326b98a 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -791,10 +791,19 @@ class CryptoSignature s where instance CryptoSignature (Signature s) => StrEncoding (Signature s) where strEncode = serializeSignature + {-# INLINE strEncode #-} strDecode = decodeSignature + {-# INLINE strDecode #-} + +instance CryptoSignature (Signature s) => Encoding (Signature s) where + smpEncode = smpEncode . signatureBytes + {-# INLINE smpEncode #-} + smpP = decodeSignature <$?> smpP + {-# INLINE smpP #-} instance CryptoSignature ASignature where signatureBytes (ASignature _ sig) = signatureBytes sig + {-# INLINE signatureBytes #-} decodeSignature s | B.length s == Ed25519.signatureSize = ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s @@ -806,6 +815,7 @@ instance CryptoSignature ASignature where instance CryptoSignature (Maybe ASignature) where signatureBytes = maybe "" signatureBytes + {-# INLINE signatureBytes #-} decodeSignature s | B.null s = Right Nothing | otherwise = Just <$> decodeSignature s @@ -814,6 +824,7 @@ instance AlgorithmI a => CryptoSignature (Signature a) where signatureBytes = \case SignatureEd25519 s -> BA.convert s SignatureEd448 s -> BA.convert s + {-# INLINE signatureBytes #-} decodeSignature s = do ASignature _ sig <- decodeSignature s checkAlgorithm sig @@ -824,25 +835,31 @@ instance SignatureSize (Signature a) where signatureSize = \case SignatureEd25519 _ -> Ed25519.signatureSize SignatureEd448 _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} instance SignatureSize ASignature where signatureSize (ASignature _ s) = signatureSize s + {-# INLINE signatureSize #-} instance SignatureSize APrivateSignKey where signatureSize (APrivateSignKey _ k) = signatureSize k + {-# INLINE signatureSize #-} instance SignatureSize APublicVerifyKey where signatureSize (APublicVerifyKey _ k) = signatureSize k + {-# INLINE signatureSize #-} instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where signatureSize = \case PrivateKeyEd25519 _ _ -> Ed25519.signatureSize PrivateKeyEd448 _ _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} instance SignatureAlgorithm a => SignatureSize (PublicKey a) where signatureSize = \case PublicKeyEd25519 _ -> Ed25519.signatureSize PublicKeyEd448 _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} -- | Various cryptographic or related errors. data CryptoError diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index 0c269bc20..8ea38f9fe 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Crypto.ShortLink ( contactShortLinkKdf, @@ -45,18 +48,23 @@ contactShortLinkKdf (LinkKey k) = invShortLinkKdf :: LinkKey -> C.SbKey invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32 -encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) -encodeSignLinkData (sigKey, pk) agentVRange connReq userData = - let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq} - ud = smpEncode UserLinkData {agentVRange, userData} - in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk ud)) +encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) +encodeSignLinkData (rootKey, pk) agentVRange connReq userData = + let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq} + md = smpEncode $ connLinkData @c agentVRange userData + in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md)) encodeSignUserData :: C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString encodeSignUserData pk agentVRange userData = - encodeSign pk $ smpEncode UserLinkData {agentVRange, userData} + encodeSign pk $ smpEncode $ connLinkData @'CMContact agentVRange userData + +connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> ConnInfo -> ConnLinkData c +connLinkData agentVRange userData = case sConnectionMode @c of + SCMInvitation -> InvitationLinkData agentVRange userData + SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData} encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString -encodeSign pk s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s +encodeSign pk s = smpEncode (C.sign' pk s) <> s encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> ExceptT AgentErrorType IO QueueLinkData encryptLinkData g k = bimapM (encrypt fixedDataPaddedLength) (encrypt userDataPaddedLength) @@ -72,22 +80,22 @@ encryptData g k len s = do ct <- liftEitherWith cryptoError $ C.sbEncrypt k nonce s len pure $ EncDataBytes $ smpEncode nonce <> ct -decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo) -decryptLinkData linkKey k (encFD, encUD) = do +decryptLinkData :: forall c. ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnLinkData c) +decryptLinkData linkKey k (encFD, encMD) = do (sig1, fd) <- decrypt encFD - (sig2, ud) <- decrypt encUD - FixedLinkData {sigKey, connReq} <- decode fd - UserLinkData {userData} <- decode ud + (sig2, md) <- decrypt encMD + FixedLinkData {rootKey, connReq} <- decode fd + md' <- decode @(ConnLinkData c) md if | LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash" - | not (C.verify' sigKey sig1 fd) -> linkErr "link data signature" - | not (C.verify' sigKey sig2 ud) -> linkErr "user data signature" - | otherwise -> Right (connReq, userData) + | not (C.verify' rootKey sig1 fd) -> linkErr "link data signature" + | not (C.verify' rootKey sig2 md) -> linkErr "user data signature" + | otherwise -> Right (connReq, md') where decrypt (EncDataBytes d) = do (nonce, Tail ct) <- decode d - (sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct) - (,s) <$> msgErr (C.decodeSignature sigBytes) + (sig, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct) + pure (sig, s) decode :: Encoding a => ByteString -> Either AgentErrorType a decode = msgErr . smpDecode msgErr = first (const $ AGENT A_MESSAGE) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index b486a7a38..cb2eea43b 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -241,6 +241,8 @@ import Simplex.Messaging.Version.Internal -- SMP client protocol version history: -- 1 - binary protocol encoding (1/1/2022) -- 2 - multiple server hostnames and versioned queue addresses (8/12/2022) +-- 3 - faster handshake: SKEY command for sender to secure queue (6/30/2024, SMP protocol version 9) +-- 4 - short connection links with stored data (3/30/2025, SMP protocol version 15) data SMPClientVersion @@ -419,6 +421,7 @@ data Command (p :: Party) where NEW :: NewQueueReq -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient + RKEY :: NonEmpty RcvPublicAuthKey -> Command Recipient LSET :: LinkId -> QueueLinkData -> Command Recipient LDEL :: Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient @@ -770,6 +773,7 @@ data CommandTag (p :: Party) where NEW_ :: CommandTag Recipient SUB_ :: CommandTag Recipient KEY_ :: CommandTag Recipient + RKEY_ :: CommandTag Recipient LSET_ :: CommandTag Recipient LDEL_ :: CommandTag Recipient NKEY_ :: CommandTag Recipient @@ -825,6 +829,7 @@ instance PartyI p => Encoding (CommandTag p) where NEW_ -> "NEW" SUB_ -> "SUB" KEY_ -> "KEY" + RKEY_ -> "RKEY" LSET_ -> "LSET" LDEL_ -> "LDEL" NKEY_ -> "NKEY" @@ -850,6 +855,7 @@ instance ProtocolMsgTag CmdTag where "NEW" -> Just $ CT SRecipient NEW_ "SUB" -> Just $ CT SRecipient SUB_ "KEY" -> Just $ CT SRecipient KEY_ + "RKEY" -> Just $ CT SRecipient RKEY_ "LSET" -> Just $ CT SRecipient LSET_ "LDEL" -> Just $ CT SRecipient LDEL_ "NKEY" -> Just $ CT SRecipient NKEY_ @@ -1494,6 +1500,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where auth = maybe "" (e . ('A',)) auth_ SUB -> e SUB_ KEY k -> e (KEY_, ' ', k) + RKEY ks -> e (RKEY_, ' ', ks) LSET lnkId d -> e (LSET_, ' ', lnkId, d) LDEL -> e LDEL_ NKEY k dhKey -> e (NKEY_, ' ', k, dhKey) @@ -1577,6 +1584,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing SUB_ -> pure SUB KEY_ -> KEY <$> _smpP + RKEY_ -> RKEY <$> _smpP LSET_ -> LSET <$> _smpP <*> smpP LDEL_ -> pure LDEL NKEY_ -> NKEY <$> _smpP <*> smpP diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 8cf730e06..32534ccf9 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1062,7 +1062,7 @@ verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TSer verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW NewQueueReq {rcvAuthKey = k}) -> pure $ Nothing `verifiedWith` k - Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey (snd q)) <$> get SRecipient + Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWithKeys` recipientKeys (snd q)) <$> get SRecipient Cmd SSender (SKEY k) -> verifySecure SSender k -- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender @@ -1082,6 +1082,8 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = verifySecure p k = verifyQueue (\q -> if k `allowedKey` snd q then Just q `verifiedWith` k else dummyVerify) <$> get p verifiedWith :: Maybe (StoreQueue s, QueueRec) -> C.APublicAuthKey -> VerificationResult s verifiedWith q_ k = if verify k then VRVerified q_ else VRFailed + verifiedWithKeys :: Maybe (StoreQueue s, QueueRec) -> NonEmpty C.APublicAuthKey -> VerificationResult s + verifiedWithKeys q_ ks = if any verify ks then VRVerified q_ else VRFailed allowedKey k = \case QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey _ -> False @@ -1262,7 +1264,8 @@ client SUB -> withQueue subscribeQueue GET -> withQueue getMessage ACK msgId -> withQueue $ acknowledgeMsg msgId - KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey + KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey + RKEY rKeys -> withQueue $ \q qr -> checkMode QMContact qr $ OK <$$ liftIO (updateKeys (queueStore ms) q rKeys) LSET lnkId d -> withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH @@ -1311,7 +1314,7 @@ client qr = QueueRec { senderId = sndId, - recipientKey = rcvAuthKey, + recipientKeys = [rcvAuthKey], rcvDhSecret = C.dh' rcvDhKey privDhKey, senderKey = Nothing, queueMode, @@ -1340,7 +1343,7 @@ client checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) checkMode qm QueueRec {queueMode} a = - (corrId,entId,) . either ERR id + either err (corrId,entId,) <$> if queueMode == Just qm then a else pure $ Left AUTH secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M (Either ErrorType BrokerMsg) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 90ee2208d..d28300a75 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -331,6 +331,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where {-# INLINE deleteQueueLinkData #-} secureQueue = withQS secureQueue {-# INLINE secureQueue #-} + updateKeys = withQS updateKeys + {-# INLINE updateKeys #-} addQueueNotifier = withQS addQueueNotifier {-# INLINE addQueueNotifier #-} deleteQueueNotifier = withQS deleteQueueNotifier diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index d2492fe43..e90359d1d 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -13,6 +13,7 @@ module Simplex.Messaging.Server.QueueStore where import Control.Applicative ((<|>)) import Data.Functor (($>)) import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol @@ -25,7 +26,7 @@ import Simplex.Messaging.Util (eitherToMaybe) #endif data QueueRec = QueueRec - { recipientKey :: RcvPublicAuthKey, + { recipientKeys :: NonEmpty RcvPublicAuthKey, rcvDhSecret :: RcvDhSecret, senderId :: SenderId, senderKey :: Maybe SndPublicAuthKey, diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 186a1574d..f500a3f42 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -41,10 +41,10 @@ import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) import qualified Database.PostgreSQL.Simple as DB @@ -58,6 +58,8 @@ import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore @@ -74,8 +76,8 @@ import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM #if !defined(dbPostgres) -import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) -import qualified Simplex.Messaging.Crypto as C +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) import Simplex.Messaging.Encoding.String #endif @@ -257,6 +259,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where Just k | sKey /= k -> throwE AUTH _ -> pure () + updateKeys :: PostgresQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) + updateKeys st sq rKeys = + withQueueRec sq "updateKeys" $ \q -> do + assertUpdated $ withDB' "updateKeys" st $ \db -> + DB.execute db "UPDATE msg_queues SET recipient_keys = ? WHERE recipient_id = ? AND deleted_at IS NULL" (rKeys, rId) + atomically $ writeTVar (queueRec sq) $ Just q {recipientKeys = rKeys} + withLog "updateKeys" st $ \s -> logUpdateKeys s rId rKeys + where + rId = recipientId sq + addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = withQueueRec sq "addQueueNotifier" $ \q -> @@ -362,7 +374,7 @@ batchInsertQueues tty queues toStore = do let st = dbStore toStore count <- withConnection st $ \db -> do - DB.copy_ db "COPY msg_queues (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)" + DB.copy_ db "COPY msg_queues (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)" mapM_ (putQueue db) (zip [1..] qs) DB.putCopyEnd db Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues") @@ -378,7 +390,7 @@ insertQueueQuery :: Query insertQueueQuery = [sql| INSERT INTO msg_queues - (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data) + (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] @@ -407,7 +419,7 @@ foldQueueRecs tty withData st skipOld_ f = do queueRecQuery :: Query queueRecQuery = [sql| - SELECT recipient_id, recipient_key, rcv_dh_secret, + SELECT recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, @@ -418,7 +430,7 @@ queueRecQuery = queueRecQueryWithData :: Query queueRecQueryWithData = [sql| - SELECT recipient_id, recipient_key, rcv_dh_secret, + SELECT recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, @@ -426,23 +438,23 @@ queueRecQueryWithData = FROM msg_queues |] -type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId) +type QueueRecRow = (RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId) queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = - (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_) +queueRecToRow (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = + (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_) :. (fst <$> queueData_, snd <$> queueData_) where (linkId_, queueData_) = queueDataColumns queueData queueRecToText :: (RecipientId, QueueRec) -> ByteString -queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = +queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n' where tabFields = BB.char7 ',' `intersperse` fields fields = [ renderField (toField rId), - renderField (toField recipientKey), + renderField (toField recipientKeys), renderField (toField rcvDhSecret), renderField (toField senderId), nullable senderKey, @@ -473,17 +485,17 @@ queueDataColumns = \case Nothing -> (Nothing, Nothing) rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) -rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) = +rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) + in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec) -rowToQueueRecWithData ((rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) = +rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ encData = fromMaybe (EncDataBytes "") queueData = (,(encData immutableData_, encData userData_)) <$> linkId_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) + in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) setStatusDB op st sq status writeLog = @@ -528,6 +540,10 @@ instance ToField EntityId where toField (EntityId s) = toField $ Binary s deriving newtype instance FromField EntityId +instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary . smpEncode + +instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode + #if !defined(dbPostgres) instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs index 9d0973976..b1c5501f6 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -77,6 +77,10 @@ UPDATE msg_queues SET queue_mode = 'M' WHERE snd_secure IS TRUE; ALTER TABLE msg_queues DROP COLUMN snd_secure; +UPDATE msg_queues SET recipient_key = ('\x01'::BYTEA || chr(length(recipient_key))::BYTEA || recipient_key); + +ALTER TABLE msg_queues RENAME COLUMN recipient_key TO recipient_keys; + CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id); |] @@ -88,11 +92,30 @@ ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE; UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M'; -ALTER TABLE +DROP INDEX idx_msg_queues_link_id; + +ALTER TABLE msg_queues DROP COLUMN queue_mode, DROP COLUMN link_id, DROP COLUMN fixed_data, DROP COLUMN user_data; -DROP INDEX idx_msg_queues_link_id; +DO $$ + DECLARE bad_id BYTEA; + BEGIN + SELECT recipient_id INTO bad_id + FROM msg_queues + WHERE get_byte(recipient_keys, 0) != 1 + OR get_byte(recipient_keys, 1) != length(recipient_keys) - 2 + LIMIT 1; + + IF bad_id IS NOT NULL + THEN RAISE EXCEPTION 'Cannot downgrade: many keys or incorrect length in recipient_keys for %', encode(bad_id, 'base64'); + END IF; + END; +$$; + +UPDATE msg_queues SET recipient_keys = substring(recipient_keys from 3); + +ALTER TABLE msg_queues RENAME COLUMN recipient_keys TO recipient_key; |] diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql new file mode 100644 index 000000000..2910b6959 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql @@ -0,0 +1,74 @@ + + +SET statement_timeout = 0; +SET lock_timeout = 0; +SET idle_in_transaction_session_timeout = 0; +SET client_encoding = 'UTF8'; +SET standard_conforming_strings = on; +SELECT pg_catalog.set_config('search_path', '', false); +SET check_function_bodies = false; +SET xmloption = content; +SET client_min_messages = warning; +SET row_security = off; + + +CREATE SCHEMA smp_server; + + +SET default_table_access_method = heap; + + +CREATE TABLE smp_server.migrations ( + name text NOT NULL, + ts timestamp without time zone NOT NULL, + down text +); + + + +CREATE TABLE smp_server.msg_queues ( + recipient_id bytea NOT NULL, + recipient_keys bytea NOT NULL, + rcv_dh_secret bytea NOT NULL, + sender_id bytea NOT NULL, + sender_key bytea, + notifier_id bytea, + notifier_key bytea, + rcv_ntf_dh_secret bytea, + status text NOT NULL, + updated_at bigint, + deleted_at bigint, + queue_mode text, + link_id bytea, + fixed_data bytea, + user_data bytea +); + + + +ALTER TABLE ONLY smp_server.migrations + ADD CONSTRAINT migrations_pkey PRIMARY KEY (name); + + + +ALTER TABLE ONLY smp_server.msg_queues + ADD CONSTRAINT msg_queues_pkey PRIMARY KEY (recipient_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_notifier_id ON smp_server.msg_queues USING btree (notifier_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_sender_id ON smp_server.msg_queues USING btree (sender_id); + + + +CREATE INDEX idx_msg_queues_updated_at ON smp_server.msg_queues USING btree (deleted_at, updated_at); + + + diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index dcd7fd5a0..61fa3af45 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -28,6 +28,7 @@ import Control.Logger.Simple import Control.Monad import Data.Bitraversable (bimapM) import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import qualified Data.Text as T import Simplex.Messaging.Protocol @@ -141,6 +142,14 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where TM.delete lnkId $ links st writeTVar qr $ Just q {queueData = Nothing} + updateKeys :: STMQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) + updateKeys st sq rKeys = + withQueueRec qr update + $>> withLog "updateKeys" st (\s -> logUpdateKeys s (recipientId sq) rKeys) + where + qr = queueRec sq + update q = writeTVar qr $ Just q {recipientKeys = rKeys} + secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = atomically (readQueueRec qr $>>= secure) diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 2a4dbc3ea..9a52a9df8 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -10,6 +10,7 @@ module Simplex.Messaging.Server.QueueStore.Types where import Control.Concurrent.STM import Control.Monad import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.TMap (TMap) @@ -34,6 +35,7 @@ class StoreQueueClass q => QueueStoreClass q s where addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) deleteQueueLinkData :: s -> q -> IO (Either ErrorType ()) secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) + updateKeys :: s -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId)) suspendQueue :: s -> q -> IO (Either ErrorType ()) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 104a89fe8..80a2b75aa 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -21,6 +21,7 @@ module Simplex.Messaging.Server.StoreLog logCreateLink, logDeleteLink, logSecureQueue, + logUpdateKeys, logAddNotifier, logSuspendQueue, logBlockQueue, @@ -43,6 +44,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (sort, stripPrefix) +import Data.List.NonEmpty (NonEmpty) import Data.Maybe (mapMaybe) import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) @@ -64,6 +66,7 @@ data StoreLogRecord | CreateLink RecipientId LinkId QueueLinkData | DeleteLink RecipientId | SecureQueue QueueId SndPublicAuthKey + | UpdateKeys RecipientId (NonEmpty RcvPublicAuthKey) | AddNotifier QueueId NtfCreds | SuspendQueue QueueId | BlockQueue QueueId BlockingInfo @@ -78,6 +81,7 @@ data SLRTag | CreateLink_ | DeleteLink_ | SecureQueue_ + | UpdateKeys_ | AddNotifier_ | SuspendQueue_ | BlockQueue_ @@ -87,9 +91,9 @@ data SLRTag | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} = + strEncode QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} = B.unwords - [ "rk=" <> strEncode recipientKey, + [ "rk=" <> strEncode recipientKeys, "rdh=" <> strEncode rcvDhSecret, "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey @@ -108,7 +112,7 @@ instance StrEncoding QueueRec where _ -> " status=" <> strEncode status strP = do - recipientKey <- "rk=" *> strP_ + recipientKeys <- "rk=" *> strP_ rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP @@ -120,7 +124,7 @@ instance StrEncoding QueueRec where notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP status <- (" status=" *> strP) <|> pure EntityActive - pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} + pure QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} where toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact @@ -130,6 +134,7 @@ instance StrEncoding SLRTag where CreateLink_ -> "LINK" DeleteLink_ -> "LDELETE" SecureQueue_ -> "SECURE" + UpdateKeys_ -> "KEYS" AddNotifier_ -> "NOTIFIER" SuspendQueue_ -> "SUSPEND" BlockQueue_ -> "BLOCK" @@ -144,6 +149,7 @@ instance StrEncoding SLRTag where "LINK" $> CreateLink_, "LDELETE" $> DeleteLink_, "SECURE" $> SecureQueue_, + "KEYS" $> UpdateKeys_, "NOTIFIER" $> AddNotifier_, "SUSPEND" $> SuspendQueue_, "BLOCK" $> BlockQueue_, @@ -159,6 +165,7 @@ instance StrEncoding StoreLogRecord where CreateLink rId lnkId d -> strEncode (CreateLink_, rId, lnkId, d) DeleteLink rId -> strEncode (DeleteLink_, rId) SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) + UpdateKeys rId rKeys -> strEncode (UpdateKeys_, rId, rKeys) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) BlockQueue rId info -> strEncode (BlockQueue_, rId, info) @@ -173,6 +180,7 @@ instance StrEncoding StoreLogRecord where CreateLink_ -> CreateLink <$> strP_ <*> strP_ <*> strP DeleteLink_ -> DeleteLink <$> strP SecureQueue_ -> SecureQueue <$> strP_ <*> strP + UpdateKeys_ -> UpdateKeys <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP BlockQueue_ -> BlockQueue <$> strP_ <*> strP @@ -221,6 +229,9 @@ logDeleteLink s = writeStoreLogRecord s . DeleteLink logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey +logUpdateKeys :: StoreLog 'WriteMode -> QueueId -> NonEmpty RcvPublicAuthKey -> IO () +logUpdateKeys s rId rKeys = writeStoreLogRecord s $ UpdateKeys rId rKeys + logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO () logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index 5a8f1f46c..bc576001c 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -45,6 +45,7 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine CreateLink rId lnkId d -> withQueue rId "CreateLink" $ \q -> addQueueLinkData st q lnkId d DeleteLink rId -> withQueue rId "DeleteLink" $ \q -> deleteQueueLinkData st q SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey + UpdateKeys rId rKeys -> withQueue rId "UpdateKeys" $ \q -> updateKeys st q rKeys AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 458760a80..d74979434 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -40,11 +41,14 @@ queueAddr = { smpServer = srv, senderId = EntityId "\223\142z\251", dhPublicKey = testDhKey, - queueMode = Nothing + queueMode = Just QMMessaging } -queueAddrSK :: SMPQueueAddress -queueAddrSK = queueAddr {queueMode = Just QMMessaging} +queueAddrNoQM :: SMPQueueAddress +queueAddrNoQM = queueAddr {queueMode = Nothing} + +queueAddrContact :: SMPQueueAddress +queueAddrContact = queueAddr {queueMode = Just QMContact} queueAddr1 :: SMPQueueAddress queueAddr1 = queueAddr {smpServer = srv1} @@ -52,6 +56,9 @@ queueAddr1 = queueAddr {smpServer = srv1} queueAddrNoPort :: SMPQueueAddress queueAddrNoPort = queueAddr {smpServer = srv {port = ""}} +queueAddrNoPortNoQM :: SMPQueueAddress +queueAddrNoPortNoQM = queueAddrNoQM {smpServer = srv {port = ""}} + queueAddrNoPort1 :: SMPQueueAddress queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} @@ -59,26 +66,32 @@ queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} queue :: SMPQueueUri queue = SMPQueueUri supportedSMPClientVRange queueAddr -queueSK :: SMPQueueUri -queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK +queueNoQM :: SMPQueueUri +queueNoQM = SMPQueueUri supportedSMPClientVRange queueAddrNoQM + +queueContact :: SMPQueueUri +queueContact = SMPQueueUri supportedSMPClientVRange queueAddrContact queueStr :: ByteString -queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" -queueStrSK :: ByteString -queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" +queueStrNoQM :: ByteString +queueStrNoQM = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queueStrContact :: ByteString +queueStrContact = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=c" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" queue1 :: SMPQueueUri queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1 queue1Str :: ByteString -queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueV1 :: SMPQueueUri -queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr +queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddrNoQM queueV1NoPort :: SMPQueueUri -queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} +queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPortNoQM} -- version range 2-3 uses new encoding -- it is fixed/changed in v5.8.2. @@ -86,10 +99,10 @@ 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-4&dh=" <> url testDhKeyStr +queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueNewStr' :: ByteString -queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> testDhKeyStr +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> testDhKeyStr <> "&q=m&k=s" queueNewNoPort :: SMPQueueUri queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} @@ -98,7 +111,7 @@ queueNew1 :: SMPQueueUri queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1 queueNew1Str :: ByteString -queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueNew1NoPort :: SMPQueueUri queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} @@ -118,8 +131,11 @@ connReqData = crClientData = Nothing } -connReqDataSK :: ConnReqUriData -connReqDataSK = connReqData {crSmpQueues = [queueSK]} +connReqDataNoQM :: ConnReqUriData +connReqDataNoQM = connReqData {crSmpQueues = [queueNoQM]} + +connReqDataContact :: ConnReqUriData +connReqDataContact = connReqData {crSmpQueues = [queueContact]} connReqData1 :: ConnReqUriData connReqData1 = connReqData {crSmpQueues = [queue1]} @@ -154,8 +170,11 @@ connectionRequest = ACR SCMInvitation invConnRequest invConnRequest :: ConnectionRequestUri 'CMInvitation invConnRequest = CRInvitationUri connReqData testE2ERatchetParams -connectionRequestSK :: AConnectionRequestUri -connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams +connectionRequestNoQM :: AConnectionRequestUri +connectionRequestNoQM = ACR SCMInvitation $ CRInvitationUri connReqDataNoQM testE2ERatchetParams + +connectionRequestContact :: AConnectionRequestUri +connectionRequestContact = ACR SCMContact $ CRContactUri connReqDataContact connectionRequestV1 :: AConnectionRequestUri connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams @@ -218,14 +237,15 @@ connectionRequestTests = describe "connection request parsing / serializing" $ do it "should serialize and parse SMP queue URIs" $ do queue #==# queueStr - queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-4&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") - queueSK #==# queueStrSK + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-4&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&q=m&k=s") + queueNoQM #==# queueStrNoQM + queueContact #==# queueStrContact queue1 #==# queue1Str queueNew #==# queueNewStr queueNew #== queueNewStr' queueNew1 #==# queueNew1Str - queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr) - queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr) + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s") + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s") 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") @@ -236,7 +256,7 @@ connectionRequestTests = it "should serialize and parse connection invitations and contact addresses" $ do connectionRequest #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest #== ("https://simplex.chat/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) - connectionRequestSK #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNoQM #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrNoQM <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest2queues #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequestNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri) @@ -256,7 +276,8 @@ connectionRequestTests = contactAddressClientData #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") it "should serialize / parse queue address, connection invitations and contact addresses as binary" $ do smpEncodingTest queue - smpEncodingTest queueSK + smpEncodingTest queueNoQM -- this passes, no queue mode patch in SMPQueueUri encoding + -- smpEncodingTest queueContact -- this fails until SMP client min version is >= sndAuthKeySMPClientVersion smpEncodingTest queue1 smpEncodingTest queueNew smpEncodingTest queueNew1 @@ -265,7 +286,8 @@ connectionRequestTests = smpEncodingTest queueV1 smpEncodingTest queueV1NoPort smpEncodingTest connectionRequest - smpEncodingTest connectionRequestSK + -- smpEncodingTest connectionRequestNoQM -- this fails, because of queue mode patch + smpEncodingTest connectionRequestContact -- this passes because of queue mode patch in ConnReqUriData encoding smpEncodingTest connectionRequest1 smpEncodingTest connectionRequest2queues smpEncodingTest connectionRequestNew @@ -279,27 +301,46 @@ connectionRequestTests = smpEncodingTest contactAddressV2 smpEncodingTest contactAddressClientData it "should serialize / parse short links" $ do - CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/c#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLContact srv CCTGroup (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/g#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/c#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLInvitation srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/i#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLInvitation shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact SLSServer CCTContact srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSServer CCTGroup srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSServer CCTContact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLInvitation SLSServer srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLInvitation SLSServer shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact SLSSimplex CCTContact srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSSimplex CCTGroup srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSSimplex CCTContact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im" + CSLInvitation SLSSimplex srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLInvitation SLSSimplex shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im" it "should shorten / restore short links" $ do - shortenShortLink [srv] (CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - shortenShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv2] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + let contact = CSLContact SLSServer CCTContact + shortenShortLink [srv] (contact srv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + -- won't shorten link that uses only onion host from preset server + shortenShortLink [srv] (contact srvOnion (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srvOnion (LinkKey "0123456789abcdef0123456789abcdef") + -- will shorten link that uses only public host from preset server + shortenShortLink [srv] (contact srv1 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + shortenShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv (LinkKey "0123456789abcdef0123456789abcdef") + -- won't change link that has only public host of preset server with keyhash + restoreShortLink [srv] (contact srv1 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv1 (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv2] (contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef") where + smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a shortSrv :: SMPServer shortSrv = SMPServer "smp.simplex.im" "" (C.KeyHash "") +srvOnion :: SMPServer +srvOnion = SMPServer "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "" (C.KeyHash "\215m\248\251") + srv2 :: SMPServer srv2 = SMPServer "smp2.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "" (C.KeyHash "\215m\248\251") diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index 6cc303513..5b05444fc 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -5,6 +5,7 @@ module AgentTests.EqInstances where import Data.Type.Equality +import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) @@ -27,6 +28,14 @@ deriving instance Eq ClientNtfCreds deriving instance Eq ShortLinkCreds +deriving instance Show (ConnLinkData c) + +deriving instance Eq (ConnLinkData c) + +deriving instance Show OwnerAuth + +deriving instance Eq OwnerAuth + deriving instance Show ProxiedRelay deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 179653a9f..c49703d1c 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -78,7 +78,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgJ2QS, cfgMS, prevRange, prevVersion, proxyCfgJ2QS, proxyCfgMS, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -102,7 +102,7 @@ import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -315,6 +315,7 @@ functionalAPITests ps = do describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink + describe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInviationShortLinkPrev describe "server restart" $ do it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps it "should connect via contact short link after restart" $ testContactShortLinkRestart ps @@ -547,8 +548,21 @@ testServerMatrix2 ps runTest = do testProxyMatrix :: HasCallStack => (ATransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec testProxyMatrix ps runTest = do - it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 initAgentServers initAgentServers2 $ runTest False - it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 initAgentServersProxy initAgentServersProxy2 $ runTest True + it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False + it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True + +testProxyMatrixWithPrev :: HasCallStack => (ATransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec +testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do + it "2 servers, directly, curr clients, prev servers" $ withSmpServers2Prev $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False True + it "2 servers, via proxy, curr clients, prev servers" $ withSmpServersProxy2Prev $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True True + it "2 servers, directly, prev clients, curr servers" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServers) (agentCfgVPrevPQ, initAgentServers2) $ runTest False False + it "2 servers, via proxy, prev clients, curr servers" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServersProxy) (agentCfgVPrevPQ, initAgentServersProxy2) $ runTest True False + where + prev cfg' = cfg' {smpServerVRange = prevRange supportedServerSMPRelayVRange} + withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgJ2QS qs) a + withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgJ2QS qs) a + withServers2 cfg1 cfg2 a = + withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True @@ -604,10 +618,10 @@ withAgentClientsCfgServers2 aCfg bCfg servers runTest = withAgent 2 bCfg servers testDB2 $ \b -> runTest a b -withAgentClientsServers2 :: HasCallStack => InitialAgentServers -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a -withAgentClientsServers2 aServers bServers runTest = - withAgent 1 agentCfg aServers testDB $ \a -> - withAgent 2 agentCfg bServers testDB2 $ \b -> +withAgentClientsServers2 :: HasCallStack => (AgentConfig, InitialAgentServers) -> (AgentConfig, InitialAgentServers) -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsServers2 (aCfg, aServers) (bCfg, bServers) runTest = + withAgent 1 aCfg aServers testDB $ \a -> + withAgent 2 bCfg bServers testDB2 $ \b -> runTest a b withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a @@ -1102,37 +1116,47 @@ testInviationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = "some user data" (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get invitation link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user cannot get the same invitation link runExceptT (getConnShortLink c 1 shortLink) >>= \case Left (SMP _ AUTH) -> pure () r -> liftIO $ expectationFailure ("unexpected result " <> show r) - runRight $ do - aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn - sndSecure <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe - liftIO $ sndSecure `shouldBe` True - ("", _, CONF confId _ "bob's connInfo") <- get a - allowConnection a bId confId "alice's connInfo" - get a ##> ("", bId, CON) - get b ##> ("", aId, INFO "alice's connInfo") - get b ##> ("", aId, CON) - exchangeGreetingsViaProxy viaProxy a bId b aId + runRight $ testJoinConn_ viaProxy True a bId b connReq + +testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO () +testJoinConn_ viaProxy sndSecure a bId b connReq = do + aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn + sndSecure' <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure' `shouldBe` sndSecure + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetingsViaProxy viaProxy a bId b aId + +testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO () +testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do + let userData = "some user data" + -- can't create short link with previous version + (bId, CCLink connReq Nothing) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe + testJoinConn_ viaProxy sndSecure a bId b connReq testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLinkAsync viaProxy a b = do let userData = "some user data" (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData runRight $ do aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False @@ -1149,18 +1173,18 @@ testContactShortLink viaProxy a b = let userData = "some user data" (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get contact link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user can get the same contact link - (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq - userData3 `shouldBe` userData + linkUserData connData3 `shouldBe` userData runRight $ do (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False @@ -1178,9 +1202,9 @@ testContactShortLink viaProxy a b = let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink - (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData -- one more time shortLink2 <- runRight $ setContactShortLink a contactId updatedData shortLink2 `shouldBe` shortLink @@ -1196,18 +1220,18 @@ testAddContactShortLink viaProxy a b = Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = "some user data" shortLink <- runRight $ setContactShortLink a contactId userData - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get contact link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user can get the same contact link - (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq - userData3 `shouldBe` userData + linkUserData connData3 `shouldBe` userData runRight $ do (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False @@ -1225,9 +1249,9 @@ testAddContactShortLink viaProxy a b = let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink - (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testInviationShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1236,10 +1260,10 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate withSmpServer ps $ do runRight_ $ subscribeConnection a bId - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1249,17 +1273,17 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = "updated user data" withSmpServer ps $ do - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- update user data shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink withSmpServer ps $ do - (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testAddContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1270,17 +1294,17 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = "updated user data" withSmpServer ps $ do - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- update user data shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink withSmpServer ps $ do - (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 376a13cb4..882dd685c 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -63,12 +63,6 @@ testVerifyLintFKeyIndexes = do getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB -withTmpFiles :: IO () -> IO () -withTmpFiles = - bracket_ - (createDirectoryIfMissing False "tests/tmp") - (removeDirectoryRecursive "tests/tmp") - testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) appMigrations diff --git a/tests/AgentTests/ShortLinkTests.hs b/tests/AgentTests/ShortLinkTests.hs index 3fd1033fd..e91472f99 100644 --- a/tests/AgentTests/ShortLinkTests.hs +++ b/tests/AgentTests/ShortLinkTests.hs @@ -5,9 +5,10 @@ module AgentTests.ShortLinkTests (shortLinkTests) where import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) +import AgentTests.EqInstances () import Control.Concurrent.STM import Control.Monad.Except -import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), supportedSMPAgentVRange) +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), linkUserData, supportedSMPAgentVRange) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.ShortLink as SL import Test.Hspec @@ -33,9 +34,9 @@ testInvShortLink = do k = SL.invShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` invConnRequest - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testInvShortLinkBadDataHash :: IO () testInvShortLinkBadDataHash = do @@ -62,9 +63,9 @@ testContactShortLink = do (_linkId, k) = SL.contactShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` contactConnRequest - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testUpdateContactShortLink :: IO () testUpdateContactShortLink = do @@ -80,9 +81,9 @@ testUpdateContactShortLink = do signed = SL.encodeSignUserData (snd sigKeys) supportedSMPAgentVRange updatedUserData Right ud' <- runExceptT $ SL.encryptUserData g k signed -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k (fd, ud') + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k (fd, ud') connReq `shouldBe` contactConnRequest - userData' `shouldBe` updatedUserData + linkUserData connData' `shouldBe` updatedUserData testContactShortLinkBadDataHash :: IO () testContactShortLinkBadDataHash = do diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 1b83526f1..5c0e7f95b 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -117,11 +118,11 @@ testNewQueueRecData :: TVar ChaChaDRG -> QueueMode -> Maybe (LinkId, QueueLinkDa testNewQueueRecData g qm queueData = do rId <- rndId senderId <- rndId - (recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g + (rKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g let qr = QueueRec - { recipientKey, + { recipientKeys = [rKey], rcvDhSecret = C.dh' k pk, senderId, senderKey = Nothing, diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 00e945675..9556c6788 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -14,6 +14,7 @@ import CoreTests.MsgStoreTests import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B import Data.Either (partitionEithers) +import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import SMPClient import qualified Simplex.Messaging.Crypto as C @@ -56,15 +57,16 @@ deriving instance Eq NtfCreds storeLogTests :: Spec storeLogTests = forM_ [QMMessaging, QMContact] $ \qm -> do - ((rId, qr), ntfCreds, date) <- runIO $ do - g <- C.newRandom + g <- runIO C.newRandom + ((rId, qr), ntfCreds, date) <- runIO $ (,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate ((rId', qr'), lnkId, qd) <- runIO $ do - g <- C.newRandom lnkId <- atomically $ EntityId <$> C.randomBytes 24 g let qd = (EncDataBytes "fixed data", EncDataBytes "user data") q <- testNewQueueRecData g qm (Just (lnkId, qd)) pure (q, lnkId, qd) + let pubKey = fst <$> atomically (C.generateAuthKeyPair C.SEd25519 g) + newKeys <- runIO $ L.fromList <$> sequence [pubKey, pubKey] testSMPStoreLog ("SMP server store log, queueMode = " <> show qm) [ SLTC @@ -120,6 +122,12 @@ storeLogTests = saved = [CreateQueue rId qr, UpdateTime rId date], compacted = [CreateQueue rId qr {updatedAt = Just date}], state = M.fromList [(rId, qr {updatedAt = Just date})] + }, + SLTC + { name = "update recipient keys", + saved = [CreateQueue rId qr, UpdateKeys rId newKeys], + compacted = [CreateQueue rId qr {recipientKeys = newKeys}], + state = M.fromList [(rId, qr {recipientKeys = newKeys})] } ] diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 00351befa..df633b570 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -60,6 +60,8 @@ serverTests = do describe "NEW and SKEY commands" $ do testCreateSndSecure testSndSecureProhibited + describe "RKEY command to add additional recipient keys" $ + testCreateUpdateKeys describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete describe "Stress test" stressTest describe "allowNewQueues setting" testAllowNewQueues @@ -272,6 +274,38 @@ testSndSecureProhibited = (sId2, sId) #== "secures queue, same queue ID in response" (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command" +testCreateUpdateKeys :: SpecWith (ATransport, AStoreType) +testCreateUpdateKeys = + it "should create (NEW) and updated recipient keys (RKEY)" $ \(ATransport t, msType) -> + smpTest t msType $ \h -> do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)))) + (rPub', rKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g + Resp "2" rId1 OK <- signSendRecv h rKey ("2", rId, RKEY [rPub, rPub']) + rId1 `shouldBe` rId + -- old key still works + Resp "3" rId2 (INFO _) <- signSendRecv h rKey ("3", rId, QUE) + rId2 `shouldBe` rId + -- new key works too + Resp "4" _ (INFO _) <- signSendRecv h rKey ("4", rId, QUE) + -- remove old key, only keep the new one + Resp "5" _ OK <- signSendRecv h rKey' ("5", rId, RKEY [rPub']) + -- old key no longer works + Resp "6" _ (ERR AUTH) <- signSendRecv h rKey ("6", rId, QUE) + -- add old key back + Resp "7" _ OK <- signSendRecv h rKey' ("7", rId, RKEY [rPub, rPub']) + -- old key works again + Resp "8" _ (INFO _) <- signSendRecv h rKey ("8", rId, QUE) + -- key can remove itself + Resp "9" _ OK <- signSendRecv h rKey ("9", rId, RKEY [rPub']) + -- old key does not work + Resp "10" _ (ERR AUTH) <- signSendRecv h rKey ("10", rId, QUE) + -- new key works + Resp "11" _ (INFO _) <- signSendRecv h rKey' ("11", rId, QUE) + pure () + testCreateDelete :: SpecWith (ATransport, AStoreType) testCreateDelete = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) -> diff --git a/tests/ServerTests/SchemaDump.hs b/tests/ServerTests/SchemaDump.hs new file mode 100644 index 000000000..e3ffdb5cb --- /dev/null +++ b/tests/ServerTests/SchemaDump.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ServerTests.SchemaDump where + +import Control.Concurrent (threadDelay) +import Control.DeepSeq +import Control.Monad (unless, void) +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import Data.Maybe (fromJust, isJust) +import SMPClient +import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) +import Simplex.Messaging.Util (ifM) +import System.Directory (doesFileExist, removeFile) +import System.Environment (lookupEnv) +import System.Process (readCreateProcess, readCreateProcessWithExitCode, shell) +import Test.Hspec + +testDBSchema :: B.ByteString +testDBSchema = "smp_server" + +serverSchemaPath :: FilePath +serverSchemaPath = "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" + +testSchemaPath :: FilePath +testSchemaPath = "tests/tmp/test_server_schema.sql" + +testServerDBOpts :: DBOpts +testServerDBOpts = + DBOpts + { connstr = testServerDBConnstr, + schema = testDBSchema, + poolSize = 3, + createSchema = True + } + +serverSchemaDumpTest :: Spec +serverSchemaDumpTest = do + it "verify and overwrite schema dump" testVerifySchemaDump + it "verify schema down migrations" testSchemaMigrations + +testVerifySchemaDump :: IO () +testVerifySchemaDump = do + savedSchema <- ifM (doesFileExist serverSchemaPath) (readFile serverSchemaPath) (pure "") + savedSchema `deepseq` pure () + void $ createDBStore testServerDBOpts serverMigrations MCConsole + getSchema serverSchemaPath `shouldReturn` savedSchema + +testSchemaMigrations :: IO () +testSchemaMigrations = do + let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) serverMigrations + Right st <- createDBStore testServerDBOpts noDownMigrations MCError + mapM_ (testDownMigration st) $ drop (length noDownMigrations) serverMigrations + closeDBStore st + removeFile testSchemaPath + where + testDownMigration st m = do + putStrLn $ "down migration " <> name m + let downMigr = fromJust $ toDownMigration m + schema <- getSchema testSchemaPath + Migrations.run st $ MTRUp [m] + schema' <- getSchema testSchemaPath + schema' `shouldNotBe` schema + Migrations.run st $ MTRDown [downMigr] + unless (name m `elem` skipComparisonForDownMigrations) $ do + schema'' <- getSchema testSchemaPath + schema'' `shouldBe` schema + Migrations.run st $ MTRUp [m] + schema''' <- getSchema testSchemaPath + schema''' `shouldBe` schema' + +skipComparisonForDownMigrations :: [String] +skipComparisonForDownMigrations = + [ -- snd_secure moves to the bottom on down migration + "20250320_short_links" + ] + +getSchema :: FilePath -> IO String +getSchema schemaPath = do + ci <- (Just "true" ==) <$> lookupEnv "CI" + let cmd = + ("pg_dump " <> B.unpack testServerDBConnstr <> " --schema " <> B.unpack testDBSchema) + <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > " + <> schemaPath + (code, out, err) <- readCreateProcessWithExitCode (shell cmd) "" + print code + putStrLn $ "out: " <> out + putStrLn $ "err: " <> err + threadDelay 20000 + let sed = (if ci then "sed -i" else "sed -i ''") + void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) "" + sch <- readFile schemaPath + sch `deepseq` pure sch diff --git a/tests/Test.hs b/tests/Test.hs index 1e29fa158..674c1aa18 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -44,6 +44,7 @@ import AgentTests.SchemaDump (schemaDumpTest) #if defined(dbServerPostgres) import SMPClient (testServerDBConnectInfo) +import ServerTests.SchemaDump #endif #if defined(dbPostgres) || defined(dbServerPostgres) @@ -85,8 +86,10 @@ main = do describe "Util tests" utilTests describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) - aroundAll_ (postgressBracket testServerDBConnectInfo) - $ describe "SMP server via TLS, postgres+jornal message store" $ + around_ (postgressBracket testServerDBConnectInfo) $ + describe "Server schema dump" serverSchemaDumpTest + aroundAll_ (postgressBracket testServerDBConnectInfo) $ + describe "SMP server via TLS, postgres+jornal message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests #endif describe "SMP server via TLS, jornal message store" $ do From bdf8bf093c566c58253e54a45a8cfde2d87e28f6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 10 Apr 2025 20:58:33 +0100 Subject: [PATCH 10/15] smp server: make symlinks relative --- apps/smp-server/static/a/index.html | 2 +- apps/smp-server/static/c/index.html | 2 +- apps/smp-server/static/i/index.html | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/apps/smp-server/static/a/index.html b/apps/smp-server/static/a/index.html index fbab335f5..1140bcf31 120000 --- a/apps/smp-server/static/a/index.html +++ b/apps/smp-server/static/a/index.html @@ -1 +1 @@ -./apps/smp-server/static/link.html \ No newline at end of file +../link.html \ No newline at end of file diff --git a/apps/smp-server/static/c/index.html b/apps/smp-server/static/c/index.html index fbab335f5..1140bcf31 120000 --- a/apps/smp-server/static/c/index.html +++ b/apps/smp-server/static/c/index.html @@ -1 +1 @@ -./apps/smp-server/static/link.html \ No newline at end of file +../link.html \ No newline at end of file diff --git a/apps/smp-server/static/i/index.html b/apps/smp-server/static/i/index.html index fbab335f5..1140bcf31 120000 --- a/apps/smp-server/static/i/index.html +++ b/apps/smp-server/static/i/index.html @@ -1 +1 @@ -./apps/smp-server/static/link.html \ No newline at end of file +../link.html \ No newline at end of file From a66163dc4664c908c9e2698c598742c9b2eb782c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 11 Apr 2025 12:29:44 +0100 Subject: [PATCH 11/15] agent: additional short link types and encodings (#1509) --- src/Simplex/Messaging/Agent/Protocol.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 419ca1d91..157ea6a86 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -21,6 +21,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} -- | -- Module : Simplex.Messaging.Agent.Protocol @@ -117,6 +118,7 @@ module Simplex.Messaging.Agent.Protocol ConnShortLink (..), AConnShortLink (..), CreatedConnLink (..), + ACreatedConnLink (..), ContactConnType (..), ShortLinkScheme (..), LinkKey (..), @@ -164,8 +166,9 @@ module Simplex.Messaging.Agent.Protocol where import Control.Applicative (optional, (<|>)) -import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) import qualified Data.Aeson.TH as J +import qualified Data.Aeson.Types as JT import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64.URL as B64 @@ -1404,6 +1407,10 @@ data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connShortLink :: Maybe (ConnShortLink m)} deriving (Eq, Show) +data ACreatedConnLink = forall m. ConnectionModeI m => ACCL (SConnectionMode m) (CreatedConnLink m) + +deriving instance Show ACreatedConnLink + data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m) deriving instance Show AConnectionLink @@ -1911,3 +1918,15 @@ instance ConnectionModeI m => FromJSON (CreatedConnLink m) where instance ConnectionModeI m => ToJSON (CreatedConnLink m) where toEncoding = $(J.mkToEncoding defaultJSON ''CreatedConnLink) toJSON = $(J.mkToJSON defaultJSON ''CreatedConnLink) + +instance FromJSON ACreatedConnLink where + parseJSON (Object v) = do + ACR m cReq <- v .: "connFullLink" + shortLink <- v .:? "connShortLink" + pure $ ACCL m $ CCLink cReq shortLink + parseJSON invalid = + JT.prependFailure "bad ACreatedConnLink, " (JT.typeMismatch "Object" invalid) + +instance ToJSON ACreatedConnLink where + toEncoding (ACCL _ ccLink) = toEncoding ccLink + toJSON (ACCL _ ccLink) = toJSON ccLink From 37ce109009d0c5928eb8e03394f4c5e2e3141dfa Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 11 Apr 2025 18:30:43 +0100 Subject: [PATCH 12/15] smp server: .well-known folder for server pages for SimpleX apps to handle preset server links (#1510) * smp server: .well-known folder for server pages for SimpleX apps to handle preset server links * add short link group path * test --- .../apple-app-site-association/index.json | 49 +++++++++++++++++++ .../static/.well-known/assetlinks.json | 16 ++++++ apps/smp-server/web/Static.hs | 9 +++- apps/smp-server/web/Static/Embedded.hs | 3 ++ tests/AgentTests/ConnectionRequestTests.hs | 10 ++++ 5 files changed, 85 insertions(+), 2 deletions(-) create mode 100644 apps/smp-server/static/.well-known/apple-app-site-association/index.json create mode 100644 apps/smp-server/static/.well-known/assetlinks.json diff --git a/apps/smp-server/static/.well-known/apple-app-site-association/index.json b/apps/smp-server/static/.well-known/apple-app-site-association/index.json new file mode 100644 index 000000000..3b513fe61 --- /dev/null +++ b/apps/smp-server/static/.well-known/apple-app-site-association/index.json @@ -0,0 +1,49 @@ +{ + "applinks": { + "details": [ + { + "appIDs": [ + "5NN7GUYB6T.chat.simplex.app" + ], + "components": [ + { + "/": "/contact/*" + }, + { + "/": "/contact" + }, + { + "/": "/invitation/*" + }, + { + "/": "/invitation" + }, + { + "/": "/a/*" + }, + { + "/": "/a" + }, + { + "/": "/c/*" + }, + { + "/": "/c" + }, + { + "/": "/g/*" + }, + { + "/": "/g" + }, + { + "/": "/i/*" + }, + { + "/": "/i" + } + ] + } + ] + } +} \ No newline at end of file diff --git a/apps/smp-server/static/.well-known/assetlinks.json b/apps/smp-server/static/.well-known/assetlinks.json new file mode 100644 index 000000000..e19f8a4c1 --- /dev/null +++ b/apps/smp-server/static/.well-known/assetlinks.json @@ -0,0 +1,16 @@ +[ + { + "relation": [ + "delegate_permission/common.handle_all_urls" + ], + "target": { + "namespace": "android_app", + "package_name": "chat.simplex.app", + "sha256_cert_fingerprints": [ + "5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D", + "3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85", + "AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6" + ] + } + } +] diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index 8d85c4b7f..8a5a31adf 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -82,8 +82,8 @@ generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO () generateSite si onionHost sitePath = do createDirectoryIfMissing True sitePath B.writeFile (sitePath "index.html") $ serverInformation si onionHost - createDirectoryIfMissing True $ sitePath "media" - forM_ E.mediaContent $ \(path, bs) -> B.writeFile (sitePath "media" path) bs + copyDir "media" E.mediaContent + copyDir ".well-known" E.wellKnown createLinkPage "contact" createLinkPage "invitation" createLinkPage "a" @@ -91,6 +91,11 @@ generateSite si onionHost sitePath = do createLinkPage "i" logInfo $ "Generated static site contents at " <> tshow sitePath where + copyDir dir content = do + createDirectoryIfMissing True $ sitePath dir + forM_ content $ \(path, s) -> do + createDirectoryIfMissing True $ sitePath dir takeDirectory path + B.writeFile (sitePath dir path) s createLinkPage path = do createDirectoryIfMissing True $ sitePath path B.writeFile (sitePath path "index.html") E.linkHtml diff --git a/apps/smp-server/web/Static/Embedded.hs b/apps/smp-server/web/Static/Embedded.hs index 23698dd6f..c1c4fde2f 100644 --- a/apps/smp-server/web/Static/Embedded.hs +++ b/apps/smp-server/web/Static/Embedded.hs @@ -13,3 +13,6 @@ linkHtml = $(embedFile "apps/smp-server/static/link.html") mediaContent :: [(FilePath, ByteString)] mediaContent = $(embedDir "apps/smp-server/static/media/") + +wellKnown :: [(FilePath, ByteString)] +wellKnown = $(embedDir "apps/smp-server/static/.well-known/") diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index d74979434..1782d3ccd 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -332,6 +333,15 @@ connectionRequestTests = `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") restoreShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")) `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef") + Right (lnk :: ConnShortLink 'CMContact) <- pure $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI" + Right (lnk' :: ConnShortLink 'CMContact) <- pure $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM" + let presetSrv :: SMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" + shortenShortLink [presetSrv] lnk `shouldBe` lnk' + restoreShortLink [presetSrv] lnk' `shouldBe` lnk + Right (inv :: ConnShortLink 'CMInvitation) <- pure $ strDecode "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI" + Right (inv' :: ConnShortLink 'CMInvitation) <- pure $ strDecode "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY" + shortenShortLink [presetSrv] inv `shouldBe` inv' + restoreShortLink [presetSrv] inv' `shouldBe` inv where smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a From 76aad61f007936ef10632785ffc4150e897e02d5 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 11 Apr 2025 23:18:23 +0100 Subject: [PATCH 13/15] smp server: update server page for short links to correctly change URI for apps (#1511) * smp server: update server page for short links to correctly change URI for apps * change page titles --- apps/smp-server/static/link.html | 25 ++++++++++++------------- apps/smp-server/static/media/contact.js | 13 ++++++++++++- apps/smp-server/web/Static.hs | 1 + 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/apps/smp-server/static/link.html b/apps/smp-server/static/link.html index cbab7324f..b5be2d7ab 100644 --- a/apps/smp-server/static/link.html +++ b/apps/smp-server/static/link.html @@ -142,8 +142,7 @@ class="hidden xl:block h-screen pt-[66px] bg-white dark:bg-gradient-radial-mobile dark:lg:bg-gradient-radial">
-

You received a - 1-time link to connect on SimpleX Chat

+

This is a one-time link of the SimpleX network user

Scan the QR code with the SimpleX Chat app on your phone or tablet.

@@ -184,10 +183,8 @@ class="block xl:hidden pt-[106px] py-[90px] bg-white dark:bg-gradient-radial-mobile dark:lg:bg-gradient-radial">
-

You received a - 1-time link to connect on SimpleX Chat

-

To make a - connection:

+

This is a one-time link of the SimpleX network user

+

To make a connection:

Install SimpleX app

@@ -506,13 +503,15 @@ const url = window.location.href const messageElements = document.getElementsByClassName('primary-header-contact') - if (url.includes('/invitation')) { - for (let element of messageElements) { - element.textContent = 'You received a 1-time link to connect on SimpleX Chat' - } - } else { - for (let element of messageElements) { - element.textContent = 'You received an address to connect on SimpleX Chat' + for (let element of messageElements) { + if (url.includes('/g') || url.includes('&data=%7B%22groupLinkId%22%3A')) { + element.innerHTML = 'This is a public group address on SimpleX network' + } else if (url.includes('/a') || url.includes('/contact')) { + element.innerHTML = 'This is a public address of the SimpleX network user' + } else if (url.includes('/i') || url.includes('/invitation')) { + element.innerHTML = 'This is a one-time link of the SimpleX network user' + } else if (url.includes('/c')) { + element.innerHTML = 'This is a public channel address on SimpleX network' } } diff --git a/apps/smp-server/static/media/contact.js b/apps/smp-server/static/media/contact.js index b1a99b74f..6df303f6c 100644 --- a/apps/smp-server/static/media/contact.js +++ b/apps/smp-server/static/media/contact.js @@ -20,7 +20,18 @@ parsedURI.pathname = "/" + action connURI = parsedURI.toString() console.log("connection URI: ", connURI) - mobileConnURIanchor.href = "simplex:" + parsedURI.pathname + parsedURI.hash + const hash = parsedURI.hash + const hostname = parsedURI.hostname + let appURI = "simplex:" + parsedURI.pathname + appURI += action.length > 1 // not short link + ? hash + : !hash.includes("?") // otherwise add server hostname + ? hash + "?h=" + hostname // no parameters + : !hash.includes("?h=") && !hash.includes("&h=") + ? hash + "&h=" + hostname // no "h" parameter + : hash.replace(/([?&])h=([^&]+)/, `$1h=${hostname},$2`) // add as the first hostname to "h" parameter + mobileConnURIanchor.href = appURI + console.log("app URI: ", appURI) connURIel.innerText = "/c " + connURI for (const connQRCode of connQRCodes) { try { diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index 8a5a31adf..a0d2b776c 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -88,6 +88,7 @@ generateSite si onionHost sitePath = do createLinkPage "invitation" createLinkPage "a" createLinkPage "c" + createLinkPage "g" createLinkPage "i" logInfo $ "Generated static site contents at " <> tshow sitePath where From ccdd8e1775cf4a96063701ab6bcd9fa987a4f169 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 13 Apr 2025 13:43:27 +0100 Subject: [PATCH 14/15] agent: additional encodings for short links --- src/Simplex/Messaging/Agent/Protocol.hs | 17 +++++++++++++++++ tests/AgentTests/SchemaDump.hs | 3 +-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 157ea6a86..43cceb376 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol ShortLinkScheme (..), LinkKey (..), sameConnReqContact, + sameShortLinkContact, simplexChat, connReqUriP', simplexConnReqUri, @@ -1413,6 +1414,11 @@ deriving instance Show ACreatedConnLink data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m) +instance Eq AConnectionLink where + ACL m cl == ACL m' cl' = case testEquality m m' of + Just Refl -> cl == cl' + _ -> False + deriving instance Show AConnectionLink instance ConnectionModeI m => StrEncoding (ConnectionLink m) where @@ -1436,6 +1442,13 @@ instance ConnectionModeI m => ToJSON (ConnectionLink m) where instance ConnectionModeI m => FromJSON (ConnectionLink m) where parseJSON = strParseJSON "ConnectionLink" +instance ToJSON AConnectionLink where + toEncoding = strToJEncoding + toJSON = strToJSON + +instance FromJSON AConnectionLink where + parseJSON = strParseJSON "AConnectionLink" + instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k @@ -1569,6 +1582,10 @@ sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUr where same (q, q') = sameQAddress (qAddress q) (qAddress q') +sameShortLinkContact :: ConnShortLink 'CMContact -> ConnShortLink 'CMContact -> Bool +sameShortLinkContact (CSLContact _ ct srv k) (CSLContact _ ct' srv' k') = + ct == ct' && sameSrvAddr srv srv' && k == k' + checkConnMode :: forall t m m'. (ConnectionModeI m, ConnectionModeI m') => t m' -> Either String (t m) checkConnMode c = case testEquality (sConnectionMode @m) (sConnectionMode @m') of Just Refl -> Right c diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 882dd685c..736863364 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -4,7 +4,6 @@ module AgentTests.SchemaDump where import Control.DeepSeq -import Control.Exception (bracket_) import Control.Monad (unless, void) import Data.List (dropWhileEnd) import Data.Maybe (fromJust, isJust) @@ -17,7 +16,7 @@ import Simplex.Messaging.Agent.Store.SQLite.DB (TrackQueries (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import Simplex.Messaging.Util (ifM) -import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile) +import System.Directory (doesFileExist, removeFile) import System.Process (readCreateProcess, shell) import Test.Hspec From c2c4730953c662ea0504e8ca53c60eec417ab231 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 13 Apr 2025 22:02:48 +0100 Subject: [PATCH 15/15] smp server: serve .well-known folder via server pages (#1514) --- .../index.json => apple-app-site-association} | 0 apps/smp-server/web/Static.hs | 32 +++++++++++++------ 2 files changed, 22 insertions(+), 10 deletions(-) rename apps/smp-server/static/.well-known/{apple-app-site-association/index.json => apple-app-site-association} (100%) diff --git a/apps/smp-server/static/.well-known/apple-app-site-association/index.json b/apps/smp-server/static/.well-known/apple-app-site-association similarity index 100% rename from apps/smp-server/static/.well-known/apple-app-site-association/index.json rename to apps/smp-server/static/.well-known/apple-app-site-association diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index a0d2b776c..50e4415eb 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -14,7 +14,8 @@ import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Text.Encoding (encodeUtf8) import Network.Socket (getPeerName) -import Network.Wai (Application) +import Network.Wai (Application, Request (..)) +import Network.Wai.Application.Static (StaticSettings (..)) import qualified Network.Wai.Application.Static as S import qualified Network.Wai.Handler.Warp as W import qualified Network.Wai.Handler.Warp.Internal as WI @@ -31,12 +32,13 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath import UnliftIO.Concurrent (forkFinally) import UnliftIO.Exception (bracket, finally) +import qualified WaiAppStatic.Types as WAT serveStaticFiles :: EmbeddedWebParams -> IO () serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do forM_ webHttpPort $ \port -> flip forkFinally (\e -> logError $ "HTTP server crashed: " <> tshow e) $ do logInfo $ "Serving static site on port " <> tshow port - W.runSettings (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath) + W.runSettings (mkSettings port) app forM_ webHttpsParams $ \WebHttpsParams {port, cert, key} -> flip forkFinally (\e -> logError $ "HTTPS server crashed: " <> tshow e) $ do logInfo $ "Serving static site on port " <> tshow port <> " (TLS)" WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app @@ -72,18 +74,30 @@ warpSettings :: W.Settings warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings staticFiles :: FilePath -> Application -staticFiles root = S.staticApp settings +staticFiles root = S.staticApp settings . changeWellKnownPath where - settings = (S.defaultFileServerSettings root) - { S.ssListing = Nothing - } + settings = defSettings {ssListing = Nothing, ssGetMimeType = getMimeType} + defSettings = S.defaultFileServerSettings root + getMimeType f + | WAT.fromPiece (WAT.fileName f) == "apple-app-site-association" = pure "application/json" + | otherwise = (ssGetMimeType defSettings) f + changeWellKnownPath req = case pathInfo req of + ".well-known" : rest -> + req + { pathInfo = "well-known" : rest, + rawPathInfo = "/well-known/" <> B.drop pfxLen (rawPathInfo req) + } + _ -> req + pfxLen = B.length "/.well-known/" generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO () generateSite si onionHost sitePath = do createDirectoryIfMissing True sitePath B.writeFile (sitePath "index.html") $ serverInformation si onionHost copyDir "media" E.mediaContent - copyDir ".well-known" E.wellKnown + -- `.well-known` path is re-written in changeWellKnownPath, + -- staticApp does not allow hidden folders. + copyDir "well-known" E.wellKnown createLinkPage "contact" createLinkPage "invitation" createLinkPage "a" @@ -94,9 +108,7 @@ generateSite si onionHost sitePath = do where copyDir dir content = do createDirectoryIfMissing True $ sitePath dir - forM_ content $ \(path, s) -> do - createDirectoryIfMissing True $ sitePath dir takeDirectory path - B.writeFile (sitePath dir path) s + forM_ content $ \(path, s) -> B.writeFile (sitePath dir path) s createLinkPage path = do createDirectoryIfMissing True $ sitePath path B.writeFile (sitePath path "index.html") E.linkHtml