Compare commits

...
Author SHA1 Message Date
spaced4ndy 3d2bf6ce43 comment 2025-07-25 13:24:08 +04:00
spaced4ndy a678758de8 don't catch sql error second time 2025-07-25 12:42:50 +04:00
spaced4ndy b51969c498 postgres: print sql errors and exceptions details 2025-07-25 12:07:39 +04:00
Evgeny Poberezkin 846be50f72 6.4.1.0 2025-07-21 15:22:47 +01:00
Evgeny c0f357d817 servers: control port session improvements (#1591)
* servers: prohibit changing role during control port session

* quota for blocked queues

* allow disabling blocking and quota

* fix test

* fix INI file
2025-07-21 15:19:43 +01:00
Evgeny 40fc09a93d smp server: additional stat counter for ntf credentials created together with the queue (#1589)
* smp server: additional stat counter for ntf credentials created together with the queue

* fix prometheus

* fix test

* fix qSub
2025-07-18 09:26:25 +01:00
Evgeny 2a90a2c552 smp protocol: create notification credentials via NEW command that creates the queue (#1586)
* smp protocol: create notification credentials via NEW command that creates the queue

* create ntf subscription for queues created with ntf credetials

* do not create ntf credentials when switching connection to another queue
2025-07-16 16:46:45 +01:00
Evgeny Poberezkin b6ea025333 docs: update build badge 2025-07-15 10:03:27 +01:00
Evgeny Poberezkin d3e2d9ac5b docs: changelog v6.4 2025-07-13 15:20:26 +01:00
Evgeny Poberezkin 85a7fbf538 6.4.0.12 2025-07-12 14:19:32 +01:00
Evgeny 62733ef4c1 smp server: refactor subscriptions and delivery in order to always response SOK on subscription with an optional message to follow. (#1573)
* smp server: refactor subscriptions and delivery

* metric for time between MSG and ACK

* cleanup

* refactor pattern match for ghc 8.10.7

* time buckets

* split max time metric

* histogram

* fix
2025-07-12 14:18:38 +01:00
Evgeny 99e59b73a3 agent: fix message delivery in case one of the connections has no snd queue for any reason - it could break delivery to all connections (#1585)
* agent: fix message delivery in case one of the connections has no snd queue for any reason - it could break delivery to all connections

* simplify

* comment

* refactor, also postpone failing on ratchet sync send prohibited errors

* postpone failing on connection errors to allow subsequent connections succeed
2025-07-10 10:21:12 +01:00
Evgeny 384a3352cf ntf server: more efficient status update query (#1584) 2025-07-08 23:01:57 +01:00
Evgeny Poberezkin 7a04fdff2e 6.4.0.11.3 2025-07-07 18:50:31 +01:00
Evgeny ba3c75e58c smp server: correctly track if ntf service is subscribed and total subscribed queues count (fixes race condition between NSUB and NSUBS from notification server) (#1583) 2025-07-07 18:49:47 +01:00
Evgeny Poberezkin 1062ccc5c3 6.4.0.11.2 2025-07-07 10:07:54 +01:00
Evgeny 36f05e272e agent: support different timeouts for interactive and background requests (#1582)
* agent: support different timeouts for interactive and background requests

* fix tests

* use one constructor for the first request and for retries
2025-07-07 09:38:52 +01:00
Evgeny Poberezkin 660c4293f0 6.4.0.11.1 2025-07-05 11:35:27 +01:00
spaced4ndyandEvgeny Poberezkin 1b8613d767 build: do not exclude postgres modules for client_library flag (#1579)
* don't exclude postgres modules for client_library flag

* fix build with client and server postgres flag

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2025-07-04 17:31:57 +01:00
Evgeny bfa52c4ba5 docs: update RFC for short links to match the implementation (#1581) 2025-07-03 18:09:02 +01:00
spaced4ndy c5eb66038b agent: allow to accept contact requests after address is deleted (#1580) 2025-07-03 09:29:39 +00:00
Evgeny Poberezkin a46edd60f0 6.4.0.11 2025-06-30 21:50:21 +01:00
Evgeny b4bcfd325b agent: better handling errors during connection handshake retries (#1578)
* agent: handle invitation connection handshake errors

* fix/test retries for connecting via address
2025-06-25 19:06:00 +01:00
Evgeny 976bd3a389 agent: short link encodings (#1577) 2025-06-24 10:06:44 +01:00
50 changed files with 1738 additions and 1125 deletions
+29 -2
View File
@@ -1,3 +1,30 @@
# 6.4.1
SMP protocol:
- create notification credentials via NEW command that creates the queue (#1586)
SMP server:
- control port session improvements (#1591)
- additional stat counter for ntf credentials created together with the queue (#1589)
# 6.4.0
SMP protocol (server/client):
- support associated queue data and short connection links (see [RFC](./rfcs/2025-03-16-smp-queues.md)).
- service certificates to optimize subscriptions.
SMP agent:
- support retries for interactive connection handshakes.
- use web port 443 by default for preset servers.
- use static RNG function to avoid creating dynamic C stubs when generating sntrup keys (it was detected as Dynamic Code Loading in GrapheneOS).
- different timeouts for interactive and background operations.
Ntf server:
- PostgreSQL storage.
- Prometheus metrics.
- use service certificates.
- fix repeat token registration.
# 6.3.2
Servers:
@@ -18,7 +45,7 @@ Servers:
- update script (simplex-servers-update) downloads scripts from the specified or the latest stable tag.
SMP server:
- support for PostrgreSQL database for queue records for higher traffic servers.
- support for PostgreSQL database for queue records for higher traffic servers.
- fix old clients sending messages to new servers (#1443)
- remove empty journals when opening message queues and expiring idle queues (#1456, #1458).
- additional start options (#1465):
@@ -74,7 +101,7 @@ Servers: more reliable restoring of state.
SMP server: reduced memory usage and faster start.
Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378):
Notifications: compensate for iOS notifications being dropped by Apple while device is offline (#1378):
- Ntf server: send multiple SMP notifications in one iOS notification.
- Agent: get multiple messages for one iOS notification.
+6 -6
View File
@@ -1,6 +1,6 @@
# SimpleXMQ
[![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild)
[![GitHub build](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml/badge.svg)](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml)
[![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplexmq)](https://github.com/simplex-chat/simplexmq/releases)
📢 SimpleXMQ v1 is released - with many security, privacy and efficiency improvements, new functionality - see [release notes](https://github.com/simplex-chat/simplexmq/releases/tag/v1.0.0).
@@ -116,7 +116,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
2. Run your Docker container.
- `smp-server`
You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
```sh
docker run -d \
@@ -129,7 +129,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
```
- `xftp-server`
You must change **your_ip_or_domain** and **maximum_storage**.
```sh
docker run -d \
@@ -187,7 +187,7 @@ On Linux, you can build smp server using Docker.
3. Run your Docker container.
- `smp-server`
You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
```sh
docker run -d \
@@ -200,7 +200,7 @@ On Linux, you can build smp server using Docker.
```
- `xftp-server`
You must change **your_ip_or_domain** and **maximum_storage**.
```sh
docker run -d \
@@ -247,7 +247,7 @@ On Linux, you can build smp server using Docker.
`xftp-server`
```sh
cabal list-bin exe:xftp-server
cabal list-bin exe:xftp-server
```
- Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
+94 -108
View File
@@ -5,22 +5,19 @@
This change is related to these problems:
- differentiating queue retention time,
- supporting MITM-resistant short connection links,
- improving notifications.
This RFC is based on the previous discussions about short links, blob storage and notifications ([1](./2024-06-21-short-links.md), [2](./2024-09-09-smp-blobs.md), [3](./2024-11-25-queue-blobs-2.md), [4](./2024-09-25-ios-notifications-2.md)).
SMP protocol supports two types of queues - queues to communicate over and queues to send invitations. While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
SMP protocol supports two types of queues - queues to send messages (messaging queues) and queues to send invitations to connect (contact queues). While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
Simply designating queue types would allow to use this information to decide for how long to retain queues, and potentially extending it:
- unsecured 1-time invitation queues with sndSecure (support of securing by sender) - e.g., 3 months.
- contact address queues without sndSecure - e.g., 3 years without activity.
- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and superpeer addresses for the group.
This proposal also combines NEW and NKEY command to streamline notifications in preparation to reworking of the notifications protocol.
- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and super-peer addresses for the group.
## Design objectives
We want to achieve these objectives:
We want to achieve these objectives for short links and associated queue data:
1. no possibility to provide incorrect SenderId inside link data (e.g. from another queue).
2. link data cannot be accessed by the server unless it has the link.
3. prevent MITM attack by the server, including the server that obtained the link.
@@ -28,17 +25,17 @@ We want to achieve these objectives:
5. for one-time links, prevent accessing link data by link observers who did not compromise the server.
6. allow changing the user-defined part of link data.
7. avoid changing the link when user-defined part of link data changes, while preventing MITM attack by the server on user-defined part, even if it has the link.
8. retain the quality that it is impossible to check the existense of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
8. retain the quality that it is impossible to check the existence of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
To achieve these objectives the queue data must have immutable part and mutable part.
To achieve these objectives the queue data will include fixed (immutable) and user-defined (mutable) parts.
Immutable part would include:
- full conection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
Fixed part would include:
- full connection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
- public signature key to verify mutable part of link data.
Signed mutable part would inlcude:
- any links to chat relays that should be contacted instead of this queue (not in this RFC), but would allow delegating group connections and contact request connections to prevent spam, hiding online presense, etc.
- and user-defined data - user profile or group profile.
Signed mutable part would include:
- any links to chat relays that should be contacted instead of this queue (not in this RFC), to allow delegating group connections and contact request connections to prevent spam, hiding online presence, etc.
- and user-defined data - user profile or group profile, chat preferences, welcome message, etc.
The link itself should include both the key and auth tag from the encryption of immutable part. Accessing one-time link data should require providing sender key and signing the command (`LKEY`).
@@ -49,8 +46,6 @@ Current NEW and NKEY commands:
```haskell
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
-- | Queue IDs and keys, returned in IDS response
data QueueIdsKeys = QIK
{ rcvId :: RecipientId,
@@ -70,43 +65,48 @@ data NewQueueReq = NewQueueReq
rcvDhKey :: RcvPublicDhKey,
auth_ :: Maybe BasicAuth,
subMode :: SubscriptionMode,
queueData :: Maybe QueueReqData,
ntfCreds :: Maybe NewNtfCreds
queueReqData :: Maybe QueueReqData,
}
-- 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
-- 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 QueueReqData
= QRMessaging (Maybe (SenderId, QueueLinkData))
| QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
-- 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)
-- It allows to include sender ID inside encrypted associated link data as part of full connection URI without requesting it from the server, but prevents checking if a given sender ID exists (queue creation would fail for a duplicate sender ID), as sha3-384 derivation is not reversible.
type QueueLinkData = (EncFixedLinkData, EncUserDataBytes)
type EncImmutableDataBytes = ByteString
type EncFixedLinkData = ByteString
type EncUserDataBytes = ByteString
-- We need to use binary encoding for AConnectionRequestUri to reduce its size
-- connReq including the full link allows connection redundancy.
-- The clients would reject changed immutable data (based on auth tag in the link) and
-- AConnectionRequestUri where SenderId of the queue does not match.
data ImmutableLinkData = ImmutableLinkData
{ signature :: SignatureEd25519, -- signature of the remaining part of immutable data
connReq :: AConnectionRequestUri,
sigKey :: PublicKeyEd25519
-- We need to use binary encoding for ConnectionRequestUri to reduce its size
-- The clients would reject changed immutable data and
-- ConnectionRequestUri where server or SenderId of the queue do not match.
data FixedLinkData c = FixedLinkData
{ agentVRange :: VersionRangeSMPA,
rootKey :: C.PublicKeyEd25519,
connReq :: ConnectionRequestUri c
}
-- This part of link data can also include any relays, but possibly we need a separate blob for it
data UserLinkData = UserLinkData
{ signature :: SignatureEd25519, -- signs the remaining part of the data
userData :: ByteString -- the max size needs to be estimated, but it is likely to be ~ 14kb
}
data ConnLinkData c where
InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> 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 :: UserLinkData
} -> ConnLinkData 'CMContact
newtype UserLinkData = UserLinkData ByteString
-- | Updated queue IDs and keys, returned in IDS response
data QueueIdsKeys = QIK
@@ -114,17 +114,14 @@ data QueueIdsKeys = QIK
sndId :: SenderId, -- server-generated
rcvPublicDhKey :: RcvPublicDhKey,
sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied?
linkId :: Maybe LinkId, -- server-generated
serverNtfCreds :: Maybe ServerNtfCreds -- currently returned in NID response
linkId :: Maybe LinkId -- server-generated
}
data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId is server-generated.
```
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:
In addition to that we add the command allowing to update and also to retrieve and secure the queue and get link data in one request, to have only one request:
```haskell
-- This command allows to set all data or to update mutlable part of contact address queue.
-- This command allows to set all data or to update mutable 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.
@@ -147,58 +144,43 @@ LKEY :: SndPublicAuthKey -> Command Sender
-- Entity ID is LinkId
LGET :: Command Sender
-- Response to LGET, LSKEY and LSGET
-- Response to LGET and LSET
-- 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 the first 24 bytes of 48 in `sha3-384(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 existence, 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.
To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` (and for contact queue, also `link_id`, which would be random as it is derived from hash of fixed link data that includes a random signature key) 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.
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:
Alternative solutions that would allow retries that were 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.
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 existence checks (oracle attack).
**Prepare queue link data**
This scheme results in 32 byte binary size for contact addresses and 56 bytes for 1-time invitation links.
- the queue owner generates a random 256 bit `link_key` that will be used in the link URI.
- for 1-time links: crypto_box key and 2 nonces to encrypt link data are derived from link_uri using HKDF: `cb_key <> nonce1 <> nonce2 = HKDF(link_key, 80 bytes)` (nonce1 is used for immutable and nonce2 for user-defined parts).
- for contact address links: key and 2 nonces and linkId will be derived: `link_id <> cb_key <> nonce1 <> nonce2 = HKDF(link_key, 104 bytes)`
- both parts of link data are encrypted with crypto_box, and included into `NEW` or `LNEW` commands.
For fixed link data.
**Retrieving queue link data**
- the sender uses `LinkId` from URI (or derived from URI) as entity ID to retrieve link data.
- 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. Generate random `nonce` (also used as a correlation ID for server command) and signature key (public `rootKey` included in fixed data).
2. Compute sender ID from `nonce` as the first 24 bytes of sha3-384 of `nonce`.
3. Generate other keys for queue address, including queue e2e encryption keys and double ratchet connection e2e encryption keys.
4. Construct the full connection address to be included in fixed data.
5. `link_key = SHA3-256(fixed_data)` - used as part of the link, and to derive the key to encrypt content.
6. 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.
2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated.
7. Encrypt: `(ct1, tag1) = secret_box(fixed_data, key, nonce1)`, where `nonce1` is a random nonce
5. Store: `(nonce1, ct1, tag1)` stored as fixed 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`.
2. Sign `user_data` with key included in `fixed_data`.
3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`.
4. Store: `(nonce2, ct2, tag2)`
@@ -208,13 +190,15 @@ Link recipient:
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.
3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`:
1) contact address: `LGET` command, that allows retrieving link data multiple times.
2) 1-time invitation: `LKEY` command, that non-optionally secures the queue, and only allows repeated link data retrievals if the same sender's key is provided and signs the transmission. This prevents link data retrieval by link observers.
4. Decrypt: `(signature1, fixed_data) = decrypt (nonce1, ct1, tag1)`.
5. Verify: `SHA3-256(fixed_data) == link_key`, abort if not.
6. Decrypt: `(signature2, used_data) = decrypt(nonce2, ct2, tag2)`.
7. Verify signatures using key in the fixed data, abort if they don't match.
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.
While using content hash as encryption key is unconventional, it is not completely unusual - 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 `fixed_data` contains mostly random keys.
## Threat model
@@ -222,10 +206,10 @@ While using content hash as encryption key is unconventional, it is not complete
can:
- delete link data.
- hide link selectively from some requests.
- hide link data selectively for some or for all requests.
cannot:
- undetectably replace link data, even if they have the link (objective 3).
- undetectably replace link data, even if it has the link (objective 3).
- access unencrypted link data, whether it was or was not accessed by the accepting party, provided it has no link (objective 2).
- observe IP addresses of the users accessing link data, if private routing is used.
@@ -236,10 +220,10 @@ can:
cannot:
- undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5).
- undetectbly check the existense of messaging queue or 1-time link (objective 8).
- undetectably check the existence of messaging queue or 1-time link (objective 8).
- replace or delete the link data.
**Queue owner who did not comprmise the server**:
**Queue owner who did not compromise the server**:
cannot:
- redirect connecting user to another queue, on the same or on another server (objective 1).
@@ -247,40 +231,42 @@ cannot:
## Correlation of design objectives with design elements
1. The presense of `SenderId` in `LINK` response from the server.
1. The presence of `SenderId` in `LNK` response from the server.
2. Encryption of link data with crypto_box.
3. Auth tag in the link prevents server modification of immutable part of link data. Signature verification key in immutable part, and signing of mutable part prevents server modification of mutable part of link data.
4. No server command to change immutable part of link data once it's set.
3. Deriving encryption key from the hash of fixed data prevents it being modified by the server - any change would be detected and rejected by the client, as the hash of fixed data won't match the link. Signature verification with the key from fixed data, and signing of mutable data prevents server modification of mutable data.
4. No server command to change fixed data once it's set. Also, changing fixed data would require changing the link.
5. 1-time link data can only be accessed with `LKEY` command, that while allows retries to mitigate network failures, will require the same key for retries.
6. `LSET` command.
7. The link only includes auth tag for immutable part, mutable part includes signature.
8. Temporarily public IDs (SenderId and LinkId for 1-time invitations) are generated server-side, and cannot be provided by the clients when creating the queues to check if these IDs are free.
7. The link is derived from fixed data only, so it does not change when mutable link data changes. Mutable part is signed preventing server MITM attacks.
8. SenderId is derived from request correlation ID, so it cannot be arbitrary defined to check existence of some known queue. LinkId for 1-time invitation is generated server-side, so it cannot be provided by the client when creating the queues to check if these IDs are used.
## Syntax for short links
The proposed syntax:
The syntax:
```abnf
shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ]
shortConnectionLink = uriAuthority "/" linkUri [ "?" param *( "&" param ) ]
uriAuthority = %s"https://" smpServerHost / "simplex:" ; using simplex: scheme requires including host in the parameter hostParam
smpServerHost = <hostname> ; RFC1123, RFC5891
linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes
oneTimeLinkBytes = <base64url(linkId | linkKey)> ; 56 bytes / 75 base64 encoded characters
contactLinkBytes = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
; linkId - 96 bits/24 bytes
linkUri = %s"i#" oneTimeLink / contactType "#" contactLink
contactType = %s"a" / %s"g" / %s"c" ; contact / group / channel address, respectively
oneTimeLink = <base64url(linkId)> "/" <base64url(linkKey)> ; 56 bytes / 75 base64 encoded characters
contactLink = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
; linkId - 192 bits/24 bytes
; linkKey - 256 bits/32 bytes
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.
fingerprint = <base64url(server offline certificate fingerprint)>
hostnames = "h=" <hostname> *( "," <hostname> ) ; additional hostnames, e.g. onion
param = hostsParam / portParam / certHashParam
hostsParam = %s"h=" host *("," host) ; additional hostnames, e.g. onion
portParam = %s"p=" 1*DIGIT ; server port
certHashParam = %s"c=" <base64url(server offline certificate fingerprint)>
```
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.
To have shorter links fingerprint and additional server hostnames do not need to be specified for pre-configured 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 (103 characters):
Example one-time link for preset server (104 characters):
```
https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234
https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij01/23456789abcdefghij0123456789abcdefghij01234
```
Example contact link for preset server (71 characters):
@@ -289,16 +275,16 @@ Example contact link for preset server (71 characters):
https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc
```
Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters):
Example contact link for user-defined server (with fingerprint, but without onion hostname - 117 characters):
```
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc
https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU
```
Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters):
Example contact link for user-defined server (with fingerprint ant onion hostname - 182 characters):
```
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU&h=beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion
```
For the links to work in the browser the servers must provide server pages.
+11 -10
View File
@@ -1,7 +1,7 @@
cabal-version: 1.12
name: simplexmq
version: 6.4.0.10.1
version: 6.4.1.0
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -162,6 +162,7 @@ library
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
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
else
exposed-modules:
Simplex.Messaging.Agent.Store.SQLite
@@ -208,6 +209,14 @@ library
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
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
if flag(client_postgres) || flag(server_postgres)
exposed-modules:
Simplex.Messaging.Agent.Store.Postgres
Simplex.Messaging.Agent.Store.Postgres.Common
Simplex.Messaging.Agent.Store.Postgres.DB
Simplex.Messaging.Agent.Store.Postgres.Migrations
Simplex.Messaging.Agent.Store.Postgres.Util
if !flag(client_library)
exposed-modules:
Simplex.FileTransfer.Client.Main
@@ -240,14 +249,6 @@ library
Simplex.Messaging.Server.StoreLog.ReadWrite
Simplex.Messaging.Server.StoreLog.Types
Simplex.Messaging.Transport.WebSockets
if flag(client_postgres) || flag(server_postgres)
exposed-modules:
Simplex.Messaging.Agent.Store.Postgres
Simplex.Messaging.Agent.Store.Postgres.Common
Simplex.Messaging.Agent.Store.Postgres.DB
Simplex.Messaging.Agent.Store.Postgres.Migrations
Simplex.Messaging.Agent.Store.Postgres.Util
if flag(server_postgres)
exposed-modules:
Simplex.Messaging.Notifications.Server
@@ -559,7 +560,7 @@ test-suite simplexmq-test
build-depends:
memory
, sqlcipher-simple
if !flag(client_postgres) || flag(server_postgres)
if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres)
build-depends:
deepseq ==1.4.*
, process
+6 -4
View File
@@ -36,8 +36,10 @@ import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Transport
import Simplex.Messaging.Client
( NetworkConfig (..),
NetworkRequestMode (..),
ProtocolClientError (..),
TransportSession,
netTimeoutInt,
chooseTransportHost,
defaultNetworkConfig,
transportClientConfig,
@@ -107,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
ProtocolServer _ host port keyHash = srv
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN
let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN
http2Config = xftpHTTP2Config tcConfig config
clientVar <- newTVarIO Nothing
let usePort = if null port then "443" else port
@@ -178,7 +180,7 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
defaultHTTP2ClientConfig
{ bodyHeadSize = xftpBlockSize,
suportedTLSParams = defaultSupportedParams,
connTimeout = tcpConnectTimeout,
connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
transportConfig
}
@@ -268,11 +270,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
maybe tcpTimeout (chunkTimeout cfg) chunkSize_
maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
chunkTimeout :: XFTPClientConfig -> Word32 -> Int
chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
+3 -3
View File
@@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.FileTransfer.Client
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
import Simplex.Messaging.TMap (TMap)
@@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
waitForXFTPClient clientVar = do
let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
liftEither $ case client_ of
Just (Right c) -> Right c
Just (Left e) -> Left e
@@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
where
closeClient cVar = do
let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
_ -> pure ()
+3 -6
View File
@@ -54,7 +54,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server.Control (CPClientRole (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
@@ -277,12 +277,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
CPSkip -> False
_ -> True
processCP h role = \case
CPAuth auth -> atomically $ writeTVar role $! newRole cfg
CPAuth auth -> controlPortAuth h user admin role auth
where
newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
| Just auth == admin = CPRAdmin
| Just auth == user = CPRUser
| otherwise = CPRNone
XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
CPDelete fileId -> withUserRole $ unliftIO u $ do
fs <- asks store
File diff suppressed because it is too large Load Diff
+191 -176
View File
@@ -251,7 +251,6 @@ import Simplex.Messaging.Protocol
ErrorType,
MsgFlags (..),
MsgId,
NtfPublicAuthKey,
NtfServer,
NtfServerWithAuth,
ProtoServer,
@@ -261,12 +260,14 @@ import Simplex.Messaging.Protocol
ProtocolType (..),
ProtocolTypeI (..),
QueueIdsKeys (..),
ServerNtfCreds (..),
RcvMessage (..),
RcvNtfPublicDhKey,
SMPMsgMeta (..),
SProtocolType (..),
SndPublicAuthKey,
SubscriptionMode (..),
NewNtfCreds (..),
QueueReqData (..),
QueueLinkData,
UserProtocol,
@@ -283,7 +284,7 @@ import Simplex.Messaging.Session
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion)
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -568,8 +569,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
slowNetworkConfig :: NetworkConfig -> NetworkConfig
slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb} =
cfg {tcpConnectTimeout = slow tcpConnectTimeout, tcpTimeout = slow tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
cfg {tcpConnectTimeout = slowTimeout tcpConnectTimeout, tcpTimeout = slowTimeout tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
where
slowTimeout (NetworkTimeout t1 t2) = NetworkTimeout (slow t1) (slow t2)
slow :: Integral a => a -> a
slow t = (t * 3) `div` 2
@@ -583,7 +585,7 @@ agentDRG AgentClient {agentEnv = Env {random}} = random
class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where
type Client msg = c | c -> msg
getProtocolServerClient :: AgentClient -> TransportSession msg -> AM (Client msg)
getProtocolServerClient :: AgentClient -> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
type ProtoClient msg = c | c -> msg
protocolClient :: Client msg -> ProtoClient msg
clientProtocolError :: HostName -> err -> AgentErrorType
@@ -613,7 +615,7 @@ instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
type Client FileResponse = XFTPClient
getProtocolServerClient = getXFTPServerClient
getProtocolServerClient c _ = getXFTPServerClient c
type ProtoClient FileResponse = XFTPClient
protocolClient = id
clientProtocolError = XFTP
@@ -621,19 +623,19 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
clientServer = X.xftpClientServer
clientTransportHost = X.xftpTransportHost
getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
getSMPServerClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> AM SMPConnectedClient
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} nm tSess = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess smpClients ts)
>>= either newClient (waitForProtocolClient c tSess smpClients)
>>= either newClient (waitForProtocolClient c nm tSess smpClients)
where
newClient v = do
prs <- liftIO TM.emptyIO
smpConnectClient c tSess prs v
smpConnectClient c nm tSess prs v
getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
getSMPProxyClient :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} nm proxySrv_ destSess@(userId, destSrv, qId) = do
unlessM (readTVarIO active) $ throwE INACTIVE
proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
ts <- liftIO getCurrentTime
@@ -651,11 +653,11 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
-- we do not need to check if it is a new proxied relay session,
-- as the client is just created and there are no sessions yet
rv <- atomically $ either id id <$> getSessVar workerSeq destSrv prs ts
clnt <- smpConnectClient c tSess prs v
clnt <- smpConnectClient c nm tSess prs v
(clnt,) <$> newProxiedRelay clnt auth rv
waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
waitForProxyClient tSess auth v = do
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess smpClients v
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c nm tSess smpClients v
ts <- liftIO getCurrentTime
sess <-
atomically (getSessVar workerSeq destSrv prs ts)
@@ -663,7 +665,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
pure (clnt, sess)
newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv =
tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case
tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp nm destSrv proxyAuth) >>= \case
Right sess -> do
atomically $ putTMVar (sessionVar rv) (Right sess)
pure $ Right sess
@@ -677,14 +679,14 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
waitForProxiedRelay (_, srv, _) rv = do
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
sess_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar rv)
sess_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar rv)
pure $ case sess_ of
Just (Right sess) -> Right sess
Just (Left e) -> Left e
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v =
smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, _) prs v =
newProtocolClient c tSess smpClients connectClient v
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
where
@@ -695,7 +697,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _)
env <- ask
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
ts <- readTVarIO proxySessTs
smp <- ExceptT $ getProtocolClient g tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
smp <- ExceptT $ getProtocolClient g nm tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
@@ -783,14 +785,14 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess ntfClients ts)
>>= either
(newProtocolClient c tSess ntfClients connectClient)
(waitForProtocolClient c tSess ntfClients)
(waitForProtocolClient c nm tSess ntfClients)
where
connectClient :: NtfClientVar -> AM NtfClient
connectClient v = do
@@ -798,7 +800,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS
g <- asks random
ts <- readTVarIO proxySessTs
liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
getProtocolClient g tSess cfg [] Nothing ts $
getProtocolClient g nm tSess cfg [] Nothing ts $
clientDisconnected v
clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -814,7 +816,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
atomically (getSessVar workerSeq tSess xftpClients ts)
>>= either
(newProtocolClient c tSess xftpClients connectClient)
(waitForProtocolClient c tSess xftpClients)
(waitForProtocolClient c NRMBackground tSess xftpClients)
where
connectClient :: XFTPClientVar -> AM XFTPClient
connectClient v = do
@@ -834,13 +836,14 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
waitForProtocolClient ::
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient ->
NetworkRequestMode ->
TransportSession msg ->
TMap (TransportSession msg) (ClientVar msg) ->
ClientVar msg ->
AM (Client msg)
waitForProtocolClient c tSess@(_, srv, _) clients v = do
waitForProtocolClient c nm tSess@(_, srv, _) clients v = do
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
client_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar v)
case client_ of
Just (Right smpClient) -> pure smpClient
Just (Left (e, ts_)) -> case ts_ of
@@ -848,7 +851,7 @@ waitForProtocolClient c tSess@(_, srv, _) clients v = do
Just ts ->
ifM
((ts <) <$> liftIO getCurrentTime)
(atomically (removeSessVar v tSess clients) >> getProtocolServerClient c tSess)
(atomically (removeSessVar v tSess clients) >> getProtocolServerClient c nm tSess)
(throwE e)
Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT
@@ -867,7 +870,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
Right client -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
atomically $ putTMVar (sessionVar v) (Right client)
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client)
liftIO $ nonBlockingWriteTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client)
pure client
Left e -> do
ei <- asks $ persistErrorInterval . config
@@ -979,7 +982,7 @@ closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -
closeClient_ c v = do
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $
tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v) >>= \case
Just (Right client) -> closeProtocolServerClient (protocolClient client) `catchAll_` pure ()
_ -> pure ()
@@ -1021,9 +1024,9 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
where
newLock = createLock >>= \l -> TM.insert key l locks $> l
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> AM a) -> AM a
withClient_ c tSess@(_, srv, _) action = do
cl <- getProtocolServerClient c tSess
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
withClient_ c nm tSess@(_, srv, _) action = do
cl <- getProtocolServerClient c nm tSess
action cl `catchAgentError` logServerError
where
logServerError :: AgentErrorType -> AM a
@@ -1031,9 +1034,9 @@ withClient_ c tSess@(_, srv, _) action = do
logServer "<--" c srv NoEntity $ bshow e
throwE e
withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
(cl, sess_) <- getSMPProxyClient c proxySrv_ destSess
withProxySession :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession c nm proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
(cl, sess_) <- getSMPProxyClient c nm proxySrv_ destSess
logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr
case sess_ of
Right sess -> do
@@ -1048,41 +1051,42 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e
throwE e
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
withLogClient_ c nm tSess@(_, srv, _) entId cmdStr action = do
logServer' "-->" c srv entId cmdStr
res <- withClient_ c tSess action
res <- withClient_ c nm tSess action
logServer' "<--" c srv entId "OK"
return res
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withClient c nm tSess action = withClient_ c nm tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
{-# INLINE withClient #-}
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withLogClient c nm tSess entId cmdStr action = withLogClient_ c nm tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
{-# INLINE withLogClient #-}
withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
withSMPClient c q cmdStr action = do
withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
withSMPClient c nm q cmdStr action = do
tSess <- mkSMPTransportSession c q
withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
withLogClient c nm tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
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 =
fst <$> sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags msg =
fst <$> sendOrProxySMPCommand c nm userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
where
sendViaProxy smp proxySess = do
atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts
proxySMPMessage smp proxySess spKey_ senderId msgFlags msg
proxySMPMessage smp nm proxySess spKey_ senderId msgFlags msg
sendDirectly smp = do
atomically $ incSMPServerStat c userId destSrv sentDirectAttempts
sendSMPMessage smp spKey_ senderId msgFlags msg
sendSMPMessage smp nm spKey_ senderId msgFlags msg
sendOrProxySMPCommand ::
forall a.
AgentClient ->
NetworkRequestMode ->
UserId ->
SMPServer ->
ConnId -> -- session entity ID, for short links LinkId is used
@@ -1091,7 +1095,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 nm 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
@@ -1113,7 +1117,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a)
sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
r <- tryAgentError . withProxySession c nm 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
@@ -1159,7 +1163,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
| serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
| otherwise -> throwE e
sendDirectly tSess =
withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
withLogClient_ c nm 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
@@ -1170,8 +1174,8 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts
where
isOnionHost = \case THOnionHost _ -> True; _ -> False
withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId
withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
withNtfClient c nm srv (EntityId entId) = withLogClient c nm (0, srv, Nothing) entId
withXFTPClient ::
ProtocolServerClient v err msg =>
@@ -1182,7 +1186,7 @@ withXFTPClient ::
AM b
withXFTPClient c (userId, srv, sessEntId) cmdStr action = do
tSess <- mkTransportSession c userId srv sessEntId
withLogClient c tSess sessEntId cmdStr action
withLogClient c NRMBackground tSess sessEntId cmdStr action
liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
liftClient protocolError_ = liftError . protocolClientError protocolError_
@@ -1222,8 +1226,8 @@ data ProtocolTestFailure = ProtocolTestFailure
}
deriving (Eq, Show)
runSMPServerTest :: AgentClient -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
cfg <- getClientConfig c smpCfg
C.AuthAlg ra <- asks $ rcvAuthAlg . config
C.AuthAlg sa <- asks $ sndAuthAlg . config
@@ -1231,20 +1235,19 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
liftIO $ do
let tSess = (userId, srv, Nothing)
ts <- readTVarIO $ proxySessTs c
getProtocolClient g tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case
getProtocolClient g nm tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case
Right smp -> do
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
(dhKey, _) <- atomically $ C.generateKeyPair g
r <- runExceptT $ do
-- TODO [notifications]
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing
liftError (testErr TSSecureQueue) $
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
Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId sKey
_ -> secureSMPQueue smp nm rpKey rcvId sKey
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId
ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
Left e -> pure (Just $ testErr TSConnect e)
where
@@ -1252,8 +1255,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
testErr step = ProtocolTestFailure step . protocolClientError SMP addr
runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
cfg <- asks $ xftpCfg . config
g <- asks random
xftpNetworkConfig <- getNetworkConfig c
@@ -1277,7 +1280,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
Left e -> pure (Just $ testErr TSConnect e)
where
@@ -1300,23 +1303,23 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
createTestChunk :: FilePath -> IO ()
createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
runNTFServerTest :: AgentClient -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runNTFServerTest c nm userId (ProtoServerWithAuth srv _) = do
cfg <- getClientConfig c ntfCfg
C.AuthAlg a <- asks $ rcvAuthAlg . config
g <- asks random
liftIO $ do
let tSess = (userId, srv, Nothing)
ts <- readTVarIO $ proxySessTs c
getProtocolClient g tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case
getProtocolClient g nm tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case
Right ntf -> do
(nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
(dhKey, _) <- atomically $ C.generateKeyPair g
r <- runExceptT $ do
let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
(tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey)
liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf
(tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey)
liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId
ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
Left e -> pure (Just $ testErr TSConnect e)
where
@@ -1349,12 +1352,11 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
getSessionMode = fmap sessionMode . getNetworkConfig
{-# INLINE getSessionMode #-}
-- 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
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue c nm userId connId srv vRange cMode enableNtfs 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 Nothing e2eKeys
newRcvQueue_ c nm userId connId srv vRange qrd enableNtfs subMode Nothing e2eKeys
data ClntQueueReqData
= CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
@@ -1371,21 +1373,21 @@ queueReqData = \case
CQRMessaging d -> QRMessaging $ srvReq <$> d
CQRContact d -> QRContact $ srvReq <$> d
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
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enableNtfs 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 [notifications]
r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId}) <-
withClient c tSess $ \(SMPConnectedClient smp _) ->
(thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd)
(thParams', ntfKeys, qik@QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId, serverNtfCreds}) <-
withClient c nm tSess $ \(SMPConnectedClient smp _) -> do
(ntfKeys, ntfCreds) <- liftIO $ mkNtfCreds a g smp
(thParams smp,ntfKeys,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds
-- TODO [certs rcv] validate that serviceId is the same as in the client session
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
shortLink <- mkShortLinkCreds r
shortLink <- mkShortLinkCreds thParams' qik
let rq =
RcvQueue
{ userId,
@@ -1406,14 +1408,26 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
dbReplaceQueueId = Nothing,
rcvSwchStatus = Nothing,
smpClientVersion = maxVersion vRange,
clientNtfCreds = Nothing,
clientNtfCreds = mkClientNtfCreds ntfKeys serverNtfCreds,
deleteErrors = 0
}
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey 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
mkNtfCreds :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> TVar ChaChaDRG -> SMPClient -> IO (Maybe (C.AAuthKeyPair, C.PrivateKeyX25519), Maybe NewNtfCreds)
mkNtfCreds a g smp
| enableNtfs && thVersion (thParams smp) >= newNtfCredsSMPVersion = do
authKeys@(k, _) <- atomically $ C.generateAuthKeyPair a g
(dhk, dhpk) <- atomically $ C.generateKeyPair g
pure (Just (authKeys, dhpk), Just $ NewNtfCreds k dhk)
| otherwise = pure (Nothing, Nothing)
mkClientNtfCreds :: Maybe (C.AAuthKeyPair, C.PrivateKeyX25519) -> Maybe ServerNtfCreds -> Maybe ClientNtfCreds
mkClientNtfCreds ntfKeys serverNtfCreds = case (ntfKeys, serverNtfCreds) of
(Just ((ntfPublicKey, ntfPrivateKey), dhpk), Just (ServerNtfCreds notifierId dhk')) ->
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret = C.dh' dhk' dhpk}
_ -> Nothing
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'
@@ -1493,7 +1507,7 @@ subscribeQueues c qs = do
env <- ask
-- only "checked" queues are subscribed
session <- newTVarIO Nothing
rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs'
rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c NRMBackground qs'
(errs <> rs,) <$> readTVarIO session
where
checkQueue rq = do
@@ -1503,7 +1517,7 @@ subscribeQueues c qs = do
subscribeQueues_ env session smp qs' = do
let (userId, srv, _) = transportSession' smp
atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
rs <- sendBatch subscribeSMPQueues smp qs'
rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs'
active <-
atomically $
ifM
@@ -1534,8 +1548,8 @@ type BatchResponses q e r = NonEmpty (q, Either e r)
-- Please note: this function does not preserve order of results to be the same as the order of arguments,
-- it includes arguments in the results instead.
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> [q] -> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches statCmd toRQ action c qs =
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)]
sendTSessionBatches statCmd toRQ action c nm qs =
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
where
batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
@@ -1548,7 +1562,7 @@ sendTSessionBatches statCmd toRQ action c qs =
in M.alter (Just . maybe [q] (q <|)) tSess m
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
sendClientBatch (tSess@(_, srv, _), qs') =
tryAgentError' (getSMPServerClient c tSess) >>= \case
tryAgentError' (getSMPServerClient c nm tSess) >>= \case
Left e -> pure $ L.map (,Left e) qs'
Right (SMPConnectedClient smp _) -> liftIO $ do
logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
@@ -1556,8 +1570,8 @@ sendTSessionBatches statCmd toRQ action c qs =
where
agentError = second . first $ protocolClientError SMP $ clientServer smp
sendBatch :: (SMPClient -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
sendBatch :: (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
sendBatch smpCmdFunc smp nm qs = L.zip qs <$> smpCmdFunc smp nm (L.map queueCreds qs)
where
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvId, rcvPrivateKey)
@@ -1626,18 +1640,18 @@ logSecret' :: ByteString -> ByteString
logSecret' = B64.encode . B.take 3
{-# INLINE logSecret' #-}
sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer)
sendConfirmation c sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
sendConfirmation :: AgentClient -> NetworkRequestMode -> SndQueue -> ByteString -> AM (Maybe SMPServer)
sendConfirmation c nm 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 "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendOrProxySMPMessage c nm userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
sendConfirmation _ _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
sendInvitation :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
sendInvitation c nm userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
msg <- mkInvitation
sendOrProxySMPMessage c userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
sendOrProxySMPMessage c nm userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
where
mkInvitation :: AM ByteString
-- this is only encrypted with per-queue E2E, not with double ratchet
@@ -1649,7 +1663,7 @@ sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpS
getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
atomically createTakeGetLock
msg_ <- withSMPClient c rq "GET" $ \smp ->
msg_ <- withSMPClient c NRMInteractive rq "GET" $ \smp ->
getSMPMessage smp rcvPrivateKey rcvId
mapM decryptMeta msg_
where
@@ -1668,44 +1682,44 @@ decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
where
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
secureQueue :: AgentClient -> RcvQueue -> SndPublicAuthKey -> AM ()
secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
withSMPClient c rq "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM ()
secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
withSMPClient c nm rq "KEY <key>" $ \smp ->
secureSMPQueue smp nm rcvPrivateKey rcvId senderKey
secureSndQueue :: AgentClient -> SndQueue -> AM ()
secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
void $ sendOrProxySMPCommand c userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
secureSndQueue :: AgentClient -> NetworkRequestMode -> SndQueue -> AM ()
secureSndQueue c nm SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
void $ sendOrProxySMPCommand c nm userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
where
-- TODO track statistics
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp nm proxySess sndPrivateKey sndId sndPublicKey
secureDirectly smp = secureSndSMPQueue smp nm 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
addQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
addQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
withSMPClient c nm rq "LSET" $ \smp -> addSMPQueueLink smp nm rcvPrivateKey rcvId lnkId d
deleteQueueLink :: AgentClient -> RcvQueue -> AM ()
deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId
deleteQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
deleteQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c nm rq "LDEL" $ \smp -> deleteSMPQueueLink smp nm 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 <key>" linkId secureGetViaProxy secureGetDirectly
secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
snd <$> sendOrProxySMPCommand c nm userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
where
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey
secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId sndPublicKey
secureGetDirectly smp = secureGetSMPQueueLink smp nm 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
getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
getQueueLink c nm userId server lnkId =
snd <$> sendOrProxySMPCommand c nm userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly
where
getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId
getDirectly smp = getSMPQueueLink smp lnkId
getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId
getDirectly smp = getSMPQueueLink smp nm 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 <nkey>" $ \smp ->
withSMPClient c NRMBackground rq "NKEY <nkey>" $ \smp ->
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
data EnableQueueNtfReq = EnableQueueNtfReq
@@ -1716,7 +1730,7 @@ data EnableQueueNtfReq = EnableQueueNtfReq
}
enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
enableQueuesNtfs c = sendTSessionBatches "NKEY" eqnrRq enableQueues_ c NRMBackground
where
enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
@@ -1729,13 +1743,13 @@ enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "NDEL" $ \smp ->
withSMPClient c NRMBackground rq "NDEL" $ \smp ->
disableSMPQueueNotifications smp rcvPrivateKey rcvId
type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
disableQueuesNtfs c = sendTSessionBatches "NDEL" snd disableQueues_ c NRMBackground
where
disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
@@ -1744,7 +1758,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp ->
ackSMPMessage smp rcvPrivateKey rcvId msgId
hasGetLock :: AgentClient -> RcvQueue -> IO Bool
@@ -1757,32 +1771,33 @@ releaseGetLock c RcvQueue {server, rcvId} =
TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
{-# INLINE releaseGetLock #-}
suspendQueue :: AgentClient -> RcvQueue -> AM ()
suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "OFF" $ \smp ->
suspendSMPQueue smp rcvPrivateKey rcvId
suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c nm rq "OFF" $ \smp ->
suspendSMPQueue smp nm rcvPrivateKey rcvId
deleteQueue :: AgentClient -> RcvQueue -> AM ()
deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
withSMPClient c rq "DEL" $ \smp ->
deleteSMPQueue smp rcvPrivateKey rcvId
deleteQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
deleteQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = do
withSMPClient c nm rq "DEL" $ \smp ->
deleteSMPQueue smp nm rcvPrivateKey rcvId
deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
deleteQueues :: AgentClient -> NetworkRequestMode -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
deleteQueues c nm = sendTSessionBatches "DEL" id deleteQueues_ c nm
where
deleteQueues_ smp rqs = do
let (userId, srv, _) = transportSession' smp
atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs
rs <- sendBatch deleteSMPQueues smp rqs
rs <- sendBatch deleteSMPQueues smp nm rqs
let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs
atomically $ incSMPServerStat' c userId srv connDeleted successes
pure rs
-- This is only used in background
sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do
let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
sendOrProxySMPMessage c userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
sendOrProxySMPMessage c NRMBackground userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
data ServerQueueInfo = ServerQueueInfo
{ server :: SMPServer,
@@ -1794,50 +1809,50 @@ data ServerQueueInfo = ServerQueueInfo
}
deriving (Show)
getQueueInfo :: AgentClient -> RcvQueue -> AM ServerQueueInfo
getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} =
withSMPClient c rq "QUE" $ \smp -> do
info <- getSMPQueueInfo smp rcvPrivateKey rcvId
getQueueInfo :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
getQueueInfo c nm rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} =
withSMPClient c nm rq "QUE" $ \smp -> do
info <- getSMPQueueInfo smp nm rcvPrivateKey rcvId
let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds
pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info}
where
enc = decodeLatin1 . B64.encode . unEntityId
agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> SMP.NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c nm NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c nm (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf nm ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
withNtfClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
agentNtfVerifyToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
agentNtfVerifyToken c nm tknId NtfToken {ntfServer, ntfPrivKey} code =
withNtfClient c nm ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf nm ntfPrivKey tknId code
agentNtfCheckToken :: AgentClient -> NtfTokenId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
withNtfClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM NtfTknStatus
agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} =
withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId
agentNtfReplaceToken :: AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token =
withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token
agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
agentNtfDeleteToken :: AgentClient -> NetworkRequestMode -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
agentNtfDeleteToken c nm ntfServer ntfPrivKey tknId =
withNtfClient c nm ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf nm ntfPrivKey tknId
-- set to 0 to disable
agentNtfSetCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
agentNtfSetCronInterval c tknId NtfToken {ntfServer, ntfPrivKey} interval =
withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf ntfPrivKey tknId interval
agentNtfSetCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> Word16 -> AM ()
agentNtfSetCronInterval c nm tknId NtfToken {ntfServer, ntfPrivKey} interval =
withNtfClient c nm ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf nm ntfPrivKey tknId interval
agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId
agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
withNtfClient c NRMBackground ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
agentNtfCreateSubscriptions :: AgentClient -> NtfToken -> NonEmpty (NewNtfEntity 'Subscription) -> AM' (NonEmpty (Either AgentErrorType NtfSubscriptionId))
agentNtfCreateSubscriptions = withNtfBatch "SNEW" ntfCreateSubscriptions
agentNtfCheckSubscription :: AgentClient -> NtfToken -> NtfSubscriptionId -> AM NtfSubStatus
agentNtfCheckSubscription c NtfToken {ntfServer, ntfPrivKey} subId =
withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
withNtfClient c NRMBackground ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
agentNtfCheckSubscriptions :: AgentClient -> NtfToken -> NonEmpty NtfSubscriptionId -> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
agentNtfCheckSubscriptions = withNtfBatch "SCHK" ntfCheckSubscriptions
@@ -1852,7 +1867,7 @@ withNtfBatch ::
AM' (NonEmpty (Either AgentErrorType r))
withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
let tSess = (0, ntfServer, Nothing)
tryAgentError' (getNtfServerClient c tSess) >>= \case
tryAgentError' (getNtfServerClient c NRMBackground tSess) >>= \case
Left e -> pure $ L.map (\_ -> Left e) subs
Right ntf -> liftIO $ do
logServer' "-->" c ntfServer (bshow (length subs) <> " subscriptions") cmdStr
@@ -1862,7 +1877,7 @@ withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM ()
agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
withNtfClient c NRMBackground ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
agentXFTPDownloadChunk :: AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> AM ()
agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = do
@@ -1876,7 +1891,7 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
logServer "-->" c srv NoEntity "FNEW"
tSess <- mkTransportSession c userId srv chunkDigest
(sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
(sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
@@ -2126,12 +2141,12 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions)
storeError :: StoreError -> AgentErrorType
storeError = \case
SEConnNotFound -> CONN NOT_FOUND
SEConnNotFound -> CONN NOT_FOUND ""
SEUserNotFound -> NO_USER
SERatchetNotFound -> CONN NOT_FOUND
SEConnDuplicate -> CONN DUPLICATE
SEBadConnType CRcv -> CONN SIMPLEX
SEBadConnType CSnd -> CONN SIMPLEX
SERatchetNotFound -> CONN NOT_FOUND ""
SEConnDuplicate -> CONN DUPLICATE ""
SEBadConnType cxt CRcv -> CONN SIMPLEX cxt
SEBadConnType cxt CSnd -> CONN SIMPLEX cxt
SEInvitationNotFound cxt invId -> CMD PROHIBITED $ "SEInvitationNotFound " <> cxt <> ", invitationId = " <> show invId
-- this error is never reported as store error,
-- it is used to wrap agent operations when "transaction-like" store access is needed
+16 -10
View File
@@ -14,6 +14,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
nsUpdateToken,
nsRemoveNtfToken,
sendNtfSubCommand,
hasInstantNotifications,
instantNotifications,
deleteToken,
closeNtfSupervisor,
@@ -45,12 +46,13 @@ import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.AgentStore
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Client (NetworkRequestMode (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, whenM)
import System.Random (randomR)
import UnliftIO
import UnliftIO.Concurrent (forkIO)
@@ -525,15 +527,19 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
nsRemoveNtfToken :: NtfSupervisor -> STM ()
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
sendNtfSubCommand ns cmd = do
tkn <- readTVar (ntfTkn ns)
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
sendNtfSubCommand ns cmd =
whenM (hasInstantNotifications ns) $ atomically $ writeTBQueue (ntfSubQ ns) cmd
instantNotifications :: Maybe NtfToken -> Bool
instantNotifications = \case
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
_ -> False
hasInstantNotifications :: NtfSupervisor -> IO Bool
hasInstantNotifications ns = do
tkn <- readTVarIO $ ntfTkn ns
pure $ maybe False instantNotifications tkn
instantNotifications :: NtfToken -> Bool
instantNotifications NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} = True
instantNotifications _ = False
{-# INLINE instantNotifications #-}
deleteToken :: AgentClient -> NtfToken -> AM ()
deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
@@ -572,7 +578,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
notifyInternalError' c (show e)
processTknToDelete :: NtfTokenToDelete -> AM ()
processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
agentNtfDeleteToken c srv ntfPrivKey tknId
agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
closeNtfSupervisor :: NtfSupervisor -> IO ()
+25 -1
View File
@@ -1153,22 +1153,39 @@ connReqUriP overrideScheme = do
instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
parseJSON = strParseJSON "ConnectionRequestUri"
{-# INLINE parseJSON #-}
instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance FromJSON AConnectionRequestUri where
parseJSON = strParseJSON "ConnectionRequestUri"
{-# INLINE parseJSON #-}
instance ToJSON AConnectionRequestUri where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance ConnectionModeI m => FromJSON (ConnShortLink m) where
parseJSON = strParseJSON "ConnShortLink"
{-# INLINE parseJSON #-}
instance ConnectionModeI m => ToJSON (ConnShortLink m) where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance FromJSON AConnShortLink where
parseJSON = strParseJSON "AConnShortLink"
{-# INLINE parseJSON #-}
instance ToJSON AConnShortLink where
toJSON = strToJSON
toEncoding = strToJEncoding
@@ -1432,6 +1449,13 @@ data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
instance Eq AConnShortLink where
ACSL m sl == ACSL m' sl' = case testEquality m m' of
Just Refl -> sl == sl'
Nothing -> False
deriving instance Show AConnShortLink
instance ToField AConnShortLink where toField = toField . Binary . strEncode
instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode
@@ -1813,7 +1837,7 @@ data AgentErrorType
= -- | command or response error
CMD {cmdErr :: CommandErrorType, errContext :: String}
| -- | connection errors
CONN {connErr :: ConnectionErrorType}
CONN {connErr :: ConnectionErrorType, errContext :: String}
| -- | user not found in database
NO_USER
| -- | SMP protocol errors forwarded to agent clients
+6 -2
View File
@@ -119,6 +119,10 @@ rcvQueueInfo :: RcvQueue -> RcvQueueInfo
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
canAbortRcvSwitch :: RcvQueue -> Bool
canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
where
@@ -511,7 +515,7 @@ data NewInvitation = NewInvitation
data Invitation = Invitation
{ invitationId :: InvitationId,
contactConnId :: ConnId,
contactConnId_ :: Maybe ConnId,
connReq :: ConnectionRequestUri 'CMInvitation,
recipientConnInfo :: ConnInfo,
ownConnInfo :: Maybe ConnInfo,
@@ -662,7 +666,7 @@ data StoreError
SESndQueueExists
| -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.
-- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.
SEBadConnType ConnType
SEBadConnType String ConnType
| -- | Confirmation not found.
SEConfirmationNotFound
| -- | Invitation not found
+21 -17
View File
@@ -387,7 +387,7 @@ updateNewConnRcv db connId rq =
getConn db connId $>>= \case
(SomeConn _ NewConnection {}) -> updateConn
(SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
(SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
where
updateConn :: IO (Either StoreError RcvQueue)
updateConn = Right <$> addConnRcvQueue_ db connId rq
@@ -396,7 +396,7 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr
updateNewConnSnd db connId sq =
getConn db connId $>>= \case
(SomeConn _ NewConnection {}) -> updateConn
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
(SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c
where
updateConn :: IO (Either StoreError SndQueue)
updateConn = Right <$> addConnSndQueue_ db connId sq
@@ -472,14 +472,14 @@ upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either S
upgradeRcvConnToDuplex db connId sq =
getConn db connId $>>= \case
(SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
(SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
upgradeSndConnToDuplex db connId rq =
getConn db connId >>= \case
Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
_ -> pure $ Left SEConnNotFound
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
@@ -487,7 +487,7 @@ addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreErr
addConnRcvQueue db connId rq =
getConn db connId >>= \case
Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
_ -> pure $ Left SEConnNotFound
addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
@@ -499,7 +499,7 @@ addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreErr
addConnSndQueue db connId sq =
getConn db connId >>= \case
Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c
_ -> pure $ Left SEConnNotFound
addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
@@ -728,7 +728,7 @@ createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInf
db
[sql|
INSERT INTO conn_invitations
(invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
(invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
|]
(Binary invitationId, contactConnId, connReq, Binary recipientConnInfo)
@@ -745,8 +745,8 @@ getInvitation db cxt invitationId =
|]
(Only (Binary invitationId))
where
invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}
invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted}
acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO ()
acceptInvitation db invitationId ownConnInfo =
@@ -764,12 +764,9 @@ unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
unacceptInvitation db invitationId =
DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId))
deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
deleteInvitation db contactConnId invId =
getConn db contactConnId $>>= \case
SomeConn SCContact _ ->
Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
_ -> pure $ Left SEConnNotFound
deleteInvitation :: DB.Connection -> InvitationId -> IO ()
deleteInvitation db invId =
DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId))
getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
getInvShortLink db server linkId =
@@ -1972,15 +1969,22 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
INSERT INTO rcv_queues
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
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 (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|]
( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
:. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
:. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
:. ntfCredsFields
)
-- TODO [certs rcv] save client service
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
where
ntfCredsFields = case clientNtfCreds of
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
Nothing -> (Nothing, Nothing, Nothing, Nothing)
-- * createSndConn helpers
@@ -11,21 +11,23 @@ module Simplex.Messaging.Agent.Store.Postgres.DB
execute,
execute_,
executeMany,
PSQL.query,
PSQL.query_,
query,
query_,
blobFieldDecoder,
fromTextField_,
)
where
import qualified Control.Exception as E
import Control.Monad (void)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Database.PostgreSQL.Simple (ResultError (..))
import Database.PostgreSQL.Simple (ResultError (..), SqlError (..))
import qualified Database.PostgreSQL.Simple as PSQL
import Database.PostgreSQL.Simple.FromField (Field (..), FieldParser, FromField (..), returnError)
import Database.PostgreSQL.Simple.ToField (ToField (..))
@@ -42,17 +44,49 @@ instance ToField BoolInt where
{-# INLINE toField #-}
execute :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> q -> IO ()
execute db q qs = void $ PSQL.execute db q qs
execute db q qs = withLoggedErrors q $ void $ PSQL.execute db q qs
{-# INLINE execute #-}
execute_ :: PSQL.Connection -> PSQL.Query -> IO ()
execute_ db q = void $ PSQL.execute_ db q
execute_ db q = withLoggedErrors q $ void $ PSQL.execute_ db q
{-# INLINE execute_ #-}
executeMany :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> [q] -> IO ()
executeMany db q qs = void $ PSQL.executeMany db q qs
executeMany db q qs = withLoggedErrors q $ void $ PSQL.executeMany db q qs
{-# INLINE executeMany #-}
query :: (PSQL.ToRow q, PSQL.FromRow r) => PSQL.Connection -> PSQL.Query -> q -> IO [r]
query db q qs = withLoggedErrors q $ PSQL.query db q qs
{-# INLINE query #-}
query_ :: PSQL.FromRow r => PSQL.Connection -> PSQL.Query -> IO [r]
query_ db q = withLoggedErrors q $ PSQL.query_ db q
{-# INLINE query_ #-}
withLoggedErrors :: Show q => q -> IO a -> IO a
withLoggedErrors q action =
action
`E.catch` (\(e :: SqlError) -> logSqlErrorAndRethrow e)
`E.catch`
(\(e :: E.SomeException) ->
case E.fromException e :: Maybe SqlError of
Just sqlErr -> E.throwIO sqlErr -- rethrow SqlError without logging
Nothing -> logGenericErrorAndRethrow e
)
where
logSqlErrorAndRethrow :: SqlError -> IO a
logSqlErrorAndRethrow e = do
putStrLn "Caught SqlError"
putStrLn $ "Message: " <> B.unpack (sqlErrorMsg e)
putStrLn $ "SQL State: " <> B.unpack (sqlState e)
putStrLn $ "Query: " <> show q
E.throwIO e
logGenericErrorAndRethrow :: E.SomeException -> IO a
logGenericErrorAndRethrow e = do
putStrLn $ "Caught generic exception: " <> show e
putStrLn $ "Query: " <> show q
E.throwIO e
-- orphan instances
-- used in FileSize
@@ -7,13 +7,15 @@ 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.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
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),
("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
]
-- | The list of migrations in ascending order by date
@@ -0,0 +1,37 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where
import Data.Text (Text)
import qualified Data.Text as T
import Text.RawString.QQ (r)
m20250702_conn_invitations_remove_cascade_delete :: Text
m20250702_conn_invitations_remove_cascade_delete =
T.pack
[r|
ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id DROP NOT NULL;
ALTER TABLE conn_invitations
ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
FOREIGN KEY (contact_conn_id)
REFERENCES connections(conn_id)
ON DELETE SET NULL;
|]
down_m20250702_conn_invitations_remove_cascade_delete :: Text
down_m20250702_conn_invitations_remove_cascade_delete =
T.pack
[r|
ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id SET NOT NULL;
ALTER TABLE conn_invitations
ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
FOREIGN KEY (contact_conn_id)
REFERENCES connections(conn_id)
ON DELETE CASCADE;
|]
@@ -43,6 +43,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last
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.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -85,7 +86,8 @@ schemaMigrations =
("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),
("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
]
-- | The list of migrations in ascending order by date
@@ -5,6 +5,7 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs w
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
-- TODO move date forward, create migration for postgres
m20250517_service_certs :: Query
m20250517_service_certs =
[sql|
@@ -0,0 +1,38 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20250702_conn_invitations_remove_cascade_delete :: Query
m20250702_conn_invitations_remove_cascade_delete =
[sql|
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(
sql,
'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE',
'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL'
)
WHERE name = 'conn_invitations' AND type = 'table';
PRAGMA writable_schema=0;
|]
down_m20250702_conn_invitations_remove_cascade_delete :: Query
down_m20250702_conn_invitations_remove_cascade_delete =
[sql|
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(
sql,
'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL',
'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE'
)
WHERE name = 'conn_invitations' AND type = 'table';
PRAGMA writable_schema=0;
|]
@@ -154,7 +154,7 @@ CREATE TABLE conn_confirmations(
) WITHOUT ROWID;
CREATE TABLE conn_invitations(
invitation_id BLOB NOT NULL PRIMARY KEY,
contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL,
cr_invitation BLOB NOT NULL,
recipient_conn_info BLOB NOT NULL,
accepted INTEGER NOT NULL DEFAULT 0,
+147 -101
View File
@@ -8,6 +8,7 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
@@ -81,12 +82,16 @@ module Simplex.Messaging.Client
unexpectedResponse,
ProtocolClientConfig (..),
NetworkConfig (..),
NetworkTimeout (..),
NetworkRequestMode (..),
pattern NRMInteractive,
TransportSessionMode (..),
HostMode (..),
SocksMode (..),
SMPProxyMode (..),
SMPProxyFallback (..),
SMPWebPortServers (..),
netTimeoutInt,
defaultClientConfig,
defaultSMPClientConfig,
defaultNetworkConfig,
@@ -154,7 +159,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -175,8 +180,8 @@ data PClient v err msg = PClient
{ connected :: TVar Bool,
transportSession :: TransportSession msg,
transportHost :: TransportHost,
tcpConnectTimeout :: Int,
tcpTimeout :: Int,
tcpConnectTimeout :: NetworkTimeout,
tcpTimeout :: NetworkTimeout,
sendPings :: TVar Bool,
lastReceived :: TVar UTCTime,
timeoutErrorCount :: TVar Int,
@@ -198,6 +203,7 @@ smpClientStub g sessionId thVersion thAuth = do
timeoutErrorCount <- newTVarIO 0
sndQ <- newTBQueueIO 100
rcvQ <- newTBQueueIO 100
let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig
return
ProtocolClient
{ action = Nothing,
@@ -219,8 +225,8 @@ smpClientStub g sessionId thVersion thAuth = do
{ connected,
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
transportHost = "localhost",
tcpConnectTimeout = 20_000_000,
tcpTimeout = 15_000_000,
tcpConnectTimeout,
tcpTimeout,
sendPings,
lastReceived,
timeoutErrorCount,
@@ -298,9 +304,9 @@ data NetworkConfig = NetworkConfig
-- | use web port 443 for SMP protocol
smpWebPortServers :: SMPWebPortServers,
-- | timeout for the initial client TCP/TLS connection (microseconds)
tcpConnectTimeout :: Int,
tcpConnectTimeout :: NetworkTimeout,
-- | timeout of protocol commands (microseconds)
tcpTimeout :: Int,
tcpTimeout :: NetworkTimeout,
-- | additional timeout per kilobyte (1024 bytes) to be sent
tcpTimeoutPerKb :: Int64,
-- | break response timeouts into groups, so later responses get later deadlines
@@ -315,6 +321,28 @@ data NetworkConfig = NetworkConfig
}
deriving (Eq, Show)
data NetworkTimeout = NetworkTimeout {backgroundTimeout :: Int, interactiveTimeout :: Int}
deriving (Eq, Show)
data NetworkRequestMode
= NRMBackground
| NRMInteractive' {retryCount :: Int}
pattern NRMInteractive :: NetworkRequestMode
pattern NRMInteractive = NRMInteractive' 0
netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout {backgroundTimeout, interactiveTimeout} = \case
NRMBackground -> backgroundTimeout
NRMInteractive' n
| n <= 0 -> interactiveTimeout
| otherwise ->
let (m, d)
| n == 1 = (3, 2)
| n == 2 = (9, 4)
| otherwise = (27, 8)
in (interactiveTimeout * m) `div` d
data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
deriving (Eq, Show)
@@ -387,8 +415,8 @@ defaultNetworkConfig =
smpProxyMode = SPMNever,
smpProxyFallback = SPFAllow,
smpWebPortServers = SWPPreset,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpTimeout = 15_000_000,
tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000},
tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000},
tcpTimeoutPerKb = 5_000,
rcvConcurrency = 8,
tcpKeepAlive = Just defaultKeepAliveOpts,
@@ -397,10 +425,11 @@ defaultNetworkConfig =
logTLSErrors = False
}
transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN =
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} nm host useSNI clientALPN =
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout = tOut, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
where
tOut = netTimeoutInt tcpConnectTimeout nm
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
useSocksProxy SMAlways = socksProxy'
useSocksProxy SMOnion = case host of
@@ -523,8 +552,8 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -562,12 +591,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
runClient (port', ATransport t) useHost c = do
cVar <- newEmptyTMVarIO
let tcConfig = (transportClientConfig networkConfig useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
let tcConfig = (transportClientConfig networkConfig nm useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
tId <-
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
`forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
c_ <- netTimeoutInt tcpConnectTimeout nm `timeout` atomically (takeTMVar cVar)
case c_ of
Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'}
Just (Left e) -> pure $ Left e
@@ -631,7 +660,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
if remaining > 1_000_000 -- delay pings only for significant time
then loop remaining
else do
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c NRMBackground Nothing NoEntity (protocolPing @v @err @msg)
-- sendProtocolCommand/getResponse updates counter for each command
cnt <- readTVarIO timeoutErrorCount
-- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
@@ -757,38 +786,41 @@ smpProxyError = \case
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
createSMPQueue ::
SMPClient ->
NetworkRequestMode ->
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 ->
QueueReqData ->
-- TODO [notifications]
-- Maybe NewNtfCreds ->
Maybe NewNtfCreds ->
ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd =
sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
IDS qik -> pure qik
r -> throwE $ unexpectedResponse r
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-- This command is always sent in background request mode
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
subscribeSMPQueue c rpKey rId = do
liftIO $ enablePings c
sendSMPCommand c (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
-- | Subscribe to multiple SMP queues batching commands if supported.
-- This command is always sent in background request mode
subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
subscribeSMPQueues c qs = do
liftIO $ enablePings c
sendProtocolCommands c cs >>= mapM (processSUBResponse c)
sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c)
where
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
-- This command is always sent in background request mode
streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c NRMBackground cs $ mapM process >=> cb
where
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
process r@(Response rId _) = (rId,) <$> processSUBResponse c r
@@ -813,9 +845,10 @@ serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionI
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-- This command is always sent in interactive request mode, as NSE has limited time
getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
getSMPMessage c rpKey rId =
sendSMPCommand c (Just rpKey) rId GET >>= \case
sendSMPCommand c NRMInteractive (Just rpKey) rId GET >>= \case
OK -> pure Nothing
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
r -> throwE $ unexpectedResponse r
@@ -824,16 +857,18 @@ getSMPMessage c rpKey rId =
-- | Subscribe to the SMP queue notifications.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-- This command is always sent in background request mode
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
subscribeSMPQueueNotifications c npKey nId = do
liftIO $ enablePings c
sendSMPCommand c (Just npKey) nId NSUB >>= except . nsubResponse_
sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
-- This command is always sent in background request mode
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
subscribeSMPQueuesNtfs c qs = do
liftIO $ enablePings c
L.map nsubResponse <$> sendProtocolCommands c cs
L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs
where
cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
@@ -848,11 +883,12 @@ nsubResponse_ = \case
r' -> Left $ unexpectedResponse r'
{-# INLINE nsubResponse_ #-}
-- This command is always sent in background request mode
subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
subscribeService c party = case smpClientService c of
Just THClientService {serviceId, serviceKey} -> do
liftIO $ enablePings c
sendSMPCommand c (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
sendSMPCommand c NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
SOKS n -> pure n
r -> throwE $ unexpectedResponse r
where
@@ -873,53 +909,54 @@ enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeT
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKey rId
{-# INLINE secureSMPQueue #-}
-- | Secure the SMP queue via sender queue ID.
secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId
{-# INLINE secureSndSMPQueue #-}
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm 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
addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
addSMPQueueLink c nm rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c nm rpKey rId
{-# INLINE addSMPQueueLink #-}
-- | Delete queue link
deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> 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
secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
secureGetSMPQueueLink c nm spKey lnkId senderKey =
sendSMPCommand c nm (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
proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey =
proxySMPCommand c nm 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
getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
getSMPQueueLink c nm lnkId =
sendSMPCommand c nm 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
-- LGET command - get short link data
proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
proxyGetSMPQueueLink c nm proxiedRelay lnkId =
proxySMPCommand c nm proxiedRelay Nothing lnkId LGET >>= \case
Right (LNK sId d) -> pure $ Right (sId, d)
Right r -> throwE $ unexpectedResponse r
Left e -> pure $ Left e
@@ -929,13 +966,14 @@ proxyGetSMPQueueLink c proxiedRelay lnkId =
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
sendSMPCommand c NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
r -> throwE $ unexpectedResponse r
-- | Enable notifications for the multiple queues for push notifications server.
-- This command is always sent in background request mode
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackground cs
where
cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
process (Response _ r) = case r of
@@ -946,33 +984,36 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
-- | Disable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-- This command is always sent in background request mode
disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
disableSMPQueueNotifications = okSMPCommand NDEL
disableSMPQueueNotifications c = okSMPCommand NDEL c NRMBackground
{-# INLINE disableSMPQueueNotifications #-}
-- | Disable notifications for multiple queues for push notifications server.
-- This command is always sent in background request mode
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
disableSMPQueuesNtfs = okSMPCommands NDEL
disableSMPQueuesNtfs c = okSMPCommands NDEL c NRMBackground
{-# INLINE disableSMPQueuesNtfs #-}
-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage c spKey sId flags msg =
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage c nm spKey sId flags msg =
sendSMPCommand c nm spKey sId (SEND flags msg) >>= \case
OK -> pure ()
r -> throwE $ unexpectedResponse r
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c proxiedRelay spKey sId flags msg = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg)
proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg)
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-- This command is always sent in background request mode
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
ackSMPMessage c rpKey rId msgId =
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE $ unexpectedResponse r
@@ -981,28 +1022,28 @@ ackSMPMessage c rpKey rId msgId =
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue = okSMPCommand OFF
{-# INLINE suspendSMPQueue #-}
-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
deleteSMPQueue = okSMPCommand DEL
{-# INLINE deleteSMPQueue #-}
-- | Delete multiple SMP queues batching commands if supported.
deleteSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
deleteSMPQueues = okSMPCommands DEL
{-# INLINE deleteSMPQueues #-}
-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
| thVersion (thParams c) >= sendingProxySMPVersion =
sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
PKEY sId vr (CertChainPubKey chain key) ->
case supportedClientSMPRelayVRange `compatibleVersion` vr of
Nothing -> throwE $ transportErr TEVersion
@@ -1010,7 +1051,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
r -> throwE $ unexpectedResponse r
| otherwise = throwE $ PCETransportError TEVersion
where
tOut = Just $ tcpConnectTimeout + tcpTimeout
tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm
transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
validateRelay (X.CertificateChain cert) exact = do
@@ -1076,9 +1117,9 @@ 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
proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxyOKSMPCommand c nm proxiedRelay spKey sId command =
proxySMPCommand c nm proxiedRelay spKey sId command >>= \case
Right OK -> pure $ Right ()
Right r -> throwE $ unexpectedResponse r
Left e -> pure $ Left e
@@ -1087,6 +1128,7 @@ proxySMPCommand ::
forall p.
PartyI p =>
SMPClient ->
NetworkRequestMode ->
-- proxy session from PKEY
ProxiedRelay ->
-- message to deliver
@@ -1094,7 +1136,7 @@ proxySMPCommand ::
SenderId ->
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
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
-- prepare params
let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
@@ -1112,8 +1154,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
TBTransmissions s _ _ : _ -> pure s
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
-- proxy interaction errors are wrapped
let tOut = Just $ 2 * tcpTimeout
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
Right r -> case r of
PRES (EncResponse er) -> do
-- server interaction errors are thrown directly
@@ -1137,6 +1179,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
-- sends RFWD :: EncFwdTransmission -> Command Sender
-- receives RRES :: EncFwdResponse -> BrokerMsg
-- proxy should send PRES to the client with EncResponse
-- Always uses background timeout mode
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
-- prepare params
@@ -1148,7 +1191,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
-- send
sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
RRES (EncFwdResponse efr) -> do
-- unwrap
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -1156,20 +1199,21 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
pure fwdResponse
r -> throwE $ unexpectedResponse r
getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo c pKey qId =
sendSMPCommand c (Just pKey) qId QUE >>= \case
-- get queue information - always sent interactively
getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo c nm pKey qId =
sendSMPCommand c nm (Just pKey) qId QUE >>= \case
INFO info -> pure info
r -> throwE $ unexpectedResponse r
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c nm pKey qId =
sendSMPCommand c nm (Just pKey) qId cmd >>= \case
OK -> return ()
r -> throwE $ unexpectedResponse r
okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs
where
aCmd = Cmd sParty cmd
cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
@@ -1179,17 +1223,17 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
Left e -> Left e
-- | Send SMP command
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (Cmd sParty cmd)
{-# INLINE sendSMPCommand #-}
type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
-- | Send multiple commands with batching and collect responses
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
sendProtocolCommands c@ProtocolClient {thParams} cs = do
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
validate . concat =<< mapM (sendBatch c) bs
validate . concat =<< mapM (sendBatch c nm) bs
where
validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
validate rs
@@ -1203,13 +1247,13 @@ sendProtocolCommands c@ProtocolClient {thParams} cs = do
where
diff = L.length cs - length rs
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands c@ProtocolClient {thParams} cs cb = do
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands c@ProtocolClient {thParams} nm cs cb = do
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
mapM_ (cb <=< sendBatch c) bs
mapM_ (cb <=< sendBatch c nm) bs
sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
case b of
TBError e Request {entityId} -> do
putStrLn "send error: large message"
@@ -1217,15 +1261,15 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
TBTransmissions s n rs
| n > 0 -> do
nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
mapConcurrently (getResponse c Nothing) rs
mapConcurrently (getResponse c nm Nothing) rs
| otherwise -> pure []
TBTransmission s r -> do
nonBlockingWriteTBQueue sndQ (Nothing, s)
(: []) <$> getResponse c Nothing r
(: []) <$> getResponse c nm Nothing r
-- | Send Protocol command
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing
-- Currently there is coupling - batch commands do not expire, and individually sent commands do.
-- 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.
@@ -1233,8 +1277,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
-- 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, serviceAuth}} nonce_ tOut pKey entId cmd =
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> 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, serviceAuth}} nm nonce_ tOut pKey entId cmd =
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd)
where
-- two separate "atomically" needed to avoid blocking
@@ -1245,7 +1289,7 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
| otherwise -> do
nonBlockingWriteTBQueue sndQ (Just r, s)
response <$> getResponse c tOut r
response <$> getResponse c nm tOut r
where
s
| batch = tEncodeBatch1 serviceAuth t
@@ -1256,9 +1300,9 @@ nonBlockingWriteTBQueue q x = do
sent <- atomically $ tryWriteTBQueue q x
unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg)
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do
r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar)
getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg)
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do
r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar)
response <- atomically $ do
writeTVar pending False
-- Try to read response again in case it arrived after timeout expired
@@ -1345,6 +1389,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)
$(J.deriveJSON defaultJSON ''NetworkTimeout)
$(J.deriveJSON defaultJSON ''NetworkConfig)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)
+3 -3
View File
@@ -203,7 +203,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
waitForSMPClient v = do
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
case smpClient_ of
Just (Right smpClient) -> pure smpClient
Just (Left (e, ts_)) -> case ts_ of
@@ -249,7 +249,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
-- | Run an SMP client for SMPClientVar
connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
where
clientDisconnected :: SMPClient -> IO ()
clientDisconnected smp = do
@@ -313,7 +313,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
subs <- getPending TM.lookupIO readTVarIO
unless (noPending subs) $ whenM (readTVarIO active) $ do
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv subs)
void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
loop
ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs
+9
View File
@@ -55,6 +55,7 @@ module Simplex.Messaging.Crypto.Ratchet
supportedE2EEncryptVRange,
generateRcvE2EParams,
generateSndE2EParams,
mkRcvE2ERatchetParams,
initialPQEncryption,
connPQEncryption,
joinContactInitialKeys,
@@ -196,6 +197,8 @@ data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RK
deriving instance Show ARKEMParams
type RcvRKEMParams = RKEMParams 'RKSProposed
instance RatchetKEMStateI s => Encoding (RKEMParams s) where
smpEncode = \case
RKParamsProposed k -> smpEncode ('P', k)
@@ -406,6 +409,12 @@ data UseKEM (s :: RatchetKEMState) where
data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem)
where
mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k
generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
generateE2EParams g v useKEM_ = do
(k1, pk1) <- atomically $ generateKeyPair g
+23 -23
View File
@@ -28,39 +28,39 @@ defaultNTFClientConfig =
{defaultTransport = ("443", transport @TLS)}
{-# INLINE defaultNTFClientConfig #-}
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c pKey newTkn =
sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
ntfRegisterToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c nm pKey newTkn =
sendNtfCommand c nm (Just pKey) NoEntity (TNEW newTkn) >>= \case
NRTknId tknId dhKey -> pure (tknId, dhKey)
r -> throwE $ unexpectedResponse r
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId
ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
ntfCheckToken c pKey tknId =
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
ntfCheckToken c nm pKey tknId =
sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case
NRTkn stat -> pure stat
r -> throwE $ unexpectedResponse r
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
ntfDeleteToken = okNtfCommand TDEL
-- set to 0 to disable
ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm pKey tknId
ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
ntfCreateSubscription c pKey newSub =
sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
sendNtfCommand c NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case
NRSubId subId -> pure subId
r -> throwE $ unexpectedResponse r
ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs
where
cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs
process (Response _ r) = case r of
@@ -70,12 +70,12 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
ntfCheckSubscription c pKey subId =
sendNtfCommand c (Just pKey) subId SCHK >>= \case
sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case
NRSub stat -> pure stat
r -> throwE $ unexpectedResponse r
ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c NRMBackground cs
where
cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds
process (Response _ r) = case r of
@@ -84,14 +84,14 @@ ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c c
Left e -> Left e
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
ntfDeleteSubscription = okNtfCommand SDEL
ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground
-- | Send notification server command
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
sendNtfCommand :: NtfEntityI e => NtfClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
sendNtfCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (NtfCmd sNtfEntity cmd)
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
okNtfCommand cmd c pKey entId =
sendNtfCommand c (Just pKey) entId cmd >>= \case
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
okNtfCommand cmd c nm pKey entId =
sendNtfCommand c nm (Just pKey) entId cmd >>= \case
NROk -> return ()
r -> throwE $ unexpectedResponse r
+13 -16
View File
@@ -364,12 +364,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
CPSkip -> False
_ -> True
processCP h role = \case
CPAuth auth -> atomically $ writeTVar role $! newRole cfg
CPAuth auth -> controlPortAuth h user admin role auth
where
newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
| Just auth == admin = CPRAdmin
| Just auth == user = CPRUser
| otherwise = CPRNone
NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
CPStats -> withUserRole $ do
ss <- unliftIO u $ asks serverStats
let getStat :: (NtfServerStats -> IORef a) -> IO a
@@ -480,8 +477,8 @@ subscribeSrvSubs ca st batchSize (srv, srvId, service_) = do
-- this function is concurrency-safe - only onle subscriber per server can be created at a time,
-- other threads would wait for the first thread to create it.
subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> ServerNtfSub -> IO ()
subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer ntfSub =
subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> Int64 -> ServerNtfSub -> IO ()
subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer srvId ntfSub =
getSubscriberVar
>>= either createSMPSubscriber waitForSMPSubscriber
>>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSub)
@@ -493,8 +490,8 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
createSMPSubscriber v =
E.handle (\(e :: SomeException) -> logError ("SMP subscriber exception: " <> tshow e) >> removeSubscriber v) $ do
q <- newTQueueIO
tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber q)
let sub = SMPSubscriber {smpServer, subscriberSubQ = q, subThreadId = tId}
tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber smpServer srvId q)
let sub = SMPSubscriber {smpServer, smpServerId = srvId, subscriberSubQ = q, subThreadId = tId}
atomically $ putTMVar (sessionVar v) sub -- this makes it available for other threads
pure $ Just sub
@@ -510,13 +507,13 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
atomically $ removeSessVar v smpServer smpSubscribers
pure Nothing
runSMPSubscriber :: TQueue ServerNtfSub -> IO ()
runSMPSubscriber q = forever $ do
runSMPSubscriber :: SMPServer -> Int64 -> TQueue ServerNtfSub -> IO ()
runSMPSubscriber smpServer' srvId' q = forever $ do
-- TODO [ntfdb] possibly, the subscriptions can be batched here and sent every say 5 seconds
-- this should be analysed once we have prometheus stats
(nId, sub) <- atomically $ readTQueue q
void $ updateSubStatus st nId NSPending
subscribeQueuesNtfs ca smpServer [sub]
void $ updateSubStatus st srvId' nId NSPending
subscribeQueuesNtfs ca smpServer' [sub]
ntfSubscriber :: NtfSubscriber -> M ()
ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
@@ -866,12 +863,12 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
let sub = mkNtfSubRec subId newSub
resp <-
withNtfStore (`addNtfSubscription` sub) $ \case
True -> do
(srvId, True) -> do
st <- asks store
liftIO $ subscribeNtfs ns st srv (subId, (nId, nKey))
liftIO $ subscribeNtfs ns st srv srvId (subId, (nId, nKey))
incNtfStat subCreated
pure $ NRSubId subId
False -> pure $ NRErr AUTH
(_, False) -> pure $ NRErr AUTH
pure (corrId, NoEntity, resp)
NtfReqCmd SSubscription (NtfSub NtfSubRec {ntfSubId, smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
(corrId,subId,) <$> case cmd of
@@ -141,6 +141,7 @@ newNtfSubscriber smpAgentCfg random = do
data SMPSubscriber = SMPSubscriber
{ smpServer :: SMPServer,
smpServerId :: Int64,
subscriberSubQ :: TQueue ServerNtfSub,
subThreadId :: Weak ThreadId
}
@@ -56,6 +56,7 @@ import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
import Simplex.Messaging.Agent.Store.Postgres.Common
import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer)
@@ -75,7 +76,6 @@ import System.IO (IOMode (..), hFlush, stdout, withFile)
import Text.Hex (decodeHex)
#if !defined(dbPostgres)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (eitherToMaybe)
#endif
@@ -401,13 +401,13 @@ updateTokenCronSentAt st tknId now =
withDB' "updateTokenCronSentAt" st $ \db ->
void $ DB.execute db "UPDATE tokens t SET cron_sent_at = ? WHERE token_id = ?" (now, tknId)
addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool)
addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType (Int64, Bool))
addNtfSubscription st sub =
withFastDB "addNtfSubscription" st $ \db -> runExceptT $ do
srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub
n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub
withLog "addNtfSubscription" st (`logCreateSubscription` sub)
pure $ n > 0
pure (srvId, n > 0)
where
-- It is possible to combine these two statements into one with CTEs,
-- to reduce roundtrips in case of `insert`, but it would be making 2 queries in all cases.
@@ -454,8 +454,8 @@ deleteNtfSubscription st subId =
DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId)
withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId)
updateSubStatus :: NtfPostgresStore -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
updateSubStatus st nId status =
updateSubStatus :: NtfPostgresStore -> Int64 -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
updateSubStatus st srvId nId status =
withFastDB' "updateSubStatus" st $ \db -> do
sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
maybeFirstRow id $
@@ -463,10 +463,10 @@ updateSubStatus st nId status =
db
[sql|
UPDATE subscriptions SET status = ?
WHERE smp_notifier_id = ? AND status != ?
WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ?
RETURNING subscription_id, ntf_service_assoc
|]
(status, nId, status)
(status, srvId, nId, status)
forM_ sub_ $ \(subId, serviceAssoc) ->
withLog "updateSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
+39 -35
View File
@@ -64,6 +64,8 @@ module Simplex.Messaging.Protocol
EncFixedDataBytes,
EncUserDataBytes,
EncDataBytes (..),
NewNtfCreds (..),
ServerNtfCreds (..),
Party (..),
Cmd (..),
QueueParty,
@@ -114,6 +116,7 @@ module Simplex.Messaging.Protocol
BasicAuth (..),
SrvLoc (..),
CorrId (..),
pattern NoCorrId,
EntityId (..),
pattern NoEntity,
QueueId,
@@ -582,9 +585,8 @@ data NewQueueReq = NewQueueReq
rcvDhKey :: RcvPublicDhKey,
auth_ :: Maybe BasicAuth,
subMode :: SubscriptionMode,
queueReqData :: Maybe QueueReqData
-- TODO [notifications]
-- ntfCreds :: Maybe NewNtfCreds
queueReqData :: Maybe QueueReqData,
ntfCreds :: Maybe NewNtfCreds
}
deriving (Show)
@@ -628,8 +630,7 @@ instance ToField EncDataBytes where
toField (EncDataBytes s) = toField (Binary s)
{-# INLINE toField #-}
-- TODO [notifications]
-- data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
instance StrEncoding SubscriptionMode where
strEncode = \case
@@ -660,10 +661,9 @@ instance Encoding QueueReqData where
'C' -> QRContact <$> smpP
_ -> fail "bad QueueReqData"
-- TODO [notifications]
-- instance Encoding NewNtfCreds where
-- smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
-- smpP = NewNtfCreds <$> smpP <*> smpP
instance Encoding NewNtfCreds where
smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
smpP = NewNtfCreds <$> smpP <*> smpP
newtype EncTransmission = EncTransmission ByteString
deriving (Show)
@@ -1370,6 +1370,9 @@ newtype CorrId = CorrId {bs :: ByteString}
deriving (Eq, Ord, Show)
deriving newtype (Encoding)
pattern NoCorrId :: CorrId
pattern NoCorrId = CorrId ""
instance IsString CorrId where
fromString = CorrId . fromString
{-# INLINE fromString #-}
@@ -1393,19 +1396,17 @@ data QueueIdsKeys = QIK
rcvPublicDhKey :: RcvPublicDhKey,
queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
linkId :: Maybe LinkId,
serviceId :: Maybe ServiceId
-- TODO [notifications]
-- serverNtfCreds :: Maybe ServerNtfCreds
serviceId :: Maybe ServiceId,
serverNtfCreds :: Maybe ServerNtfCreds
}
deriving (Eq, Show)
-- TODO [notifications]
-- data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
-- 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
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.
--
@@ -1650,7 +1651,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}
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
| v >= newNtfCredsSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
| v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData)
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
| otherwise -> new <> auth <> e subMode
@@ -1735,19 +1737,20 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
CT SCreator NEW_ -> Cmd SCreator <$> newCmd
where
newCmd
| v >= shortLinksSMPVersion = new smpP smpP
| v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP)
| otherwise = new auth (pure Nothing)
| v >= newNtfCredsSMPVersion = new smpP smpP smpP
| v >= shortLinksSMPVersion = new smpP smpP nothing
| v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP) nothing
| otherwise = new auth nothing nothing
where
new p1 p2 = NEW <$> do
nothing = pure Nothing
new p1 p2 p3 = NEW <$> do
rcvAuthKey <- _smpP
rcvDhKey <- smpP
auth_ <- p1
subMode <- smpP
queueReqData <- p2
-- TODO [notifications]
-- ntfCreds <- p3
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData} -- ntfCreds
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
CT SRecipient tag ->
@@ -1792,7 +1795,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, serviceId}
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
| v >= newNtfCredsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId <> e serverNtfCreds
| v >= serviceCertsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId
| v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId
| v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
@@ -1833,23 +1837,23 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
where
bodyP = EncRcvMsgBody . unTail <$> smpP
IDS_
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP
| v >= shortLinksSMPVersion -> ids smpP smpP nothing
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
| otherwise -> ids nothing nothing nothing
| v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
| v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing nothing
| otherwise -> ids nothing nothing nothing nothing
where
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
nothing = pure Nothing
ids p1 p2 p3 = do
ids p1 p2 p3 p4 = do
rcvId <- _smpP
sndId <- smpP
rcvPublicDhKey <- smpP
queueMode <- p1
linkId <- p2
serviceId <- p3
-- TODO [notifications]
-- serverNtfCreds <- p3
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId}
serverNtfCreds <- p4
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
LNK_ -> LNK <$> _smpP <*> smpP
SOK_ -> SOK <$> _smpP
SOKS_ -> SOKS <$> _smpP
+212 -195
View File
@@ -31,6 +31,7 @@
module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
controlPortAuth,
importMessages,
exportMessages,
printMessageStats,
@@ -61,17 +62,18 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Constraint (Dict (..))
import Data.Dynamic (toDyn)
import Data.Either (fromRight, partitionEithers)
import Data.Foldable (foldrM)
import Data.Functor (($>))
import Data.IORef
import Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.List (foldl', intercalate, mapAccumR)
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Semigroup (Sum (..))
import qualified Data.Set as S
import Data.Text (Text)
@@ -271,6 +273,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
as'' <- if prevServiceId == serviceId_ then pure [] else endServiceSub prevServiceId qId END
case serviceId_ of
Just serviceId -> do
modifyTVar' totalServiceSubs (+ 1) -- server count for all services
as <- endQueueSub qId END
as' <- cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers
pure $ as ++ as' ++ as''
@@ -282,8 +285,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
as <- endQueueSub qId DELD
as' <- endServiceSub serviceId qId DELD
pure $ as ++ as'
CSService serviceId -> do
CSService serviceId count -> do
modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients
modifyTVar' totalServiceSubs (+ count) -- server count for all services
cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers
updateSubDisconnected = case clntSub of
-- do not insert client if it is already disconnected, but send END/DELD to any other client subscribed to this queue or service
@@ -296,7 +300,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
as <- endQueueSub qId DELD
as' <- endServiceSub serviceId qId DELD
pure $ as ++ as'
CSService serviceId -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers
CSService serviceId _ -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers
endQueueSub :: QueueId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub qId msg = prevSub qId msg (CSAEndSub qId) =<< lookupDeleteSubscribedClient qId queueSubscribers
endServiceSub :: Maybe ServiceId -> QueueId -> BrokerMsg -> STM [PrevClientSub s]
@@ -382,7 +386,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept"
unlessM (currentClient readTVar c) $ cancelNtfs "not current client"
whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full"
writeTBQueue sndQ ts
writeTBQueue sndQ (ts, [])
pure $ length ts_
currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool
currentClient rd Client {clientId, connected} = (&&) <$> rd connected <*> (IS.member clientId <$> rd subClients)
@@ -393,7 +397,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
ntfs -> do
writeTVar v []
pure $ foldl' (\acc' ntf -> nmsg nId ntf : acc') acc ntfs -- reverses, to order by time
nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (CorrId "", nId, NMSG ntfNonce ntfEncMeta)
nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (NoCorrId, nId, NMSG ntfNonce ntfEncMeta)
updateNtfStats :: Client s' -> Either SomeException Int -> IO ()
updateNtfStats Client {clientId} = \case
Right 0 -> pure ()
@@ -419,14 +423,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
where
enqueueEvts evts c@Client {connected, sndQ} =
whenM (readTVarIO connected) $ do
sent <- atomically $ tryWriteTBQueue sndQ ts
sent <- atomically $ tryWriteTBQueue sndQ (ts, [])
if sent
then updateEndStats
else -- if queue is full it can block
forkClient c ("sendPendingEvtsThread.queueEvts") $
atomically (writeTBQueue sndQ ts) >> updateEndStats
forkClient c "sendPendingEvtsThread.queueEvts" $
atomically (writeTBQueue sndQ (ts, [])) >> updateEndStats
where
ts = L.map (\(entId, evt) -> (CorrId "", entId, evt)) evts
ts = L.map (\(entId, evt) -> (NoCorrId, entId, evt)) evts
-- this accounts for both END and DELD events
updateEndStats = do
let len = L.length evts
@@ -555,6 +559,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0
msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0
msgNtfExpired' <- atomicSwapIORef (msgNtfExpired ss) 0
_qBlocked <- atomicSwapIORef (qBlocked ss) 0 -- not logged, only reset
pRelays' <- getResetProxyStatsData pRelays
pRelaysOwn' <- getResetProxyStatsData pRelaysOwn
pMsgFwds' <- getResetProxyStatsData pMsgFwds
@@ -703,7 +708,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times')
else acc
countSubs acc@(!cnt, times) Sub {delivered} = do
delivered_ <- atomically $ tryReadTMVar delivered
delivered_ <- readTVarIO delivered
pure $ case delivered_ of
Nothing -> acc
Just (_, ts) -> (cnt + 1, updateTimeBuckets ts ts' times)
@@ -767,12 +772,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
CPSkip -> False
_ -> True
processCP h role = \case
CPAuth auth -> atomically $ writeTVar role $! newRole cfg
CPAuth auth -> controlPortAuth h user admin role auth
where
newRole ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
| Just auth == admin = CPRAdmin
| Just auth == user = CPRUser
| otherwise = CPRNone
ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
CPSuspend -> withAdminRole $ hPutStrLn h "suspend not implemented"
CPResume -> withAdminRole $ hPutStrLn h "resume not implemented"
CPClients -> withAdminRole $ do
@@ -961,7 +963,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
SubPending -> (c1, c2 + 1, c3, c4)
SubThread _ -> (c1, c2, c3 + 1, c4)
ProhibitSub -> pure (c1, c2, c3, c4 + 1)
CPDelete sId -> withUserRole $ unliftIO u $ do
CPDelete sId -> withAdminRole $ unliftIO u $ do
st <- asks msgStore
r <- liftIO $ runExceptT $ do
q <- ExceptT $ getQueue st SSender sId
@@ -980,14 +982,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
"status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", queueMode: " <> show queueMode
CPBlock sId info -> withUserRole $ unliftIO u $ do
st <- asks msgStore
r <- liftIO $ runExceptT $ do
q <- ExceptT $ getQueue st SSender sId
ExceptT $ blockQueue (queueStore st) q info
case r of
Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
Right () -> do
incStat . qBlocked =<< asks serverStats
liftIO $ hPutStrLn h "ok"
stats <- asks serverStats
blocked <- liftIO $ readIORef $ qBlocked stats
let quota = dailyBlockQueueQuota cfg
if blocked >= quota && quota /= 0
then liftIO $ hPutStrLn h $ "error: reached limit of " <> show quota <> " queues blocked daily"
else do
r <- liftIO $ runExceptT $ do
q <- ExceptT $ getQueue st SSender sId
ExceptT $ blockQueue (queueStore st) q info
case r of
Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
Right () -> do
incStat $ qBlocked stats
liftIO $ hPutStrLn h "ok"
CPUnblock sId -> withUserRole $ unliftIO u $ do
st <- asks msgStore
r <- liftIO $ runExceptT $ do
@@ -1042,6 +1050,20 @@ runClientTransport h@THandle {params = thParams@THandleParams {sessionId}} = do
where
hasSubs ServerSubscribers {subClients} = IS.member clientId <$> readTVarIO subClients
controlPortAuth :: Handle -> Maybe BasicAuth -> Maybe BasicAuth -> TVar CPClientRole -> BasicAuth -> IO ()
controlPortAuth h user admin role auth = do
readTVarIO role >>= \case
CPRNone -> do
atomically $ writeTVar role $! newRole
hPutStrLn h $ currentRole newRole
r -> hPutStrLn h $ currentRole r <> if r == newRole then "" else ", start new session to change."
where
currentRole r = "Current role is " <> show r
newRole
| Just auth == admin = CPRAdmin
| Just auth == user = CPRUser
| otherwise = CPRNone
clientDisconnected :: forall s. Client s -> M s ()
clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, serviceSubsCount, ntfServiceSubsCount, connected, clientTHParams = THandleParams {sessionId, thAuth}, endThreads} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
@@ -1095,7 +1117,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
let (es, ts') = partitionEithers $ L.toList ts
errs = map (second ERR) es
case ts' of
errs' <- case ts' of
(_, _, (_, _, Cmd p cmd)) : rest -> do
let service = peerClientService =<< thAuth
(errs', cmds) <- partitionEithers <$> case batchParty p of
@@ -1105,9 +1127,10 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
qs <- getQueueRecs ms p $ map queueId ts'
zipWithM (\t -> verified stats t . verifyLoadedQueue service thAuth t) ts' qs
_ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts'
write rcvQ cmds
write sndQ $ errs ++ errs'
[] -> write sndQ errs
mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds
pure $ errs ++ errs'
[] -> pure errs
mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs'
where
sameParty :: SParty p -> SignedTransmission Cmd -> Bool
sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p'
@@ -1129,32 +1152,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
NSUB -> incStat $ ntfSubAuth stats
GET -> incStat $ msgGetAuth stats
_ -> pure ()
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
forever $ atomically (readTBQueue sndQ) >>= sendTransmissions
where
sendTransmissions :: NonEmpty (Transmission BrokerMsg) -> IO ()
sendTransmissions ts
| L.length ts <= 2 = tSend th c ts
-- If the request had batched subscriptions
-- this will reply SOKs to all SUBs in the first batched transmission,
-- to reduce client timeouts.
-- After that all messages will be sent in separate transmissions,
-- without any client response timeouts, and allowing them to interleave
-- with other requests responses.
sendTransmissions :: (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
sendTransmissions (ts, []) = tSend th c ts
sendTransmissions (ts, msg : msgs)
| length ts <= 4 = do -- up to 4 SOKs can be in one block with MSG (see testBatchSubResponses test)
tSend th c $ ts <> [msg]
mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs
| otherwise = do
let (msgs_, ts') = mapAccumR splitMessages [] ts
-- If the request had batched subscriptions and L.length ts > 2
-- this will reply OK to all SUBs in the first batched transmission,
-- to reduce client timeouts.
tSend th c ts'
-- After that all messages will be sent in separate transmissions,
-- without any client response timeouts, and allowing them to interleave
-- with other requests responses.
mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs_
where
splitMessages :: [Transmission BrokerMsg] -> Transmission BrokerMsg -> ([Transmission BrokerMsg], Transmission BrokerMsg)
splitMessages msgs t@(corrId, entId, cmd) = case cmd of
-- replace MSG response with OK, accumulating MSG in a separate list.
MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
_ -> (msgs, t)
tSend th c ts
atomically $ writeTBQueue msgQ (msg :| msgs)
sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
sendMsg th c@Client {msgQ, clientTHParams = THandleParams {sessionId}} = do
@@ -1200,7 +1218,7 @@ verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case
Left e -> VRFailed e
verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s
verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(Cmd p cmd))) q_
verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_
| not checkRole = VRFailed $ CMD PROHIBITED
| not verifyServiceSig = VRFailed SERVICE
| otherwise = vc p cmd
@@ -1226,8 +1244,8 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(
verify = verifyCmdAuthorization thAuth tAuth authorized' corrId
verifyServiceCmd :: VerificationResult s
verifyServiceCmd = case (service, tAuth) of
(Just THClientService {serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing))
| C.verify' k s authorized -> VRVerified Nothing
(Just THClientService {serviceId, serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing))
| entId == serviceId && C.verify' k s authorized -> VRVerified Nothing
_ -> VRFailed SERVICE
-- this function verify service signature for commands that use it in service sessions
verifyServiceSig
@@ -1321,19 +1339,20 @@ client
-- TODO [certs rcv] rcv subscriptions
Server {subscribers, ntfSubscribers}
ms
clnt@Client {clientId, subscriptions, ntfSubscriptions, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
clnt@Client {clientId, ntfSubscriptions, ntfServiceSubscribed, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
let THandleParams {thVersion} = thParams'
service = peerClientService =<< thAuth thParams'
clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
process t acc@(rs, msgs) =
(maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_)))
<$> processCommand clntServiceId thVersion t
forever $
atomically (readTBQueue rcvQ)
>>= mapM (processCommand service thVersion)
>>= mapM_ reply . L.nonEmpty . catMaybes . L.toList
>>= foldrM process ([], [])
>>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_)
where
reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m ()
reply = atomically . writeTBQueue sndQ
processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe (Transmission BrokerMsg))
processProxiedCmd (corrId, EntityId sessId, command) = (corrId,EntityId sessId,) <$$> case command of
processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe ResponseAndMessage)
processProxiedCmd (corrId, EntityId sessId, command) = (\t -> ((corrId, EntityId sessId, t), Nothing)) <$$> case command of
PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH)
where
allowProxy = do
@@ -1396,7 +1415,7 @@ client
forkProxiedCmd cmdAction = do
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> reply [(corrId, EntityId sessId, t)]
cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, EntityId sessId, t)], [])
pure Nothing
where
wait = do
@@ -1412,32 +1431,32 @@ client
mkIncProxyStats ps psOwn own sel = do
incStat $ sel ps
when own $ incStat $ sel psOwn
processCommand :: Maybe THPeerClientService -> VersionSMP -> VerifiedTransmission s -> M s (Maybe (Transmission BrokerMsg))
processCommand service clntVersion (q_, (corrId, entId, cmd)) = case cmd of
processCommand :: Maybe ServiceId -> VersionSMP -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage)
processCommand clntServiceId clntVersion (q_, (corrId, entId, cmd)) = case cmd of
Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
Cmd SSender command -> Just <$> case command of
Cmd SSender command -> case command of
SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k
SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody
Cmd SIdleClient PING -> pure $ Just (corrId, NoEntity, PONG)
Cmd SProxyService (RFWD encBlock) -> Just . (corrId,NoEntity,) <$> processForwardedCommand encBlock
Cmd SSenderLink command -> Just <$> case command of
SEND flags msgBody -> response <$> withQueue_ False err (sendMessage flags msgBody)
Cmd SIdleClient PING -> pure $ response (corrId, NoEntity, PONG)
Cmd SProxyService (RFWD encBlock) -> response . (corrId,NoEntity,) <$> processForwardedCommand encBlock
Cmd SSenderLink command -> case command of
LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
Cmd SNotifier NSUB -> Just . (corrId,entId,) <$> case q_ of
Cmd SNotifier NSUB -> response . (corrId,entId,) <$> case q_ of
Just (q, QueueRec {notifier = Just ntfCreds}) -> subscribeNotifications q ntfCreds
_ -> pure $ ERR INTERNAL
Cmd SNotifierService NSUBS -> Just . (corrId,entId,) <$> case service of
Just s -> subscribeServiceNotifications s
Cmd SNotifierService NSUBS -> response . (corrId,entId,) <$> case clntServiceId of
Just serviceId -> subscribeServiceNotifications serviceId
Nothing -> pure $ ERR INTERNAL
Cmd SCreator (NEW nqr@NewQueueReq {auth_}) ->
Just <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
response <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
where
allowNew = do
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth
Cmd SRecipient command ->
Just <$> case command of
SUB -> withQueue subscribeQueue
case command of
SUB -> withQueue' subscribeQueueAndDeliver
GET -> withQueue getMessage
ACK msgId -> withQueue $ acknowledgeMsg msgId
KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey
@@ -1453,25 +1472,24 @@ client
Nothing -> pure ok
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_
OFF -> response <$> maybe (pure $ err INTERNAL) suspendQueue_ q_
DEL -> response <$> maybe (pure $ err INTERNAL) delQueueAndMsgs q_
QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr
Cmd SRecipientService SUBS -> pure $ Just $ err (CMD PROHIBITED) -- "TODO [certs rcv]"
Cmd SRecipientService SUBS -> pure $ response $ err (CMD PROHIBITED) -- "TODO [certs rcv]"
where
createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData}
| isJust service && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED)
| otherwise = time "NEW" $ do
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds}
| isJust clntServiceId && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED)
| otherwise = do
g <- asks random
idSize <- asks $ queueIdBytes . config
updatedAt <- Just <$> liftIO getSystemDate
(rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g
-- TODO [notifications]
-- ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
-- (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
-- pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
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
-- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
sndId' = B.take 24 $ C.sha3_384 (bs corrId)
tryCreate 0 = pure $ ERR INTERNAL
tryCreate n = do
@@ -1486,12 +1504,11 @@ client
then pure $ ERR $ CMD PROHIBITED
else do
rcvId <- randId
-- TODO [notifications]
-- ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
-- notifierId <- randId
-- pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey)
ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
notifierId <- randId
let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId = Nothing}
pure (ntfCreds, ServerNtfCreds notifierId rcvPubDhKey)
let queueMode = queueReqMode <$> queueReqData
rcvServiceId = (\THClientService {serviceId} -> serviceId) <$> service
qr =
QueueRec
{ senderId = sndId,
@@ -1500,11 +1517,10 @@ client
senderKey = Nothing,
queueMode,
queueData,
-- TODO [notifications]
notifier = Nothing, -- fst <$> ntf,
notifier = fst <$> ntf,
status = EntityActive,
updatedAt,
rcvServiceId
rcvServiceId = clntServiceId
}
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?
@@ -1515,12 +1531,11 @@ client
stats <- asks serverStats
incStat $ qCreated stats
incStat $ qCount stats
-- TODO [notifications]
-- when (isJust ntf) $ incStat $ ntfCreated stats
when (isJust ntf) $ incStat $ ntfNewCreated stats
case subMode of
SMOnlyCreate -> pure ()
SMSubscribe -> void $ subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = rcvServiceId} -- , serverNtfCreds = snd <$> ntf
SMSubscribe -> subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = clntServiceId, serverNtfCreds = snd <$> ntf}
(corrId,entId,) <$> tryCreate (3 :: Int)
-- this check allows to support contact queues created prior to SKEY,
@@ -1544,7 +1559,7 @@ client
getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId
addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M s (Transmission BrokerMsg)
addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do
addQueueNotifier_ q notifierKey dhKey = do
(rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
let rcvNtfDhSecret = C.dh' dhKey privDhKey
(corrId,entId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
@@ -1581,47 +1596,60 @@ client
suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue (queueStore ms) q
-- TODO [certs rcv] if serviceId is passed, associate with the service and respond with SOK
subscribeQueue :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
subscribeQueue q qr =
liftIO (TM.lookupIO rId subscriptions) >>= \case
Nothing -> subscribeNewQueue rId qr >>= deliver True
subscribeQueueAndDeliver :: StoreQueue s -> QueueRec -> M s ResponseAndMessage
subscribeQueueAndDeliver q qr =
liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case
Nothing -> subscribeRcvQueue qr >>= deliver False
Just s@Sub {subThread} -> do
stats <- asks serverStats
case subThread of
ProhibitSub -> do
-- cannot use SUB in the same connection where GET was used
incStat $ qSubProhibited stats
pure (corrId, rId, ERR $ CMD PROHIBITED)
pure (err (CMD PROHIBITED), Nothing)
_ -> do
incStat $ qSubDuplicate stats
atomically (tryTakeTMVar $ delivered s) >> deliver False s
atomically (writeTVar (delivered s) Nothing) >> deliver True s
where
rId = recipientId q
deliver :: Bool -> Sub -> M s (Transmission BrokerMsg)
deliver inc sub = do
deliver :: Bool -> Sub -> M s ResponseAndMessage
deliver hasSub sub = do
stats <- asks serverStats
fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do
fmap (either ((,Nothing) . err) id) $ liftIO $ runExceptT $ do
msg_ <- tryPeekMsg ms q
liftIO $ when (inc && isJust msg_) $ incStat (qSub stats)
liftIO $ deliverMessage "SUB" qr rId sub msg_
msg' <- forM msg_ $ \msg -> liftIO $ do
ts <- getSystemSeconds
atomically $ setDelivered sub msg ts
unless hasSub $ incStat $ qSub stats
pure (NoCorrId, entId, MSG (encryptMsg qr msg))
pure ((corrId, entId, SOK clntServiceId), msg')
subscribeNewQueue :: RecipientId -> QueueRec -> M s Sub
subscribeNewQueue rId QueueRec {rcvServiceId} = time "SUB newSub" . atomically $ do
writeTQueue (subQ subscribers) (CSClient rId rcvServiceId Nothing, clientId)
-- TODO [certs rcv] combine with subscribing ntf queues
subscribeRcvQueue :: QueueRec -> M s Sub
subscribeRcvQueue QueueRec {rcvServiceId} = atomically $ do
writeTQueue (subQ subscribers) (CSClient entId rcvServiceId Nothing, clientId)
sub <- newSubscription NoSub
TM.insert rId sub subscriptions
TM.insert entId sub $ subscriptions clnt
pure sub
subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
subscribeNewQueue rId QueueRec {rcvServiceId} = do
case rcvServiceId of
Just _ -> atomically $ modifyTVar' (serviceSubsCount clnt) (+ 1)
Nothing -> do
sub <- atomically $ newSubscription NoSub
atomically $ TM.insert rId sub $ subscriptions clnt
atomically $ writeTQueue (subQ subscribers) (CSClient rId rcvServiceId rcvServiceId, clientId)
-- clients that use GET are not added to server subscribers
getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
getMessage q qr = time "GET" $ do
atomically (TM.lookup entId subscriptions) >>= \case
getMessage q qr = do
atomically (TM.lookup entId $ subscriptions clnt) >>= \case
Nothing ->
atomically newSub >>= (`getMessage_` Nothing)
Just s@Sub {subThread} ->
case subThread of
ProhibitSub ->
atomically (tryTakeTMVar $ delivered s)
atomically (swapTVar (delivered s) Nothing)
>>= getMessage_ s
-- cannot use GET in the same connection where there is an active subscription
_ -> do
@@ -1632,7 +1660,7 @@ client
newSub :: STM Sub
newSub = do
s <- newProhibitedSub
TM.insert entId s subscriptions
TM.insert entId s $ subscriptions clnt
-- Here we don't account for this client as subscribed in the server
-- and don't notify other subscribed clients.
-- This is tracked as "subscription" in the client to prevent these
@@ -1650,27 +1678,32 @@ client
atomically $ setDelivered s msg ts $> (corrId, entId, MSG encMsg)
Nothing -> incStat (msgGetNoMsg stats) $> ok
withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg)
withQueue = withQueue_ True
withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Maybe ResponseAndMessage)
withQueue = fmap response . withQueue_ True err
{-# INLINE withQueue #-}
withQueue' :: (StoreQueue s -> QueueRec -> M s ResponseAndMessage) -> M s (Maybe ResponseAndMessage)
withQueue' = fmap Just . withQueue_ True ((,Nothing) . err)
{-# INLINE withQueue' #-}
-- SEND passes queueNotBlocked False here to update time, but it fails anyway on blocked queues (see code for SEND).
withQueue_ :: Bool -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg)
withQueue_ queueNotBlocked action = case q_ of
Nothing -> pure $ err INTERNAL
withQueue_ :: Bool -> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
withQueue_ queueNotBlocked err' action = case q_ of
Nothing -> pure $ err' INTERNAL
Just (q, qr@QueueRec {status, updatedAt}) -> case status of
EntityBlocked info | queueNotBlocked -> pure $ err $ BLOCKED info
EntityBlocked info | queueNotBlocked -> pure $ err' $ BLOCKED info
_ -> do
t <- liftIO getSystemDate
if updatedAt == Just t
then action q qr
else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err) (action q)
else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err') (action q)
subscribeNotifications :: StoreQueue s -> NtfCreds -> M s BrokerMsg
subscribeNotifications q NtfCreds {ntfServiceId} = do
stats <- asks serverStats
let incNtfSrvStat sel = incStat $ sel $ ntfServices stats
case service of
Just THClientService {serviceId}
case clntServiceId of
Just serviceId
| ntfServiceId == Just serviceId -> do
-- duplicate queue-service association - can only happen in case of response error/timeout
hasSub <- atomically $ ifM hasServiceSub (pure True) (False <$ newServiceQueueSub)
@@ -1719,24 +1752,25 @@ client
incStat $ if hasSub then ntfSubDuplicate stats else ntfSub stats
pure $ SOK Nothing
subscribeServiceNotifications :: THPeerClientService -> M s BrokerMsg
subscribeServiceNotifications THClientService {serviceId} = do
srvSubs <- readTVarIO ntfServiceSubsCount
if srvSubs == 0
then
liftIO (getNtfServiceQueueCount @(StoreQueue s) (queueStore ms) serviceId) >>= \case
subscribeServiceNotifications :: ServiceId -> M s BrokerMsg
subscribeServiceNotifications serviceId = do
subscribed <- readTVarIO ntfServiceSubscribed
if subscribed
then SOKS <$> readTVarIO ntfServiceSubsCount
else
liftIO (getServiceQueueCount @(StoreQueue s) (queueStore ms) SNotifierService serviceId) >>= \case
Left e -> pure $ ERR e
Right count -> do
atomically $ do
modifyTVar' ntfServiceSubsCount (+ count) -- service count
modifyTVar' (totalServiceSubs ntfSubscribers) (+ count) -- server count for all services
atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId, clientId)
pure $ SOKS count
else pure $ SOKS srvSubs
Right !count' -> do
incCount <- atomically $ do
writeTVar ntfServiceSubscribed True
count <- swapTVar ntfServiceSubsCount count'
pure $ count' - count
atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId incCount, clientId)
pure $ SOKS count'
acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
acknowledgeMsg msgId q qr = time "ACK" $ do
liftIO (TM.lookupIO entId subscriptions) >>= \case
acknowledgeMsg msgId q qr =
liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case
Nothing -> pure $ err NO_MSG
Just sub ->
atomically (getDelivered sub) >>= \case
@@ -1750,16 +1784,20 @@ client
pure ok
_ -> do
(deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId
liftIO $ mapM_ (updateStats stats False ts) deletedMsg_
liftIO $ deliverMessage "ACK" qr entId sub msg_
liftIO $ do
mapM_ (updateStats stats False ts) deletedMsg_
forM_ msg_ $ \msg -> do
ts' <- getSystemSeconds
atomically $ setDelivered sub msg ts'
pure (corrId, entId, maybe OK (MSG . encryptMsg qr) msg_)
_ -> pure $ err NO_MSG
where
getDelivered :: Sub -> STM (Maybe (ServerSub, RoundedSystemTime))
getDelivered Sub {delivered, subThread} = do
tryTakeTMVar delivered $>>= \v@(msgId', ts) ->
readTVar delivered $>>= \(msgId', ts) ->
if msgId == msgId' || B.null msgId
then pure $ Just (subThread, ts)
else putTMVar delivered v $> Nothing
then writeTVar delivered Nothing $> Just (subThread, ts)
else pure Nothing
updateStats :: ServerStats -> Bool -> RoundedSystemTime -> Message -> IO ()
updateStats stats isGet deliveryTime = \case
MessageQuota {} -> pure ()
@@ -1804,7 +1842,7 @@ client
deleteQueueLinkData (queueStore ms) q
ServerConfig {messageExpiration, msgIdBytes} <- asks config
msgId <- randomId' msgIdBytes
msg_ <- liftIO $ time "SEND" $ runExceptT $ do
msg_ <- liftIO $ runExceptT $ do
expireMessages messageExpiration stats
msg <- liftIO $ mkMessage msgId body
writeMsg ms q True msg
@@ -1813,7 +1851,7 @@ client
Right Nothing -> do
incStat $ msgSentQuota stats
pure $ err QUOTA
Right (Just (msg, wasEmpty)) -> time "SEND ok" $ do
Right (Just (msg, wasEmpty)) -> do
when wasEmpty $ liftIO $ tryDeliverMessage msg
when (notification msgFlags) $ do
mapM_ (`enqueueNotification` msg) (notifier qr)
@@ -1854,17 +1892,17 @@ client
deliverToSub rcv = do
ts <- getSystemSeconds
atomically $
-- reading client TVar in the same transaction,
-- so that if subscription ends, it re-evalutates
-- and delivery is cancelled -
-- the new client will receive message in response to SUB.
-- reading client TVar in the same transaction,
-- so that if subscription ends, it re-evalutates
-- and delivery is cancelled -
-- the new client will receive message in response to SUB.
readTVar rcv
$>>= \rc@Client {subscriptions = subs, sndQ = sndQ'} -> TM.lookup rId subs
$>>= \s@Sub {subThread, delivered} -> case subThread of
ProhibitSub -> pure Nothing
ServerSub st -> readTVar st >>= \case
NoSub ->
tryTakeTMVar delivered >>= \case
readTVar delivered >>= \case
Just _ -> pure Nothing -- if a message was already delivered, should not deliver more
Nothing ->
ifM
@@ -1874,8 +1912,8 @@ client
_ -> pure Nothing
deliver sndQ' s ts = do
let encMsg = encryptMsg qr msg
writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)]
void $ setDelivered s msg ts
writeTBQueue sndQ' ([(NoCorrId, rId, MSG encMsg)], [])
setDelivered s msg ts
forkDeliver (rc@Client {sndQ = sndQ'}, s@Sub {delivered}, st) = do
t <- mkWeakThreadId =<< forkIO deliverThread
atomically $ modifyTVar' st $ \case
@@ -1888,10 +1926,10 @@ client
-- lookup can be outside of STM transaction,
-- as long as the check that it is the same client is inside.
getSubscribedClient rId (queueSubscribers subscribers) >>= mapM_ deliverIfSame
deliverIfSame rcv = time "deliver" $ do
deliverIfSame rcv = do
ts <- getSystemSeconds
atomically $ whenM (sameClient rc rcv) $
tryTakeTMVar delivered >>= \case
readTVar delivered >>= \case
Just _ -> pure () -- if a message was already delivered, should not deliver more
Nothing -> do
-- a separate thread is needed because it blocks when client sndQ is full.
@@ -1935,7 +1973,8 @@ client
Left r -> pure r
-- rejectOrVerify filters allowed commands, no need to repeat it here.
-- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types).
Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand Nothing fwdVersion t'')
-- `fst` removes empty message that is only returned for `SUB` command
Right t''@(_, (corrId', entId', _)) -> maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing fwdVersion t'')
-- encode response
r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of
[] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
@@ -1968,22 +2007,6 @@ client
VRVerified q -> Right (q, t'')
VRFailed e -> Left (corrId', entId', ERR e)
deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg)
deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") $
case subThread of
ProhibitSub -> pure resp
_ -> case msg_ of
Just msg -> do
ts <- getSystemSeconds
let encMsg = encryptMsg qr msg
atomically (setDelivered s msg ts) $> (corrId, rId, MSG encMsg)
_ -> pure resp
where
resp = (corrId, rId, OK)
time :: MonadIO m => T.Text -> m a -> m a
time name = timed name entId
encryptMsg :: QueueRec -> Message -> RcvMessage
encryptMsg qr msg = encrypt . encodeRcvMsgBody $ case msg of
Message {msgFlags, msgBody} -> RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
@@ -1994,21 +2017,21 @@ client
msgId' = messageId msg
msgTs' = messageTs msg
setDelivered :: Sub -> Message -> RoundedSystemTime -> STM Bool
setDelivered :: Sub -> Message -> RoundedSystemTime -> STM ()
setDelivered Sub {delivered} msg !ts = do
let !msgId = messageId msg
tryPutTMVar delivered (msgId, ts)
writeTVar delivered $ Just (msgId, ts)
delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
delQueueAndMsgs (q, QueueRec {rcvServiceId}) = do
liftIO (deleteQueue ms q) >>= \case
Right qr -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ do
writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId)
-- queue is usually deleted by the same client that is currently subscribed,
-- we delete subscription here, so the client with no subscriptions can be disconnected.
TM.delete entId subscriptions
-- queue is usually deleted by the same client that is currently subscribed,
-- we delete subscription here, so the client with no subscriptions can be disconnected.
sub <- atomically $ TM.lookupDelete entId $ subscriptions clnt
liftIO $ mapM_ cancelSub sub
atomically $ writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId)
forM_ (notifier qr) $ \NtfCreds {notifierId = nId, ntfServiceId} -> do
-- queue is deleted by a different client from the one subscribed to notifications,
-- so we don't need to remove subscription from the current client.
@@ -2023,7 +2046,7 @@ client
getQueueInfo :: StoreQueue s -> QueueRec -> M s BrokerMsg
getQueueInfo q QueueRec {senderKey, notifier} = do
fmap (either ERR INFO) $ liftIO $ runExceptT $ do
qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub
qiSub <- liftIO $ TM.lookupIO entId (subscriptions clnt) >>= mapM mkQSub
qiSize <- getQueueSize ms q
qiMsg <- toMsgInfo <$$> tryPeekMsg ms q
let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
@@ -2038,14 +2061,20 @@ client
SubPending -> QSubPending
SubThread _ -> QSubThread
ProhibitSub -> pure QProhibitSub
qDelivered <- atomically $ decodeLatin1 . encode . fst <$$> tryReadTMVar delivered
qDelivered <- decodeLatin1 . encode . fst <$$> readTVarIO delivered
pure QSub {qSubThread, qDelivered}
ok :: Transmission BrokerMsg
ok = (corrId, entId, OK)
{-# INLINE ok #-}
err :: ErrorType -> Transmission BrokerMsg
err e = (corrId, entId, ERR e)
{-# INLINE err #-}
response :: Transmission BrokerMsg -> Maybe ResponseAndMessage
response = Just . (,Nothing)
{-# INLINE response #-}
updateDeletedStats :: QueueRec -> M s ()
updateDeletedStats q = do
@@ -2059,18 +2088,6 @@ incStat :: MonadIO m => IORef Int -> m ()
incStat r = liftIO $ atomicModifyIORef'_ r (+ 1)
{-# INLINE incStat #-}
timed :: MonadIO m => T.Text -> RecipientId -> m a -> m a
timed name (EntityId qId) a = do
t <- liftIO getSystemTime
r <- a
t' <- liftIO getSystemTime
let int = diff t t'
when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int]
pure r
where
diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
sec = 1000_000000
randomId' :: Int -> M s ByteString
randomId' n = atomically . C.randomBytes n =<< asks random
+1 -1
View File
@@ -8,7 +8,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
data CPClientRole = CPRNone | CPRUser | CPRAdmin
deriving (Eq)
deriving (Eq, Show)
data ControlProtocol
= CPAuth BasicAuth
+15 -5
View File
@@ -40,6 +40,7 @@ module Simplex.Messaging.Server.Env.STM
MsgStore (..),
AStoreType (..),
VerifiedTransmission,
ResponseAndMessage,
newEnv,
mkJournalStoreConfig,
msgStore,
@@ -148,6 +149,7 @@ data ServerConfig s = ServerConfig
-- | control port passwords,
controlPortUserAuth :: Maybe BasicAuth,
controlPortAdminAuth :: Maybe BasicAuth,
dailyBlockQueueQuota :: Int,
-- | time after which the messages can be removed from the queues and check interval, seconds
messageExpiration :: Maybe ExpirationConfig,
expireMessagesOnStart :: Bool,
@@ -377,7 +379,7 @@ sameClient c cv = maybe False (sameClientId c) <$> readTVar cv
data ClientSub
= CSClient QueueId (Maybe ServiceId) (Maybe ServiceId) -- includes previous and new associated service IDs
| CSDeleted QueueId (Maybe ServiceId) -- includes previously associated service IDs
| CSService ServiceId -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB
| CSService ServiceId Int64 -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB
newtype ProxyAgent = ProxyAgent
{ smpAgent :: SMPClientAgent 'Sender
@@ -389,10 +391,12 @@ data Client s = Client
{ clientId :: ClientId,
subscriptions :: TMap RecipientId Sub,
ntfSubscriptions :: TMap NotifierId (),
serviceSubscribed :: TVar Bool, -- set independently of serviceSubsCount, to track whether service subscription command was received
ntfServiceSubscribed :: TVar Bool,
serviceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count
ntfServiceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count
rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]),
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
procThreads :: TVar Int,
endThreads :: TVar (IntMap (Weak ThreadId)),
@@ -406,13 +410,15 @@ data Client s = Client
type VerifiedTransmission s = (Maybe (StoreQueue s, QueueRec), Transmission Cmd)
type ResponseAndMessage = (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
data ServerSub = ServerSub (TVar SubscriptionThread) | ProhibitSub
data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId)
data Sub = Sub
{ subThread :: ServerSub, -- Nothing value indicates that sub
delivered :: TMVar (MsgId, RoundedSystemTime)
delivered :: TVar (Maybe (MsgId, RoundedSystemTime))
}
newServer :: IO (Server s)
@@ -458,6 +464,8 @@ newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemT
newClient clientId qSize clientTHParams createdAt = do
subscriptions <- TM.emptyIO
ntfSubscriptions <- TM.emptyIO
serviceSubscribed <- newTVarIO False
ntfServiceSubscribed <- newTVarIO False
serviceSubsCount <- newTVarIO 0
ntfServiceSubsCount <- newTVarIO 0
rcvQ <- newTBQueueIO qSize
@@ -474,6 +482,8 @@ newClient clientId qSize clientTHParams createdAt = do
{ clientId,
subscriptions,
ntfSubscriptions,
serviceSubscribed,
ntfServiceSubscribed,
serviceSubsCount,
ntfServiceSubsCount,
rcvQ,
@@ -491,13 +501,13 @@ newClient clientId qSize clientTHParams createdAt = do
newSubscription :: SubscriptionThread -> STM Sub
newSubscription st = do
delivered <- newEmptyTMVar
delivered <- newTVar Nothing
subThread <- ServerSub <$> newTVar st
return Sub {subThread, delivered}
newProhibitedSub :: STM Sub
newProhibitedSub = do
delivered <- newEmptyTMVar
delivered <- newTVar Nothing
return Sub {subThread = ProhibitSub, delivered}
newEnv :: ServerConfig s -> IO (Env s)
+1
View File
@@ -420,6 +420,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini,
controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini,
dailyBlockQueueQuota = readIniDefault 20 "AUTH" "daily_block_queue_quota" ini,
messageExpiration =
Just
defaultMessageExpiration
+5 -2
View File
@@ -107,8 +107,11 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
)
<> "\n\n"
<> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
<> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
<> "\n\
<> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n\n")
<> "# The limit for queues that can be blocked via control port per day, resets at 0:00 UTC.\n\
\# Set to 0 to disable limit, to -1 to prohibit blocking. Default is 20.\n\
\# daily_block_queue_quota: 20\n\
\\n\
\[TRANSPORT]\n\
\# Host is only used to print server address on start.\n\
\# You can specify multiple server ports.\n"
@@ -356,8 +356,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
{-# INLINE setQueueService #-}
getQueueNtfServices = withQS (getQueueNtfServices @(JournalQueue s))
{-# INLINE getQueueNtfServices #-}
getNtfServiceQueueCount = withQS (getNtfServiceQueueCount @(JournalQueue s))
{-# INLINE getNtfServiceQueueCount #-}
getServiceQueueCount = withQS (getServiceQueueCount @(JournalQueue s))
{-# INLINE getServiceQueueCount #-}
makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s)
makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do
+8 -3
View File
@@ -82,6 +82,7 @@ prometheusMetrics sm rtm ts =
_qSubEnd,
_qSubEndB,
_ntfCreated,
_ntfNewCreated,
_ntfDeleted,
_ntfDeletedB,
_ntfSub,
@@ -262,15 +263,19 @@ prometheusMetrics sm rtm ts =
\simplex_smp_messages_notify_get_errors{type=\"duplicate\"} " <> mshow _msgGetDuplicate <> "\n# msgGetDuplicate\n\
\simplex_smp_messages_notify_get_errors{type=\"prohibited\"} " <> mshow _msgGetProhibited <> "\n# msgGetProhibited\n\
\\n\
\# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\n\
\# HELP simplex_smp_queues_notify_created Created queue notification credentials.\n\
\# TYPE simplex_smp_queues_notify_created counter\n\
\simplex_smp_queues_notify_created " <> mshow _ntfCreated <> "\n# ntfCreated\n\
\\n\
\# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\n\
\# HELP simplex_smp_queues_notify_new_created Created new queues with notification credentials.\n\
\# TYPE simplex_smp_queues_notify_new_created counter\n\
\simplex_smp_queues_notify_new_created " <> mshow _ntfNewCreated <> "\n# ntfNewCreated\n\
\\n\
\# HELP simplex_smp_queues_notify_deleted Deleted queue notification credentials.\n\
\# TYPE simplex_smp_queues_notify_deleted counter\n\
\simplex_smp_queues_notify_deleted " <> mshow _ntfDeleted <> "\n# ntfDeleted\n\
\\n\
\# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\
\# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queue notification credentials.\n\
\# TYPE simplex_smp_queues_notify_deleted_batch counter\n\
\simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\
\\n\
@@ -43,16 +43,16 @@ import qualified Data.ByteString.Builder as BB
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Bitraversable (bimapM)
import Data.Either (fromRight, lefts, rights)
import Data.Either (fromRight, lefts)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (foldl', intersperse, partition)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
@@ -64,12 +64,12 @@ import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))
import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import GHC.IO (catchAny)
import Simplex.Messaging.Agent.Client (withLockMap, withLocksMap)
import Simplex.Messaging.Agent.Client (withLockMap)
import Simplex.Messaging.Agent.Lock (Lock)
import Simplex.Messaging.Agent.Store.AgentStore ()
import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
import Simplex.Messaging.Agent.Store.Postgres.Common
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
import Simplex.Messaging.Parsers (parseAll)
@@ -83,14 +83,12 @@ import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPServiceRole (..))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>), ($>>=))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>))
import System.Exit (exitFailure)
import System.IO (IOMode (..), hFlush, stdout)
import UnliftIO.STM
#if !defined(dbPostgres)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
import Simplex.Messaging.Encoding.String
#endif
@@ -486,11 +484,15 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
in ((serviceId, sNtfs) : ssNtfs, restNtfs)
getNtfServiceQueueCount :: PostgresQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
getNtfServiceQueueCount st serviceId =
E.uninterruptibleMask_ $ runExceptT $ withDB' "getNtfServiceQueueCount" st $ \db ->
getServiceQueueCount :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
getServiceQueueCount st party serviceId =
E.uninterruptibleMask_ $ runExceptT $ withDB' "getServiceQueueCount" st $ \db ->
fmap (fromMaybe 0) $ maybeFirstRow fromOnly $
DB.query db "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL" (Only serviceId)
DB.query db query (Only serviceId)
where
query = case party of
SRecipientService -> "SELECT count(1) FROM msg_queues WHERE rcv_service_id = ? AND deleted_at IS NULL"
SNotifierService -> "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL"
batchInsertServices :: [STMService] -> PostgresQueueStore q -> IO Int64
batchInsertServices services' toStore =
@@ -346,10 +346,15 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs'
pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs)
getNtfServiceQueueCount :: STMQueueStore q -> ServiceId -> IO (Either ErrorType Int64)
getNtfServiceQueueCount st serviceId =
getServiceQueueCount :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
getServiceQueueCount st party serviceId =
TM.lookupIO serviceId (services st) >>=
maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceNtfQueues)
maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceSel)
where
serviceSel :: STMService -> TVar (Set QueueId)
serviceSel = case party of
SRecipientService -> serviceRcvQueues
SNotifierService -> serviceNtfQueues
withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
@@ -48,7 +48,7 @@ class StoreQueueClass q => QueueStoreClass q s where
getCreateService :: s -> ServiceRec -> IO (Either ErrorType ServiceId)
setQueueService :: (PartyI p, ServiceParty p) => s -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
getQueueNtfServices :: s -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
getNtfServiceQueueCount :: s -> ServiceId -> IO (Either ErrorType Int64)
getServiceQueueCount :: (PartyI p, ServiceParty p) => s -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
data EntityCounts = EntityCounts
{ queueCount :: Int,
+10
View File
@@ -48,6 +48,7 @@ data ServerStats = ServerStats
qSubEnd :: IORef Int,
qSubEndB :: IORef Int,
ntfCreated :: IORef Int,
ntfNewCreated :: IORef Int, -- credentials created at the time of queue creation
ntfDeleted :: IORef Int,
ntfDeletedB :: IORef Int,
ntfSub :: IORef Int,
@@ -107,6 +108,7 @@ data ServerStatsData = ServerStatsData
_qSubEnd :: Int,
_qSubEndB :: Int,
_ntfCreated :: Int,
_ntfNewCreated :: Int,
_ntfDeleted :: Int,
_ntfDeletedB :: Int,
_ntfSub :: Int,
@@ -167,6 +169,7 @@ newServerStats ts = do
qSubEnd <- newIORef 0
qSubEndB <- newIORef 0
ntfCreated <- newIORef 0
ntfNewCreated <- newIORef 0
ntfDeleted <- newIORef 0
ntfDeletedB <- newIORef 0
ntfSub <- newIORef 0
@@ -224,6 +227,7 @@ newServerStats ts = do
qSubEnd,
qSubEndB,
ntfCreated,
ntfNewCreated,
ntfDeleted,
ntfDeletedB,
ntfSub,
@@ -283,6 +287,7 @@ getServerStatsData s = do
_qSubEnd <- readIORef $ qSubEnd s
_qSubEndB <- readIORef $ qSubEndB s
_ntfCreated <- readIORef $ ntfCreated s
_ntfNewCreated <- readIORef $ ntfNewCreated s
_ntfDeleted <- readIORef $ ntfDeleted s
_ntfDeletedB <- readIORef $ ntfDeletedB s
_ntfSub <- readIORef $ ntfSub s
@@ -340,6 +345,7 @@ getServerStatsData s = do
_qSubEnd,
_qSubEndB,
_ntfCreated,
_ntfNewCreated,
_ntfDeleted,
_ntfDeletedB,
_ntfSub,
@@ -400,6 +406,7 @@ setServerStats s d = do
writeIORef (qSubEnd s) $! _qSubEnd d
writeIORef (qSubEndB s) $! _qSubEndB d
writeIORef (ntfCreated s) $! _ntfCreated d
writeIORef (ntfNewCreated s) $! _ntfNewCreated d
writeIORef (ntfDeleted s) $! _ntfDeleted d
writeIORef (ntfDeletedB s) $! _ntfDeletedB d
writeIORef (ntfSub s) $! _ntfSub d
@@ -460,6 +467,7 @@ instance StrEncoding ServerStatsData where
"qSubEnd=" <> strEncode (_qSubEnd d),
"qSubEndB=" <> strEncode (_qSubEndB d),
"ntfCreated=" <> strEncode (_ntfCreated d),
"ntfNewCreated=" <> strEncode (_ntfNewCreated d),
"ntfDeleted=" <> strEncode (_ntfDeleted d),
"ntfDeletedB=" <> strEncode (_ntfDeletedB d),
"ntfSub=" <> strEncode (_ntfSub d),
@@ -523,6 +531,7 @@ instance StrEncoding ServerStatsData where
_qSubEnd <- opt "qSubEnd="
_qSubEndB <- opt "qSubEndB="
_ntfCreated <- opt "ntfCreated="
_ntfNewCreated <- opt "ntfNewCreated="
_ntfDeleted <- opt "ntfDeleted="
_ntfDeletedB <- opt "ntfDeletedB="
_ntfSub <- opt "ntfSub="
@@ -590,6 +599,7 @@ instance StrEncoding ServerStatsData where
_qSubEnd,
_qSubEndB,
_ntfCreated,
_ntfNewCreated,
_ntfDeleted,
_ntfDeletedB,
_ntfSub,
+8 -3
View File
@@ -54,6 +54,7 @@ module Simplex.Messaging.Transport
blockedEntitySMPVersion,
shortLinksSMPVersion,
serviceCertsSMPVersion,
newNtfCredsSMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -166,6 +167,7 @@ smpBlockSize = 16384
-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
-- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
-- 16 - service certificates (5/31/2025)
-- 17 - create notification credentials with NEW (7/12/2025)
data SMPVersion
@@ -208,6 +210,9 @@ shortLinksSMPVersion = VersionSMP 15
serviceCertsSMPVersion :: VersionSMP
serviceCertsSMPVersion = VersionSMP 16
newNtfCredsSMPVersion :: VersionSMP
newNtfCredsSMPVersion = VersionSMP 17
minClientSMPRelayVersion :: VersionSMP
minClientSMPRelayVersion = VersionSMP 6
@@ -215,13 +220,13 @@ minServerSMPRelayVersion :: VersionSMP
minServerSMPRelayVersion = VersionSMP 6
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 16
currentClientSMPRelayVersion = VersionSMP 17
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 16
currentServerSMPRelayVersion = VersionSMP 17
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
@@ -229,7 +234,7 @@ currentServerSMPRelayVersion = VersionSMP 16
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 15
proxiedSMPRelayVersion = VersionSMP 16
-- minimal supported protocol version is 6
-- TODO remove code that supports sending commands without batching
+245 -55
View File
@@ -66,7 +66,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (isRight)
import Data.Int (Int64)
import Data.List (find, nub)
import Data.List (find, isSuffixOf, nub)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Data.Maybe (isJust, isNothing)
@@ -81,7 +81,7 @@ import Data.Word (Word16)
import GHC.Stack (withFrozenCallStack)
import SMPAgentClient
import SMPClient
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, subscribeConnection, sendMessage)
import Simplex.Messaging.Agent hiding (acceptContact, createConnection, deleteConnection, deleteConnections, getConnShortLink, joinConnection, sendMessage, setConnShortLink, subscribeConnection, suspendConnection)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
@@ -91,7 +91,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 (..), TransportSessionMode (..), defaultClientConfig)
import Simplex.Messaging.Client (pattern NRMInteractive, 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
@@ -253,6 +253,12 @@ runRight action =
Right x -> pure x
Left e -> error $ "Unexpected error: " <> show e
runLeft :: (Show a, HasCallStack) => ExceptT e IO a -> IO e
runLeft action =
runExceptT action >>= \case
Right x -> error $ "unexpected result " <> show x
Left e -> pure e
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation
getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
@@ -270,15 +276,18 @@ inAnyOrder g rs = withFrozenCallStack $ do
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
createConnection c userId enableNtfs cMode clientData subMode = do
(connId, (CCLink cReq _, Nothing)) <- A.createConnection c userId enableNtfs cMode Nothing clientData IKPQOn subMode
(connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs cMode Nothing clientData IKPQOn subMode
pure (connId, cReq)
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
joinConnection c userId enableNtfs cReq connInfo subMode = do
connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
(sndSecure, Nothing) <- A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
(sndSecure, Nothing) <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
pure (connId, sndSecure)
acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
acceptContact c = A.acceptContact c NRMInteractive
subscribeConnection :: AgentClient -> ConnId -> AE ()
subscribeConnection c = void . A.subscribeConnection c
@@ -288,6 +297,21 @@ sendMessage c connId msgFlags msgBody = do
liftIO $ pqEnc `shouldBe` PQEncOn
pure msgId
deleteConnection :: AgentClient -> ConnId -> AE ()
deleteConnection c = A.deleteConnection c NRMInteractive
deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ()))
deleteConnections c = A.deleteConnections c NRMInteractive
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
getConnShortLink c = A.getConnShortLink c NRMInteractive
setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
setConnShortLink c = A.setConnShortLink c NRMInteractive
suspendConnection :: AgentClient -> ConnId -> AE ()
suspendConnection c = A.suspendConnection c NRMInteractive
functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
functionalAPITests ps = do
describe "Establishing duplex connection" $ do
@@ -331,6 +355,13 @@ functionalAPITests ps = do
testAsyncServerOffline ps
it "should restore confirmation after client restart" $
testAllowConnectionClientRestart ps
describe "Establishing connections with user retries" $ do
describe "Via invitation" $ do
it "should connect after errors" $ testInvitationErrors ps False
it "should connect after errors with client restarts" $ testInvitationErrors ps True
describe "Via contact" $ do
it "should connect after errors" $ testContactErrors ps False
it "should connect after errors with client restarts" $ testContactErrors ps True
describe "Short connection links" $ do
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
@@ -667,9 +698,9 @@ 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, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
(sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
liftIO $ sqSecured' `shouldBe` sqSecured
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
@@ -869,14 +900,14 @@ 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
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
(sqSecuredJoin, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
(sqSecuredJoin, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` reqPQSupport
bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
(sqSecured', Nothing) <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
(sqSecured', Nothing) <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
liftIO $ sqSecured' `shouldBe` sqSecured
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
liftIO $ pqSup'' `shouldBe` bPQ
@@ -913,7 +944,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
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 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
@@ -922,12 +953,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
msgId = subtract baseId . fst
connectViaContact b pq qInfo = do
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
(sqSecuredJoin, Nothing) <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
(sqSecuredJoin, Nothing) <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ)
(sqSecuredAccept, Nothing) <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
(sqSecuredAccept, Nothing) <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
liftIO $ pqSup'' `shouldBe` pq
@@ -966,13 +997,12 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
testRejectContactRequest :: HasCallStack => IO ()
testRejectContactRequest =
withAgentClients2 $ \alice bob -> runRight_ $ do
(addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
(_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
rejectContact alice addrConnId invId
rejectContact alice invId
liftIO $ noMessages bob "nothing delivered to bob"
testUpdateConnectionUserId :: HasCallStack => IO ()
@@ -982,7 +1012,7 @@ testUpdateConnectionUserId =
newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
_ <- changeConnectionUser alice 1 connId newUserId
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
(sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured' `shouldBe` True
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -1134,11 +1164,166 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
disposeAgentClient alice2
disposeAgentClient bob
testInvitationErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
testInvitationErrors ps restart = do
a <- getAgentA
b <- getAgentB
(bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe
("", "", DOWN _ [_]) <- nGet a
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
-- fails to secure the queue on testPort
BROKER srv NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
(testPort `isSuffixOf` srv) `shouldBe` True
withServer1 ps $ do
("", "", UP _ [_]) <- nGet a
let loopSecure = do
-- secures the queue on testPort, but fails to create reply queue on testPort2
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
loopSecure
("", "", DOWN _ [_]) <- nGet a
b' <- withServer2 ps $ do
threadDelay 200000
let loopCreate = do
-- creates the reply queue on testPort2, but fails to send it to testPort
BROKER srv' NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
loopCreate
restartAgentB restart b [aId]
("", "", DOWN _ [_]) <- nGet b'
n <- withServer1 ps $ do
("", "", UP _ [_]) <- nGet a
threadDelay 200000
let loopConfirm n =
runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
Right (True, Nothing) -> pure n
Right r -> error $ "unexpected result " <> show r
Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
n <- loopConfirm 1
runRight $ do
("", _, CONF confId _ "bob's connInfo") <- get a
allowConnectionAsync a "1" bId confId "alice's connInfo"
get a ##> ("1", bId, OK)
pure n
("", "", DOWN _ [_]) <- nGet a
withServer2 ps $ do
get a ##> ("", bId, CON) -- note that server 1 is down, CON event is sent when HELLO is sent to server 2
("", "", UP _ [_]) <- nGet b'
get b' ##> ("", aId, INFO "alice's connInfo")
get b' ##> ("", aId, CON)
withServer1 ps $ do
("", "", UP _ [_]) <- nGet a
runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn 2 (2 + n) a bId b' aId
disposeAgentClient a
disposeAgentClient b'
restartAgentA :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
restartAgentA = restartAgent_ getAgentA
restartAgentB :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
restartAgentB = restartAgent_ getAgentB
restartAgent_ :: IO AgentClient -> Bool -> AgentClient -> [ConnId] -> IO AgentClient
restartAgent_ getAgent restart c cIds
| restart = do
disposeAgentClient c
threadDelay 200000
c' <- getAgent
rs <- runRight $ subscribeConnections c' cIds
all isRight rs `shouldBe` True
pure c'
| otherwise = pure c
testContactErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
testContactErrors ps restart = do
a <- getAgentA
b <- getAgentB
(contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe
("", "", DOWN _ [_]) <- nGet a
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
-- fails to create queue on testPort2
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
(testPort2 `isSuffixOf` srv2) `shouldBe` True
b' <- restartAgentB restart b [aId]
let loopCreate2 = do
-- creates the reply queue on testPort2, but fails to send invitation to testPort
BROKER srv' NETWORK <- runLeft $ A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2
b'' <- withServer2 ps $ do
loopCreate2
restartAgentB restart b' [aId]
("", "", DOWN _ [_]) <- nGet b''
invId <- withServer1 ps $ do
("", "", UP _ [_]) <- nGet a
let loopSend = do
-- sends the invitation to testPort
runExceptT (A.joinConnection b'' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
Right (False, Nothing) -> pure ()
Right r -> error $ "unexpected result " <> show r
Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend
loopSend
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a
pure invId
("", "", DOWN _ [_]) <- nGet a
bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
withServer2 ps $ do
("", "", UP _ [_]) <- nGet b''
let loopSecure = do
-- secures the queue on testPort2, but fails to create reply queue on testPort
BROKER srv NETWORK <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
unless (testPort `isSuffixOf` srv) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
loopSecure
("", "", DOWN _ [_]) <- nGet b''
a' <- withServer1 ps $ do
("", "", UP _ [_]) <- nGet a
let loopCreate = do
-- creates the reply queue on testPort, but fails to send confirmation to testPort2
BROKER srv2' NETWORK <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
unless (testPort2 `isSuffixOf` srv2') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
loopCreate
restartAgentA restart a [contactId, bId]
("", "", DOWN _ [_, _]) <- nGet a' -- the second connection is from accept
(n, confId) <- withServer2 ps $ do
("", "", UP _ [_]) <- nGet b''
let loopConfirm n =
runExceptT (acceptContact a' 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case
Right (True, Nothing) -> pure n
Right r -> error $ "unexpected result " <> show r
Left _ -> putStrLn "retrying accept confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
n <- loopConfirm 1
("", _, A.CONF confId PQSupportOn _ "alice's connInfo") <- get b''
pure (n, confId)
("", "", DOWN _ [_]) <- nGet b''
runRight_ $ allowConnection b'' aId confId "bob's connInfo"
withServer1 ps $ do
("", "", UP _ [_, _]) <- nGet a'
get a' ##> ("", bId, A.INFO PQSupportOn "bob's connInfo")
get a' ##> ("", bId, A.CON PQEncOn)
get b'' ##> ("", aId, A.CON PQEncOn) -- note that server 2 is down, this event is delivered when HELLO is sent to server 1
a'' <- restartAgentA restart a' [contactId, bId]
withServer2 ps $ do
("", "", UP _ [_]) <- nGet b''
runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn (2 + n) 2 a'' bId b'' aId
disposeAgentClient a''
disposeAgentClient b''
getAgentA :: IO AgentClient
getAgentA = getSMPAgentClient' 1 agentCfg initAgentServers testDB
getAgentB :: IO AgentClient
getAgentB = getSMPAgentClient' 2 agentCfg (initAgentServers {smp = userServers [testSMPServer2]}) testDB2
withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a
withServer1 ps = withSmpServerStoreLogOn ps testPort . const
withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a
withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const
testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
testInviationShortLink viaProxy a b =
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
let userData = UserLinkData "some user data"
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
strDecode (strEncode shortLink) `shouldBe` Right shortLink
connReq' `shouldBe` connReq
@@ -1160,7 +1345,7 @@ testInviationShortLink viaProxy a b =
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', Nothing) <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
(sndSecure', Nothing) <- A.joinConnection b NRMInteractive 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"
@@ -1173,13 +1358,13 @@ testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> Age
testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
let userData = UserLinkData "some user data"
-- can't create short link with previous version
(bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
(bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 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 = UserLinkData "some user data"
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
strDecode (strEncode shortLink) `shouldBe` Right shortLink
connReq' `shouldBe` connReq
@@ -1198,7 +1383,7 @@ testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO
testContactShortLink viaProxy a b =
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
let userData = UserLinkData "some user data"
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
Right connReq <- pure $ smpDecode (smpEncode connReq0)
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
strDecode (strEncode shortLink) `shouldBe` Right shortLink
@@ -1216,8 +1401,8 @@ testContactShortLink viaProxy a b =
(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', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
(sndSecure', Nothing) <- acceptContact a 1 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"
@@ -1236,14 +1421,14 @@ testContactShortLink viaProxy a b =
shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
shortLink2 `shouldBe` shortLink
-- delete short link
runRight_ $ deleteConnShortLink a contactId SCMContact
runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact
Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink
pure ()
testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
testAddContactShortLink viaProxy a b =
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
(contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
(contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
Right connReq <- pure $ smpDecode (smpEncode connReq0) --
let userData = UserLinkData "some user data"
shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
@@ -1263,8 +1448,8 @@ testAddContactShortLink viaProxy a b =
(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', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
(sndSecure', Nothing) <- acceptContact a 1 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"
@@ -1284,7 +1469,7 @@ testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = UserLinkData "some user data"
(bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $
runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
withSmpServer ps $ do
runRight_ $ subscribeConnection a bId
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
@@ -1296,7 +1481,7 @@ testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO
testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = UserLinkData "some user data"
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $
runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
Right connReq <- pure $ smpDecode (smpEncode connReq0)
let updatedData = UserLinkData "updated user data"
withSmpServer ps $ do
@@ -1316,7 +1501,7 @@ testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = UserLinkData "some user data"
((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do
r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
r@(contactId, _) <- A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
(r,) <$> setConnShortLink a contactId SCMContact userData Nothing
Right connReq <- pure $ smpDecode (smpEncode connReq0)
let updatedData = UserLinkData "updated user data"
@@ -1336,7 +1521,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
(contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $
A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
-- make it an "old" queue
let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
() <- case testServerStoreConfig msType of
@@ -2067,9 +2252,9 @@ 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, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
(sqSecured', Nothing) <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
liftIO $ sqSecured' `shouldBe` sqSecured
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` pqSupport
@@ -2235,7 +2420,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
liftIO $ do
let dc = S.fromList $ take nDel cs
all isRight (M.withoutKeys r dc) `shouldBe` True
all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
all (== Left (CONN NOT_FOUND "")) (M.restrictKeys r dc) `shouldBe` True
M.keys r `shouldMatchList` cs
delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
delete c cs = do
@@ -2247,7 +2432,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
deleteFail c cs = do
r <- deleteConnections c cs
liftIO $ do
all (== Left (CONN NOT_FOUND)) r `shouldBe` True
all (== Left (CONN NOT_FOUND "")) r `shouldBe` True
M.keys r `shouldMatchList` cs
runServers :: ExceptT AgentErrorType IO a -> IO a
runServers a = do
@@ -2405,7 +2590,7 @@ testAcceptContactAsync sqSecured alice bob baseId =
(aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
("", _, REQ invId _ "bob's connInfo") <- get alice
bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
bobId <- acceptContactAsync alice 1 "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False
("", _, CONF confId _ "alice's connInfo") <- get bob
allowConnection bob aliceId confId "bob's connInfo"
@@ -3216,7 +3401,7 @@ testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
-- initially passed server is not running
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a 1 srv
testProtocolServer a NRMInteractive 1 srv
where
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
@@ -3614,7 +3799,7 @@ testServerQueueInfo = do
liftIO $ isJust r `shouldBe` True
pure r
checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do
ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId
ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c NRMInteractive cId
liftIO $ do
qiSnd `shouldBe` qiSnd'
qiNtf `shouldBe` False
@@ -3651,24 +3836,29 @@ exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> Agen
exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn
exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetingsMsgId_ = exchangeGreetingsViaProxyMsgId_ False
exchangeGreetingsMsgId_ pqEnc msgId = exchangeGreetingsViaProxyMsgId_ False pqEnc msgId msgId
exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2
exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 2
exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc msgId alice bobId bob aliceId = do
exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc aMsgId bMsgId alice bobId bob aliceId = do
msgId1 <- A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
liftIO $ msgId1 `shouldBe` (msgId, pqEnc)
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
liftIO $ msgId1 `shouldBe` (aMsgId, pqEnc)
get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == aMsgId && viaProxy == isJust srv_; _ -> False
if aMsgId <= bMsgId
then get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
else get bob =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
ackMessage bob aliceId bMsgId Nothing
msgId2 <- A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
let msgId' = msgId + 1
liftIO $ msgId2 `shouldBe` (msgId', pqEnc)
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
let aMsgId' = aMsgId + 1
bMsgId' = bMsgId + 1
liftIO $ msgId2 `shouldBe` (bMsgId', pqEnc)
get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == bMsgId' && viaProxy == isJust srv_; _ -> False
if aMsgId >= bMsgId
then get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
else get alice =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
ackMessage alice bobId aMsgId' Nothing
exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO ()
exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
+13 -2
View File
@@ -61,7 +61,8 @@ import qualified Database.PostgreSQL.Simple as PSQL
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
import SMPClient
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
@@ -69,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken)
import Simplex.Messaging.Agent.Store.Common (withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore)
import Simplex.Messaging.Client (pattern NRMInteractive)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
@@ -194,6 +196,15 @@ testNtfMatrix ps@(_, msType) runTest = do
cfg' = cfgMS msType
cfgVPrev' = cfgVPrev msType
registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
registerNtfToken c = A.registerNtfToken c NRMInteractive
checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
checkNtfToken c = A.checkNtfToken c NRMInteractive
verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
verifyNtfToken c = A.verifyNtfToken c NRMInteractive
runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
@@ -529,7 +540,7 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai
testRunNTFServerTests t srv =
withNtfServer t $
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
+4 -4
View File
@@ -421,10 +421,10 @@ testUpgradeRcvConnToDuplex =
smpClientVersion = VersionSMPC 1
}
upgradeRcvConnToDuplex db "conn1" anotherSndQueue
`shouldReturn` Left (SEBadConnType CSnd)
`shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CSnd)
_ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
upgradeRcvConnToDuplex db "conn1" anotherSndQueue
`shouldReturn` Left (SEBadConnType CDuplex)
`shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CDuplex)
testUpgradeSndConnToDuplex :: SpecWith DBStore
testUpgradeSndConnToDuplex =
@@ -455,10 +455,10 @@ testUpgradeSndConnToDuplex =
deleteErrors = 0
}
upgradeSndConnToDuplex db "conn1" anotherRcvQueue
`shouldReturn` Left (SEBadConnType CRcv)
`shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CRcv)
_ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
upgradeSndConnToDuplex db "conn1" anotherRcvQueue
`shouldReturn` Left (SEBadConnType CDuplex)
`shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CDuplex)
testSetRcvQueueStatus :: SpecWith DBStore
testSetRcvQueueStatus =
+31
View File
@@ -47,6 +47,7 @@ batchingTests = do
it "should batch with 135 subscriptions per batch" testClientBatchSubscriptions
it "should batch with 255 ENDs per batch" testClientBatchENDs
it "should batch with 80 NMSGs per batch" testClientBatchNMSGs
it "should batch subscription responses with message" testBatchSubResponses
it "should break on message that does not fit" testClientBatchWithMessage
it "should break on large message" testClientBatchWithLargeMessage
@@ -207,6 +208,20 @@ testClientBatchNMSGs = do
(length rs1, length rs2, length rs3) `shouldBe` (40, 80, 80)
all lenOk [s1, s2, s3] `shouldBe` True
-- 4 responses are used in Simplex.Messaging.Server / `send`
testBatchSubResponses :: IO ()
testBatchSubResponses = do
client <- testClientStub
soks <- replicateM 4 $ randomSOK
msg <- randomMSG
let msgs = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks <> [msg])
batches = batchTransmissions (thParams client) $ L.fromList msgs
length batches `shouldBe` 1
soks' <- replicateM 5 $ randomSOK
let msgs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks' <> [msg])
batches' = batchTransmissions (thParams client) $ L.fromList msgs'
length batches' `shouldBe` 2
testClientBatchWithMessageV6 :: IO ()
testClientBatchWithMessageV6 = do
client <- testClientStubV6
@@ -361,6 +376,22 @@ randomNMSGCmd ts = do
Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128
pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta)
randomSOK :: IO (Transmission BrokerMsg)
randomSOK = do
g <- C.newRandom
corrId <- atomically $ C.randomBytes 24 g
rId <- atomically $ C.randomBytes 24 g
pure (CorrId corrId, EntityId rId, SOK Nothing)
randomMSG :: IO (Transmission BrokerMsg)
randomMSG = do
g <- C.newRandom
corrId <- atomically $ C.randomBytes 24 g
rId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ C.randomBytes 24 g
msg <- atomically $ C.randomBytes (maxMessageLength currentClientSMPRelayVersion) g
pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg})
randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString))
randomSENDv6 = randomSEND_ C.SEd25519 minServerSMPRelayVersion
+1 -1
View File
@@ -91,7 +91,7 @@ testSocksMode = do
where
transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
transportSocksCfg cfg host =
let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing
let TransportClientConfig {socksProxy} = transportClientConfig cfg NRMInteractive host False Nothing
in socksProxy
testSocksProxyEncoding :: Spec
+3 -3
View File
@@ -19,7 +19,7 @@ import SMPClient (proxyVRangeV8, ntfTestPort, 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 (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
import Simplex.Messaging.Transport
@@ -64,7 +64,7 @@ initAgentServers =
{ smp = userServers [testSMPServer],
ntf = [testNtfServer],
xftp = userServers [testXFTPServer],
netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000},
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
presetDomains = []
}
@@ -96,7 +96,7 @@ agentCfg =
certificateFile = "tests/fixtures/server.crt"
}
where
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
networkConfig = defaultNetworkConfig {tcpConnectTimeout = NetworkTimeout 1_000000 1_000000, tcpTimeout = NetworkTimeout 2_000000 2_000000}
agentProxyCfgV8 :: AgentConfig
agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}}
+1
View File
@@ -226,6 +226,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
newQueueBasicAuth = Nothing,
controlPortUserAuth = Nothing,
controlPortAdminAuth = Nothing,
dailyBlockQueueQuota = 20,
messageExpiration = Just defaultMessageExpiration,
expireMessagesOnStart = True,
idleQueueInterval = defaultIdleQueueInterval,
+19 -19
View File
@@ -167,37 +167,37 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
g <- C.newRandom
-- set up proxy
ts <- getCurrentTime
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- set up relay
msgQ <- newTBQueueIO 1024
rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
rc <- either (fail . show) pure rc'
-- 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)
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive 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")
sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
sess0 `shouldBe` sess
-- send via proxy to unsecured queue
forM_ unsecuredMsgs $ \msg -> do
runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
runExceptT' (proxySMPMessage pc NRMInteractive sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
-- receive 1
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ
dec msgId encBody `shouldBe` Right msg
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId
-- secure queue
(sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
runExceptT' $ secureSMPQueue rc rPriv rcvId sPub
runExceptT' $ secureSMPQueue rc NRMInteractive rPriv rcvId sPub
-- send via proxy to secured queue
waitSendRecv
( forM_ securedMsgs $ \msg' ->
runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
runExceptT' (proxySMPMessage pc NRMInteractive sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
)
( forM_ securedMsgs $ \msg' -> do
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ
@@ -210,12 +210,12 @@ proxyConnectDeadRelay n d proxyServ = do
g <- C.newRandom
-- set up proxy
ts <- getCurrentTime
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- get proxy session
replicateM_ n $ do
sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct")
sess0 <- runExceptT $ connectSMPProxiedRelay pc NRMInteractive (SMPServer testHost "45678" testKeyHash) (Just "correct")
case sess0 of
Right !_noWay -> error "got unexpected client"
Left !_err -> threadDelay d
@@ -224,9 +224,9 @@ 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, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
@@ -280,9 +280,9 @@ 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, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
(bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
(sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
confId <-
get alice >>= \case
@@ -331,9 +331,9 @@ 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, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
(_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
pure ()
where
servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs}
@@ -351,9 +351,9 @@ agentViaProxyRetryOffline = do
let pqEnc = CR.PQEncOn
withServer $ \_ -> do
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
+62 -30
View File
@@ -18,6 +18,7 @@
module ServerTests where
import Control.Concurrent (ThreadId, killThread, threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Control.Exception (SomeException, throwIO, try)
import Control.Monad
@@ -29,6 +30,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Hashable (hash)
import qualified Data.IntSet as IS
import Data.List.NonEmpty (NonEmpty)
import Data.String (IsString (..))
import Data.Type.Equality
import qualified Data.X509.Validation as XV
@@ -75,6 +77,7 @@ serverTests = do
describe "GET command" testGetCommand
describe "GET & SUB commands" testGetSubCommands
describe "Exceeding queue quota" testExceedQueueQuota
describe "Concurrent sending and delivery" testConcurrentSendDelivery
describe "Store log" testWithStoreLog
describe "Restore messages" testRestoreMessages
describe "Restore messages (old / v2)" testRestoreExpireMessages
@@ -96,10 +99,10 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> Transmission (Either ErrorType
pattern Resp corrId queueId command <- (corrId, queueId, Right command)
pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Creator
pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)))
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 _linkId Nothing)
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing Nothing)
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
@@ -111,16 +114,25 @@ sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do
tGet1 h
signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
signSendRecv h pk = signSendRecv_ h pk Nothing
signSendRecv h pk t = do
[r] <- signSendRecv_ h pk Nothing t
pure r
signSendRecv2 :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg), Transmission (Either ErrorType BrokerMsg))
signSendRecv2 h pk t = do
[r1, r2] <- signSendRecv_ h pk Nothing t
pure (r1, r2)
serviceSignSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
serviceSignSendRecv h pk = signSendRecv_ h pk . Just
serviceSignSendRecv h pk serviceKey t = do
[r] <- signSendRecv_ h pk (Just serviceKey) t
pure r
signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg))
signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (authorize tForAuth, tToSend)
tGet1 h
liftIO $ tGetClient h
where
authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t'
@@ -282,7 +294,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))))
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
@@ -297,7 +309,7 @@ testCreateUpdateKeys =
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))))
Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
(rPub', rKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
Resp "2" rId1 OK <- signSendRecv h rKey ("2", rId, RKEY [rPub, rPub'])
rId1 `shouldBe` rId
@@ -365,7 +377,7 @@ testCreateDelete =
Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)
(ok4, OK) #== "accepts OFF when suspended"
Resp "cdab" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
(Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 rh rKey ("cdab", rId, SUB)
(dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)
@@ -404,7 +416,7 @@ stressTest =
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)
Resp "" rId' (SOK Nothing) <- signSendRecv h rKey ("", rId, SUB)
rId' `shouldBe` rId
closeConnection $ connection h1
subscribeQueues h2
@@ -497,7 +509,7 @@ testSwitchSub =
Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
(dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
Resp "bcda" _ (Msg mId2' msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)
(Resp "bcda" _ (SOK Nothing), Resp "" _ (Msg mId2' msg2')) <- signSendRecv2 rh2 rKey ("bcda", rId, SUB)
(dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
@@ -620,6 +632,27 @@ testExceedQueueQuota =
Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
pure ()
testConcurrentSendDelivery :: SpecWith (ASrvTransport, AStoreType)
testConcurrentSendDelivery =
it "should continue delivering messages if message is sent before it is acknowledged" $ \(ATransport t, msType) -> do
g <- C.newRandom
smpTest3 t msType $ \rh sh1 sh2 -> do
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
let dec = decryptMsgV3 dhShared
sndMsg sh n = do
Resp (CorrId n') _ OK <- signSendRecv sh sKey (n, sId, _SEND ("msg " <> n))
n' `shouldBe` n
isMsg1or2 mId msg = dec mId msg == Right "msg 1" || dec mId msg == Right "msg 2" `shouldBe` True
replicateM_ 50 $ do
concurrently_ (sndMsg sh1 "1") (sndMsg sh2 "2")
Resp "" _ (Msg mId1 msg1) <- tGet1 rh
isMsg1or2 mId1 msg1
Resp "3" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("3", rId, ACK mId1)
isMsg1or2 mId2 msg2
Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, ACK mId2)
pure ()
testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
testWithStoreLog =
it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do
@@ -684,7 +717,7 @@ testWithStoreLog =
nId <- readTVarIO notifierId
Resp "dabc" _ (SOK Nothing) <- signSendRecv h1 nKey ("dabc", nId, NSUB)
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
(Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId3 msg3)) <- signSendRecv2 h rKey1 ("cdab", rId1, SUB)
(decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
Resp "" _ (NMSG _ _) <- tGet1 h1
-- this queue is removed - not restored
@@ -762,14 +795,14 @@ testRestoreMessages =
pure ()
rId <- readTVarIO recipientId
logSize testStoreLogFile `shouldReturn` 2
logSize testServerStatsBackupFile `shouldReturn` 94
logSize testServerStatsBackupFile `shouldReturn` 95
Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats1 [rId] 5 1
withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do
Just rKey <- readTVarIO recipientKey
Just dh <- readTVarIO dhShared
let dec = decryptMsgV3 dh
Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
(Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 h rKey ("2", rId, SUB)
(dec mId2 msg2, Right "hello 2") #== "restored message delivered"
Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
(dec mId3 msg3, Right "hello 3") #== "restored message delivered"
@@ -778,7 +811,7 @@ testRestoreMessages =
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
-- the last message is not removed because it was not ACK'd
-- logSize testStoreMsgsFile `shouldReturn` 3
logSize testServerStatsBackupFile `shouldReturn` 94
logSize testServerStatsBackupFile `shouldReturn` 95
Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats2 [rId] 5 3
@@ -786,7 +819,7 @@ testRestoreMessages =
Just rKey <- readTVarIO recipientKey
Just dh <- readTVarIO dhShared
let dec = decryptMsgV3 dh
Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB)
(Resp "4" _ (SOK Nothing), Resp "" _ (Msg mId4 msg4)) <- signSendRecv2 h rKey ("4", rId, SUB)
(dec mId4 msg4, Right "hello 4") #== "restored message delivered"
Resp "5" _ (Msg mId5 msg5) <- signSendRecv h rKey ("5", rId, ACK mId4)
(dec mId5 msg5, Right "hello 5") #== "restored message delivered"
@@ -796,7 +829,7 @@ testRestoreMessages =
pure ()
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
removeFile testStoreLogFile
logSize testServerStatsBackupFile `shouldReturn` 94
logSize testServerStatsBackupFile `shouldReturn` 95
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
removeFileIfExists testStoreMsgsFile
@@ -1131,7 +1164,7 @@ testMsgExpireOnSend =
threadDelay 2500000
Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)")
testSMPClient @c $ \rh -> do
Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB)
(Resp "3" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("3", rId, SUB)
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
@@ -1139,8 +1172,7 @@ testMsgExpireOnSend =
testMsgExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
testMsgExpireOnInterval =
-- fails on ubuntu
xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
@@ -1151,7 +1183,7 @@ testMsgExpireOnInterval =
threadDelay 3000000
testSMPClient @c $ \rh -> do
signSendRecv rh rKey ("2", rId, SUB) >>= \case
Resp "2" _ OK -> pure ()
Resp "2" _ (SOK Nothing) -> pure ()
r -> unexpected r
1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
@@ -1170,7 +1202,7 @@ testMsgNOTExpireOnInterval =
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should NOT expire)")
threadDelay 2500000
testSMPClient @c $ \rh -> do
Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB)
(Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("2", rId, SUB)
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
@@ -1215,9 +1247,9 @@ testInvQueueLinkData =
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)))
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)))
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 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
@@ -1272,9 +1304,9 @@ testContactQueueLinkData =
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)))
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)))
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 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
@@ -1346,8 +1378,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)))) >#> ("", "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)
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)
+2 -1
View File
@@ -33,6 +33,7 @@ import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFi
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
import Simplex.Messaging.Client (pattern NRMInteractive)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
@@ -674,4 +675,4 @@ testXFTPServerTest newFileBasicAuth srv =
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
-- initially passed server is not running
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a 1 srv
testProtocolServer a NRMInteractive 1 srv