Compare commits

...
Author SHA1 Message Date
Evgeny Poberezkin 03168b9fbf 6.1.0.1 2024-09-26 12:23:31 +01:00
spaced4ndy 41e1b2bd39 ntf: use common function for differentiating temporary errors (#1333) 2024-09-25 18:40:59 +01:00
Evgeny 1afa0206a5 smp: increase server and default agent queue sizes (#1335) 2024-09-25 18:33:45 +01:00
spaced4ndyandEvgeny Poberezkin 81fcdf8ac9 ntf: batch smp worker command processing (#1331)
* ntf: refactor smp worker (separate command processing into steps)

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-09-25 15:00:06 +04:00
Evgeny 1f67b403de agent: function to get multiple work items (#1330) 2024-09-25 10:55:45 +01:00
Evgeny 8e7f3f7b27 agent: return full argument with batched results (#1332) 2024-09-24 16:16:52 +01:00
Evgeny Poberezkin e6e9f1d5a5 Merge branch 'stable' 2024-09-24 12:36:05 +01:00
Evgeny Poberezkin 4268b90763 6.0.5.0 2024-09-24 12:34:46 +01:00
Evgeny 856137b763 rfс: efficient message storage (#1295)
* rfs: efficient message storage

* typos

* update
2024-09-24 12:29:44 +01:00
Evgeny d0ee505c3a rfc: protocol for SMP queue data blobs and short links (#1309)
* rfc: protocol for SMP queue data blobs and short links

* update

* private rendezvous
2024-09-24 12:29:11 +01:00
Evgeny 7dcac19a67 xrcp: session encryption with forward secrecy (#1328)
* xrcp: session encryption with forward secrecy

* update doc

* accept keys as parameters

* docs: counter

* spec corrections
2024-09-24 09:22:26 +01:00
Evgeny 22260cd719 agent: transport isolation mode "Session" (default) to use new SOCKS credentials when client restarts or SOCKS proxy configuration changes (#1321)
* agent: transport isolation mode "Session" (default) to use new SOCKS credentials when client restarts or SOCKS proxy configuration changes

* fix test
2024-09-22 22:22:05 +01:00
spaced4ndyandEvgeny Poberezkin bef11e4cbe agent: ntf errs (#1316)
* agent: ntf errs

* refactor

* errs

* refactor

* simplify

* inline

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-09-20 20:08:42 +04:00
Evgeny Poberezkin d5a65656f5 test: socks proxy parameter encoding 2024-09-16 13:15:30 +01:00
Evgeny Poberezkin 309ef3766c 6.1.0.0 2024-09-16 07:28:50 +01:00
Evgeny Poberezkin bde7b97f6a Merge branch 'stable' 2024-09-15 21:38:22 +01:00
Evgeny 398dbeedea servers: allow multiple server ports for SMP and Ntf servers (#1319)
* servers: allow multiple server ports for SMP and Ntf servers

* fix
2024-09-15 21:37:09 +01:00
Evgeny fa772af6c6 agent: support socks proxy without isolate-by-auth, with and without credentials (#1320)
* agent: support socks proxy without isolate-by-auth, with and without credentials

* add unit tests

* make xftp use correct SOCKS credentials

* rename

* support ipv6 in brackets, test parsing

* constant

* textToHostMode

* space
2024-09-15 21:36:31 +01:00
Evgeny Poberezkin 9ebdd2b0ea Merge branch 'stable' 2024-09-14 19:00:36 +01:00
Evgeny bec4e5e038 smp: reduce max message sizes (#1318) 2024-09-14 17:34:29 +01:00
spaced4ndy ea67b34ba7 ntf: batch supervisor commands (#1313) 2024-09-13 15:26:57 +04:00
spaced4ndyandEvgeny Poberezkin e247f691cb agent: do not reuse notifier credentials when re-creating notification subscription; on deleting ntf sub delete directly on smp server skipping ntf server (#1311)
* agent: change notifier credentials when re-creating notification subscription

* skip ndel

* enable tests

* fix race

* Revert "fix race"

This reverts commit ed9b18e8a7.

* delete record

* rename

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-09-12 14:02:51 +04:00
Evgeny Poberezkin 896b2425a4 xrcp: use SHA3-256 in hybrid key agreement (#1302)
This reverts commit 62133ceb24.
2024-09-11 19:32:40 +01:00
spaced4ndy 30e15b881f agent: don't prohibit deletion of notifications token if different is passed (fixes turning notifications off after importing database) (#1308)
* agent: don't prohibit deletion of notifications token if different is passed (fixes turning notifications off after importing database)

* ignore error

* notify
2024-09-11 19:30:59 +01:00
Evgeny Poberezkin 24ded9e5a0 Merge branch 'master' into stable 2024-09-11 19:03:29 +01:00
Evgeny Poberezkin f5e666ae4f 6.0.4.0 2024-09-11 18:51:26 +01:00
Evgeny Poberezkin 62133ceb24 Revert "xrcp: use SHA3-256 in hybrid key agreement (#1302)"
This reverts commit 67d38090ed.
2024-09-11 18:45:44 +01:00
Evgeny 3b50e1fb7d ntf server: only use SOCKS proxy for servers without public address (#1314) 2024-09-11 18:41:40 +01:00
Evgeny 7c25b3b1e0 smp protocol: send DELD when subscribed queue is deleted (#1312)
* smp protocol: send DELD when subscribed queue is deleted

* fix, test

* refactor

* send DELD event only if the client supports it (version 10); send END otherwise

* fix test

* notify on notifier rotation

* increase test delays
2024-09-11 13:16:51 +01:00
Evgeny a70bd02c67 xftp server: round down file creation time to 1 hour (#1310) 2024-09-10 08:14:05 +01:00
sh 7000431249 scripts/servers: update stopscript (#1286)
* scripts/servers: update stopscript

* Major refactoring

* archive -> backups

* simplify logic

* sort files by timestamp
2024-09-09 10:19:17 +01:00
50 changed files with 1702 additions and 462 deletions
+28
View File
@@ -1,3 +1,31 @@
# 6.0.5
SMP agent:
- support generic SOCKS proxy (without isolate-by-auth).
- reduce max message sizes
# 6.0.4
SMP server:
- better performance/memory: fewer map updates on re-subscriptions (#1297), split and reduce STM transactions (#1294)
- send DELD when subscribed queue is deleted (#1312)
- add created/updated/used date to queues to manage expiration (#1306)
XFTP server: truncate file creation time to 1 hour (#1310)
Servers:
- bind control port only to 127.0.0.1 for better security in case of firewall misconfiguration (#1280)
- reduce memory used for period stats (#1298)
Agent: process last notification from list (#1307)
- report receive file error with redirected file ID, when redirect is present (#1304)
- special error when deleted user record is not in database (#1303)
- fix race when sending a message to the deleted connection (#1296)
- support for multiple messages in a single notification
Ntf server:
- only use SOCKS proxy for servers without public address (#1314)
# 6.0.3
Agent:
+1 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 6.0.3.0
version: 6.1.0.1
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
+27 -7
View File
@@ -67,7 +67,7 @@ The session invitation contains this data:
- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
- Session X25519 DH key and SNTRUP761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
- Session X25519 DH key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
Host application decrypts (except the first session) and validates the invitation:
- Session signature is valid.
@@ -184,7 +184,7 @@ The controller decrypts (including the first session) and validates the received
The controller should reply with with `ctrlHello` or `ctrlError` response:
```abnf
ctrlHello = %s"HELLO " kemCiphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
ctrlHello = %s"HELLO " kemCiphertext encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
; ctrlHelloJSON is encrypted with the hybrid secret,
; including both previously agreed DH secret and KEM secret from kemCiphertext
unpaddedSize = largeLength
@@ -206,6 +206,8 @@ JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`:
}
```
Controller `hello` block and all subsequent protocol messages are encrypted with the chain keys derived from the hybrid key (see key exchange below) - that is why conntroller hello block does not include nonce. That provides forward secrecy within the XRCP session. Receiving this `hello` block allows host to compute the same hybrid keys and to derive the same chain keys.
Once the controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections.
### Controller/host session operation
@@ -223,10 +225,12 @@ tlsunique channel binding from TLS session MUST be included in commands (include
The syntax for encrypted command and response body encoding:
```abnf
commandBody = encBody sessSignature idSignature [attachment]
responseBody = encBody [attachment] ; counter must match command
encBody = nonce encLength32 encrypted(tlsunique counter body)
attachment = %x01 nonce encLength32 encrypted(attachment)
commandBody = counter encBody sessSignature idSignature [attachment]
responseBody = counter encBody [attachment] ; counter must match command
; counter is placed outside of encrypted body to allow correlating encryption keys
; with the chain keys (each command and response are encrypted by different keys)
encBody = encLength32 encrypted(tlsunique body)
attachment = %x01 encLength32 encrypted(attachment)
noAttachment = %x00
tlsunique = length 1*OCTET
counter = 8*8 OCTET ; int64
@@ -239,7 +243,7 @@ If the command or response includes attachment, its hash must be included in com
Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted.
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA3-256 over concatenated DH shared secret and KEM encapsulated secret) to derive keys for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secret from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
@@ -273,6 +277,22 @@ If controller fails to store the new host DH key after receiving HELLO block, th
To decrypt a multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers.
Once kemSecret is agreed for the session, it is used to derive two chain keys, to receive and to send messages:
```
host: sndKey, rcvKey = HKDF(kemSecret, "SimpleXSbChainInit", 64)
controller: rcvKey, sndKey = HKDF(kemSecret, "SimpleXSbChainInit", 64)
```
where HKDF is based on SHA512, with empty salt.
Actual keys and nonces to encrypt and decrypt messages are derived from these chain keys:
```
to send: (sndKey', sk, nonce) = HKDF(sndKey, "SimpleXSbChain", 88)
to receive: (rcvKey', sk, nonce) = HKDF(rcvKey, "SimpleXSbChain", 88)
```
## Threat model
#### A passive network adversary able to monitor the site-local traffic:
+179
View File
@@ -0,0 +1,179 @@
# SMP server message storage
## Problem
Currently SMP servers store all queues in server memory. As the traffic grows, so does the number of undelivered messages. What is worse, Haskell is not avoiding heap fragmentation when messages are allocated and then de-allocated - undelivered messages use ByteString and GC cannot move them around, as they use pinned memory.
## Possible solutions
### Solution 1: solve only GC fragmentation problem
Move from ByteString to some other primitive to store messages in memory long term, e.g. ShortByteString, or manage allocation/de-allocation of stored messages manually in some other way.
Pros: the simplest solution that avoids substantial re-engineering of the server.
Cons:
- not a long term solution, as memory growth still has limits.
- may be ineffective, as it introduces additional copying of bytes.
### Solution 2: move message storage to hard drive
Use files or RocksDB to store messages.
Pros:
- much lower memory usage.
- no message loss in case of abnormal server termination (important until clients have delivery redundancy).
- this is a long term solution, and at some point it might need to be done anyway.
Cons:
- substantial re-engineering costs and risks.
- metadata privacy. Currently we only save undelivered messages when server is restarted, with this approach all messages will be stored for some time. this argument is limited, as hosting providers of VMs can make memory snapshots too, on the other hand they are harder to analyze than files. On another hand, with this approach messages will be stored for a shorter time.
#### RocksDB and other key-value stores
The downside of any key-value stores is that they don't seem to have efficient primitives for sequential delivery. While sequential delivery can be modelled with linked lists, they would require 1 key insert (on send), 3 key updates (1 update to update queue data on send, 1 update of the last message to point to the next, 1 update on delivery or message expiration) and 1 key deletion (on delivery or message expiration) for each delivered message.
This might result in substantial write amplification and compacting costs.
In general, tree structures that are efficient for quick lookups and updates, given approximately fixed value size, are inefficient for modelling queues.
#### Files
The upside of files is that they are well suited for sequential delivery and don't result in the same churn, with careful design, as trees do.
The downside of filesystem is that it does not scale well with the large number of files in a folder, so queues will have to be spread across multiple folders, following tree-like structure.
I could not find an available library that efficiently models sequential delivery in highly concurrent environment.
A possible design could be the following.
##### Queue folder and files
Each message queue is stored in its own folder (see below on folder locations). Folder would contain these files:
- `messages.abcd.log` - the file that is used to read messages from, sequentially
- `messages.efgh.log` - the optional file that is used to write messages, in case it is different from read file.
- `queue.log` - append-only file where the last line represents the current queue state
- `queue.timestamp.log` - previous states of queue.log file
Each line in "queue.log" file has this syntax
```abnf
queueLogLine =
%s"read_file=" base64
%s"read_msg=" digits
%s"read_byte=" digits
%s"write_file=" base64
%s"write_msg=" digits
```
When queue is first requested by the server:
```c
if queue folder exists:
read queue state from last line of queue.log
if queue.log contained more than one line: // compaction
copy queue.log to queue.timestamp.log
write one line queue state to queue.log
else:
create queue folder
create messages.abcd.log (abcd is some random string)
read_msg = 0
read_byte = 0
create queue.log with one line: "read_file=abcd read_msg=0 read_byte=0 write_files=abcd write_msg=0"
open read_file in ReadMode and seek to read_byte position
nextReadByte = read_byte
nextReadMsg = read_msg
open write_file in AppendMode
```
When message is added to the queue (assumes that queue state is loaded to server memory, if not the previous section will be done first):
```c
if write_msg > max_queue_messages:
return quota error
else if write_msg = max_queue_messages:
add quota_exceeded message to write_file
update queue state: write_msg += 1
append updated queue state to queue.log
else ]
// It is required that `max_queue_messages < max_file_messages`,
// so that we never need more than one additional write file.
if write_msg >= max_file_messages: // queue file rotation
create messages.efgh.log // efgh is some random string
update queue state: write_file=efgh write_msg=0 // read file remains the same as it was
append updated queue state to queue.log
copy queue.log to queue.timestamp.log
// `old` needs to be defined to limit the number and storage duration,
// preserving not more than N files, and not more than M days files, "and then some"
// (that is if the queue has high churn, we have file from M days before in any case, for any debugging).
delete `old` `queue.timestamp.log` files
write one line queue state to queue.log // compaction
add message to write_file
update queue state: write_msg += 1
append updated queue state to queue.log
```
The above algorithm assumes `max_queue_messages < than max_file_messages`, so that we never need more than one write file.
When message is delivered, it is simply read from the read queue, queue state does not change yet:
```c
if nextReadMsg > read_msg:
deliver cached message, no need to read it again
else
read message from read_file handle
nextReadMsg = read_msg + 1
nextReadByte = current position in file
```
When message delivery is acknowledged, the read queue needs to be advanced, and possibly switched to read from the current write_queue:
```c
if nextReadByte == read_byte:
return error // nothing was delivered
else if nextReadByte = EOF:
// end of file is reached, possibly some other condition,
// but it should allow changing max_file_messages on server restart
currReadFile = read_file
read_file = write_file
read_msg = 0
read_byte = 0
append updated queue state to queue.log
delete currReadFile
else
read_msg += 1
read_byte = nextReadByte
// `seek` should not be necessary, as the handle is already at nextReadByte position here
// seek to read_byte
append updated queue state to queue.log
```
The above algorithm delegates the problem of compaction and fragmentation management to file system, that is very optimized for such scenarios.
Also, read and write files will grow to almost a constant size, so the space they used may be re-used.
An important consideration is that writes to queue.log and message.log files and queue state modifications have to be sequential, without concurrency - it can be managed with the usual locks.
##### Queue folders structure
Most Linux systems use EXT4 filesystem where the file lookup time scales linearly to the number of files. While alternatives with logarithmic lookup time exist (XFS), they may be very complex to configure on the existing systems.
So storing all queue folders in one folder won't scale.
To solve this problem we could use recipient queue ID in base64url format not as a folder name, but as a folder path, splitting it to path fragments of some length. The number of fragments can be configurable and migration to a different fragment size can be supported as the number of queues on a given server grows.
Currently, queue ID is 24 bytes random number, thus allowing 2^192 possible queue IDs. If we assume that a server must hold 1b queues, it means that we have ~2^162 possible addresses for each existing queue. 24 bytes in base64 is 32 characters that can be split into say 8 fragments with 4 characters each, so that queue folder path for queue with ID `abcdefghijklmnopqrstuvwxyz012345` would be:
`/var/opt/simplex/messages/abcd/efgh/ijkl/mnop/qrst/uvwx/yz01/2345`
The maximum theoretic number of the folders on the 1st level is 64^4, or 2^24 ~ 16m - this is probably still a large number of subfolders for EXT4. Given that addresses are random, all the possible combinations in the first folder can be used with a large number of queues.
So we could use an unequal split of path, two letters each and the last being long:
`/var/opt/simplex/messages/ab/cd/ef/ghijklmnopqrstuvwxyz012345`
The first three levels in this case can have 4096 subfolders each, and it gives 68b possible subfolders (64^2^3), so the last level will be sparse in case of 1b queues on the server. So we could make it 4 levels with 2 letters to never think about it, accounting for a large variance of the random numbers distribution:
`/var/opt/simplex/messages/ab/cd/ef/gh/ijklmnopqrstuvwxyz012345`
+124
View File
@@ -0,0 +1,124 @@
# Short invitation links
## Problem
Long links look scary and unsafe for many users. While this is a perceived problem, rather than a real one, it hurts adoption.
What is worse, long links do not fit in profile descriptions of other social networks where people might want to advertize their contact addresses.
The current link size limitation is also the reason for not including PQ KEM keys into invitation links and addresses, postponing the moment when PQ-resistant encryption kicks in - if we include PQ KEM key into the link, the QR code will not be scannable.
Additionally, if we store short links, they can also include chat preferences and public profile data.
## Solution
MITM-resistant link shortening.
Instead of generating the random address that would resolve into the link - doing so would create the possibility of MITM by the server hosting this link - we can use private key as the link ID that will be passed to the accepting party, and the hash of the public key as ID for the server - the accepting party would present this key itself as ID and it will also be used for server to client encryption (see Protocol below). HKDF will be used to derive symmetric key from private key and used in secret_box together with random nonce (to allow replacing data with the same key but with a different nonce - nonce will be sent to the server too). secret_box construction is authenticated encryption, so it would protect from MITM.
The proposed syntax:
```abnf
shortConnectionRequest = connectionScheme "/" connReqType "#/" smpServer "/" linkHash
connReqType = %s"invitation" / %s"contact"
connectionScheme = (%s"https://" clientAppServer) / %s"simplex:"
clientAppServer = hostname [ ":" port ]
; client app server, e.g. simplex.chat
smpServer = serverIdentity "@" srvHosts [":" port] ; no smp:// prefix, no escaping
srvHosts = <hostname> ["," srvHosts] ; RFC1123, RFC5891
linkHash = <base64url encoded SHA256 or SHA512 hash of the original link>
```
If SMP server supports pages, its name can be used as clientAppServer, without repeating it after #, for a shorter link.
Example link:
```
https://simplex.chat/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im/abcdefghij0123456789abcdefghij0123456789abc=
```
This link has the length of ~136 characters (256 bits), which is shorter than the full contact address (~310 characters) and much shorter than invitation links (~528 characters) even without post-quantum keys added to them.
This size can be further reduced by
- use server domain in the link.
- do not include onion address, as the connection happens via proxy anyway, if it's untrusted server.
- not pinning server TLS certificate - the downside here is that while the attack that compromises TLS will not be able to substitute the link (because it's hash will not match), it will be able to intercept and to block it.
- using shorter hash, e.g. SHA128 - reducing the collision resistance.
If the server is known, the client could use it's hash and onion address, otherwise it could trust the proxy to use any existing session with the same hostname or to accept the risk of interception - given that there is no risk of substitution.
With the first two of these "improvements" the link could be ~122 characters:
```
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@/abcdefghij0123456789abcdefghij0123456789abc
```
If onion address is preserved the link will be ~184 characters (won't fit in Twitter 160 characters bio):
```
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
```
If we implement it, the request to resolve the link would be made via proxied SMP command (to avoid the direct connection between the client and the recipient's server).
Pros:
- a bit shorter link.
- possibility to include post-quantum keys into the full link keeping the same shortened link size.
- possibility to include chat profile of contact or group, and preferences, for a much better connection experience, and to show this information when the link sent in the conversation (clients can resolve them automatically, without connecting - it can be resolved by the sending clients).
- server will not have access to the link.
Cons:
- protocol complexity.
- observers can access the link content, so for 1-time invitation we should only include permissions and not profile.
Pros are a huge improvement of UX of connecting both within and from outside of the app (e.g., link can be resolved even before creating chat profile, as part of the onboarding).
## Protocol
To support short links, the SMP servers would provide a simple key-value store enabled by three additional commands: `WRT`, `CLR` and `READ`
`WRT` command is used to store and to update values in the store. The size of the value is limited by the same size as sent messages (or, possibly, smaller - as connection information size used in confirmation messages) - the clients would use this fixed size irrespective of the content. `WRT` command will be sent with the data blob ID in the transaction entityId field, public authorization key used to authorize `WRT` and `CLR` commands (subsequent WRT commands to the existing key must use the same key), and the data blob.
`CLR` command must use with the same entity ID and must be authorized by the same key.
`READ` command must use the ID which hash would be equal of the ID used to create the data blob, and this ID would also be used as public authorization
## Algorithm to store and to retrieve data blob.
**Store data blob**
- the data blob owner generates X25519 key pair: `(k, pk)`.
- private key `pk` will be included in the short link shared with the other party (only base64url encoded key bytes, not X509 encoding).
- `HKDF(pk)` will be used to encrypt the link data with secret_box before storing it on the server.
- the hash of public key `sha256(k)` will be used as ID by the owner to store and to remove the data blob (`WRT` and `CLR` commands).
**Retrieve data blob**
- the sender uses the public key `k` derived from the private key `pk` included in the link as entity ID to retrieve data blob (the server will compute the ID used by the owner as `sha256(k)` and will be able to look it up). This provides the quality that the traffic of the parties has no shared IDs inside TLS. It also means that unlike message queue creation, the ID to retrieve the blob was never sent to the blob creator, and also is not known to the server in advance (the second part is only an observation, in itself it does not increase security, as server has access to an encrypted blob anyway).
- note that the sender does not authorize the request to retrieve the blob, as it would not increase security unless a different key is used to authorize, and adding a key would increase link size.
- server session keys with the sender will be `(sk, spk)`, where `sk` is public key shared with the sender during session handshake, and `spk` is the private key known only to the server.
- this public key `k` will also be combined with server session key `spk` using `dh(k, spk)` to encrypt the response, so that there is no ciphertext in common in sent and received traffic for these blobs. Correlation ID will be used as a nonce for this encryption.
- having received the blob, the client can now decrypt it using secret_box with `HKDF(pk)`.
Using the same key as ID for the request, and also to additionally encrypt the response allows to use a single key in the link, without increasing the link size.
## Threat model
**Compromised SMP server**
can:
- delete link data.
- hide link selectively from some requests.
cannot:
- undetectably replace link data.
- access unencrypted link data, whether it was or was not accessed by the accepting party.
- observe IP addresses of the users accessing link data.
**Passive observer who observed short link**:
can:
- access original unencrypted link data
cannot:
- replace or delete the link data
+81
View File
@@ -0,0 +1,81 @@
# Storage considerations for SMP queues
See [Short invitation links](./2024-06-21-short-links.md).
## Problem
1) queue records are created permanently, until the clients delete them.
2) clients only delete queue records based on some user action, pending connections do not expire.
While part 2 should be improved in the client, indefinite storage of queue records becomes a much bigger issue if each of them would result in a permanent storage of 4-16kb blob in server memory, without server-side expiration for short invitation links.
## Possible solutions
1) Add some queue timestamp, e.g. queue creation date, to expire unsecured queues after say 3 weeks.
The problem with this approach is that contact addresses are also unsecured queues, and they should not be expired.
We could set really large expiration time, and require that clients "update" the unsecured queues they need at least every 1-2 years, but it would not solve the problem of storing a large number of blobs in the server memory for unused/abandoned 1-time invitations.
2) Do not store blobs in memory / append-only log, and instead use something like RocksDB. While it may be a correct long term solution, it may be not expedient enough at the current POC stage for this feature. Also, the lack of expiration is wrong in any case and would indefinitely grow server storage.
3) Add flag allowing the server to differentiate permanent queues used as contact addresses, also using different blob sizes for them. In this case, messaging queues will be expired if not secured after 3 weeks, and contact address queues would be expired if not "updated" by the owner within 2 years.
Probably all three solutions need to be used, to avoid creating a non-expiring blob storage in memory, as in case too many of such blobs are created it would not be possible to differentiate between real users and resource exhaustion attacks, and unlike with messages, they won't be expiring too.
Servers already can differentiate messaging queues and contact address queues, if they want to:
- with the old 4-message handshake, the confirmation message on a normal queue was different, and also KEY command was eventually used.
- with the fast 2-message handshake, while the confirmation message has the same syntax, and the differences are inside encrypted envelope, the client still uses SKEY command.
- in both cases, the usual messaging queues are secured, and contact addresses are not, so this difference is visible in the storage as well (although it is not easy to differentiate between abandoned 1-time invitations and contact addresses).
Differentiating these queues can also allow different message retention times - e.g., the queues for contact addresses could have bigger size, but have lower message retention time.
## Proposed solution
1. Add queue updated_at date into queue records. While it adds some metadata, it seems necessary to manage retention and quality of service. It will not include exact time, only date, and the time of creation will be replaced by the time of any update - queue secured, a message is sent, or queue owner subscribes to the queue. To avoid the need to update store log on every message this information can be appended to store log on server termination. Or given that only one update per day is needed it may be ok to make these updates as they happen (temporarily making the sequence and time of these events available in storage).
2. Add flag to indicate the queue usage - messaging queue or queue for contact address connection requests. This would result in different queue size and different retention policy for queue and its messages. We already have "sender can secure flag" which is, effectively, this flag - contact address queues are never secured. So this does not increase stored metadata in any way.
## Possible changes to short links
This is a design considerations and a concept, not a design yet.
Instead of implementing a generic blob storage that can be used as an attack vector, and adds additional failure point (another server storing blob that is necessary to connect to the queue on the current server), but instead adds an extended queue information blobs, most of which could be dropped without the loss of connectivity, so that the attack can be mitigated by deleting these blobs without users losing the ability to connect, as long as the queue and minimal extended information is retained.
So, to make the connection there need to be these elements:
- queue server and queue ID - mandatory part, that can be included in short link
- SMP key - mandatory part for all queues. We are considering initializing ratchets earlier for contact addresses, and include ratchet keys and pre-keys into queue data as well, but it is out of scope here.
- Ratchet keys - mandatory part for 1-time invitation that won't fit in short link.
- PQ key - optional part that can be stored with addresses if ratchet keys are added and with 1-time invitations.
- App blobs - chat preferences for 1-time invitation links and profile information for contact addresses.
So rather that storing one blob with a large address inside it, not associated with the queue, increasing probability of failure and reducing our ability to mitigate resource exhaustion, we could store extended blobs associated with the queues.
Also, we need the address shared with the sender (party accepting the connection) to be short. We could use a similar approach that was proposed for data blobs, using a single random seed per queues to derive multiple keys and IDs from it. For example:
1. The queue owner:
- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now sent in NEW command.
- generates queue recipient ID (this ID can still be server-generated).
- generates X25519 key pair `(k, pk)` to use with the accepting party.
- derives from `k`:
- sender ID.
- symmetric key for authenticated encryption of blobs.
- `k` will be used as short link.
2. All other data from the invitation can be included in queue creation request and be associated with the queue as 1-3 blobs with different priority:
- ratchet keys - it will have a small size, so only this blob cannot be removed, while other blobs can be removed in case of resource exhaustion.
- PQ keys - optional blob.
- conversation preferences and profile - can be removed depending on creation time, e.g. all new blobs can be removed.
The algorithm used to derive key and ID from `k` needs to be cryptographically secure, e.g. it could be some KDF or ChaCha DRG initialized with `k` as seed, TBC.
So, coupling blob storage with messaging queues has these pros/cons:
Cons:
- no additional layer of privacy - the server used for connection is visible in the link, even after the blobs are removed from the server.
Pros:
- no additional point of failure in the connection process - the same server will be used to retrieve necessary blobs as for connection.
- queue blobs of messaging blobs will be automatically removed once the queue is secured or expired, without additional request from the recipient - reducing the storage and the time these blobs are available.
- queue blobs for contact addresses will be structured and some of the large blobs can be removed in case of resource exhaustion attack (and recreated by the client if needed), with the only downside that PQ handshake will be postponed (which is the case now) and profile will not be available at a point of connection.
+80
View File
@@ -0,0 +1,80 @@
# Blob extensions for SMP queues
Evolution of the design for short links, see [here](./2024-06-21-short-links.md) and [here](./2024-09-05-queue-storage.md).
## Problems
Allow storing extended information with SMP queues to improve UX and security of making connections:
- short invitation links and contact addresses.
- PQ encryption from the first message.
- present user profile with chat preferences and welcome message when the public address link is scanned.
## Design
1. Queue creation/update date is already added to server persistence, allowing to expire queues and blobs, depending on their usage.
2. Add "queue type" metadata to NEW command to indicate whether messaging queue is used as public address or as messaging queue (see previous docs on why it doesn't change threat model). While at the moment it would match sndSecure flag there may be future scenarios when they diverge. Initially only "invitation" and "contact" types will be supported.
3. Prohibit sndSecure flag for "contact" queues, prohibit securing contact queues.
4. Add "queue blobs" to NEW command:
- blob0: ratchetKeys up to N0 bytes - priority 0, can't be removed by the server, only in "invitation"
- blob1: PQ key up to N1 bytes - priority 1, can be removed by the server, only used in "invitation"
- blob2: Application data up to N2 bytes - priority 2, can be removed by the server.
5. Add linkId to NEW command
6. linkId and blobs will be removed when queue is secured.
7. Add recipient command to remove/upsert blob2 for contact queues.
8. Add sender command to retrieve blobs.
## Protocol
### Creating a queue:
The queue owner:
- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now. `sk` and `dhk` will be sent in NEW command.
- generates X25519 key pair `(k, pk)` to use with the accepting party to encrypt queue messages.
- derives from `k` using HKDF:
- symmetric key `bk` for authenticated encryption of blobs.
- `linkId`, will be sent in NEW command.
- `k` will be used as short link.
- sends NEW command.
NEW command syntax:
```abnf
create = %s"NEW " linkId queueType recipientAuthPublicKey recipientDhPublicKey
basicAuth subscribe sndSecure [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ]
queueType = %s"I" / %s "C" ; new parameter
linkId = length *OCTET ; new parameter,
; can be empty in which case blobs won't be allowed
blob0 = word16 *OCTET ; new parameter, encrypted ratchet keys,
; including nonce and auth tag
blob1 = word16 *OCTET ; new parameter, encrypted PQ key
blob2 = word16 *OCTET ; new parameter, encrypted application data
```
SET - command to update queue blobs (recipientId is used as entity ID):
```abnf
set = %s"SET " linkId [ "2" blob2 ] ; passing empty blob removes it
linkId ; updated (or the same) linkId, can be empty to remove blobs
; allows to change the address without removing the queue / changing blobs
; (e.g., to avoid losing the messages).
```
### Sending messages to the queue
GET - command to get queue blobs (linkId is used as entity ID):
```abnf
get = %s"GET"
```
Response to GET:
```abnf
blobs = %s"BLOB" senderId [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ]
```
As blobs are retrieved using a separate linkId, once blobs are removed it will be impossible to find senderId from short link - it is a threat model improvement. Once server storage is compacted, it will be impossible to find queue related to the link even with the access to server data (unless server preserves the data).
### Possible privacy improvement
We could only allow unauthorized GET and authorized SET commands for long-term "contact" queues, and return BLOB in response to SKEY (or require that GET is authorized) - so that only the person who secures the queue will get access to data blobs. This way it ensures that the parties transmitting the invitation links cannot retrieve their content without the sender noticing it.
+26
View File
@@ -0,0 +1,26 @@
# Private rendezvous protocol
## Problem
Our current handshake protocol is open to this attack: whoever observes the link exchange, knows on which server connection is being made, and if the traffic on this server is observed, then it can confirm communication between parties. Further, even with the [last proposal](./2024-09-09-smp-blobs.md#possible-privacy-improvement), having real-time access to the server data allows to establish the exact messaging queue that is used to send messages.
## Solution
We could make the initial link exchange more private by making it harder for any observer to discover which server will be used for messaging by hiding this information from the server that hosts the initial link.
Preliminary, the protocol could be the following:
1. Connection initiator stores 224-256 bytes of encrypted connection link on a rendezvous server (link contains server host and linkId on another messaging server, not a rendezvous one).
2. Rendezvous server adds these links to buckets, up to 64 links per bucket. Bucket ID is the timestamp when the bucket was created + a sequential bucket number, in case more than one bucket is created per second.
3. The server responds to the link creator with a bucket ID where this link was added. That bucket ID is its timestamp + a number prevents server "fingerprinting" clients and using say one bucket for each client. If timestamp is different or a bucket number within this timestamp is too large, the client can refuse to use it, depending on the client settings.
4. The initiating party will pass to the accepting party the rendezvous server host, the hash of this bucket ID (bucket link) and the passphrase to derive the key from. The initiating party has an option to pass a link and passphrase via two channels - in which case the link will only contain the bucket ID.
5. The accepting party would then request the bucket via its ID hash (the server would store hashes to be able to look up - hash is used to prevent showing time in the link) and attempt to decrypt all contained links using the provided key.
The accepting party then will continue the connection via the decrypted link.
This obviously does not protect accepting party from the initiating party, if it can choose rendezvous server it controls. It also does not protect from the malicious rendezvous server that would collaborate with link observers. I think reunion doesnt protect from it too.
But it does protect connection from whoever observes the link, particularly if this link only contains the bucket and the key is passed separately, via some other channel.
+165 -21
View File
@@ -1,30 +1,174 @@
#!/usr/bin/env sh
set -eu
path_conf_var="/var/opt"
path_conf_smp="$path_conf_var/simplex"
path_conf_xftp="$path_conf_var/simplex-xftp"
path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
# Common
# ------
date="$(date -u '+%Y-%m-%dT%H:%M:%S')"
backup_smp() {
if [ -e "$path_conf_storelog_smp" ]; then
cp "$path_conf_storelog_smp" "${path_conf_storelog_smp}.${date:-date-failed}"
fi
GRN='\033[0;32m'
YLW='\033[1;33m'
BLU='\033[1;34m'
RED='\033[0;31m'
NC='\033[0m'
path_conf_var="/var/opt"
smp_variables() {
path_conf_smp="$path_conf_var/simplex"
path_conf_smp_archive="$path_conf_smp/backups"
path_conf_smp_archive_storelog="$path_conf_smp_archive/queues"
path_conf_smp_archive_stats="$path_conf_smp_archive/stats"
path_conf_smp_archive_messages="$path_conf_smp_archive/messages"
path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
path_conf_storelog_smp_out="$path_conf_smp_archive_storelog/smp-server-store.log.${date:-date-failed}"
path_conf_stats_smp="$path_conf_smp/smp-server-stats.log"
path_conf_stats_smp_out="$path_conf_smp_archive_stats/smp-server-stats.log.${date:-date-failed}"
path_conf_messages_smp="$path_conf_smp/smp-server-messages.log"
path_conf_messages_smp_out="$path_conf_smp_archive_messages/smp-server-messages.log.${date:-date-failed}"
}
backup_xftp() {
if [ -e "$path_conf_storelog_xftp" ]; then
cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
fi
xftp_variables() {
path_conf_xftp="$path_conf_var/simplex-xftp"
path_conf_xftp_archive="$path_conf_xftp/backups"
path_conf_xftp_archive_storelog="$path_conf_xftp_archive/queues"
path_conf_xftp_archive_stats="$path_conf_xftp_archive/stats"
path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
path_conf_storelog_xftp_out="$path_conf_xftp_archive_storelog/file-server-store.log.${date:-date-failed}"
path_conf_stats_xftp="$path_conf_xftp/file-server-stats.log"
path_conf_stats_xftp_out="$path_conf_xftp_archive_stats/file-server-stats.log.${date:-date-failed}"
}
if [ "$1" = 'smp-server' ]; then
backup_smp
elif [ "$1" = 'xftp-server' ]; then
backup_xftp
else
backup_smp
backup_xftp
fi
checks() {
result=${SERVICE_RESULT:-exit-code}
status=${EXIT_STATUS:-TERM}
case "$result" in
success)
case "$status" in
TERM)
printf "${RED}Refusing to backup files with failed service state${NC}\n"
exit 1
;;
*)
:
;;
esac
;;
*)
printf "${RED}Refusing to backup files with failed service state${NC}\n"
exit 1
;;
esac
}
smp_check() {
if [ ! -d "$path_conf_smp_archive_storelog" ]; then
mkdir -p "$path_conf_smp_archive_storelog"
fi
if [ ! -d "$path_conf_smp_archive_messages" ]; then
mkdir -p "$path_conf_smp_archive_messages"
fi
if [ ! -d "$path_conf_smp_archive_stats" ]; then
mkdir -p "$path_conf_smp_archive_stats"
fi
}
xftp_check() {
if [ ! -d "$path_conf_xftp_archive_storelog" ]; then
mkdir -p "$path_conf_xftp_archive_storelog"
fi
if [ ! -d "$path_conf_xftp_archive_stats" ]; then
mkdir -p "$path_conf_xftp_archive_stats"
fi
}
backup() {
file="$1"
out="$2"
file_type="$3"
if [ -e "$file" ]; then
if cp "$file" "$out"; then
printf "${YLW}${file_type}${NC} ${GRN}backup successful:${NC} ${BLU}%s${NC}\n" "${out}"
else
printf "${YLW}${file_type}${NC} ${RED}backup failed!${NC}\n"
fi
fi
unset file out file_type
}
cleanup() {
directory="$1"
file_type="$2"
files_date=$(find "$directory" -type f -exec stat --format="%y" {} + | awk '{print $1}' | sort -nr | uniq | awk 'NR==2')
if [ -n "$files_date" ]; then
files=$(find "$directory" -type f -not -newermt "$files_date" -printf "%T@ %Tc %p\n" | sort -n | awk '{print $NF}')
if [ -n "$files" ]; then
printf '%s' "$files" | xargs rm -f
printf "${YLW}Old ${file_type} files${NC}${GRN} has been deleted:${NC}\n"
files_colored=$(printf '%s' "$files" | awk '{print "\033[1;34m"$0"\033[0m"}')
printf "${files_colored}\n"
fi
fi
unset directory file_type files_date files
}
smp_backup() {
backup "$path_conf_storelog_smp" "$path_conf_storelog_smp_out" 'Storelog'
backup "$path_conf_messages_smp" "$path_conf_messages_smp_out" 'Messages'
backup "$path_conf_stats_smp" "$path_conf_stats_smp_out" 'Stats'
}
smp_cleanup() {
cleanup "$path_conf_smp_archive_storelog" 'storelog'
cleanup "$path_conf_smp_archive_stats" 'stats'
cleanup "$path_conf_smp_archive_messages" 'messages'
}
xftp_backup() {
backup "$path_conf_storelog_xftp" "$path_conf_storelog_xftp_out" 'Storelog'
backup "$path_conf_stats_xftp" "$path_conf_stats_xftp_out" 'Stats'
}
xftp_cleanup() {
cleanup "$path_conf_xftp_archive_storelog" 'storelog'
cleanup "$path_conf_xftp_archive_stats" 'stats'
}
main() {
type="${1:-}"
checks
case "$type" in
smp-server)
smp_variables
smp_check
smp_backup
smp_cleanup
;;
xftp-server)
xftp_variables
xftp_check
xftp_backup
xftp_cleanup
;;
*)
printf "${YLW}Unknown server type.${NC}\n"
exit 1
;;
esac
}
main "$@"
+2 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 6.0.3.0
version: 6.1.0.1
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -610,6 +610,7 @@ test-suite simplexmq-test
CoreTests.CryptoTests
CoreTests.EncodingTests
CoreTests.RetryIntervalTests
CoreTests.SOCKSSettings
CoreTests.TRcvQueuesTests
CoreTests.UtilTests
CoreTests.VersionRangeTests
+6 -5
View File
@@ -22,6 +22,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Time.Clock (UTCTime)
import Data.Word (Word32)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
@@ -36,8 +37,8 @@ import Simplex.Messaging.Client
TransportSession,
chooseTransportHost,
defaultNetworkConfig,
proxyUsername,
transportClientConfig,
clientSocksCredentials,
unexpectedResponse,
)
import qualified Simplex.Messaging.Crypto as C
@@ -98,9 +99,9 @@ defaultXFTPClientConfig =
clientALPN = Just supportedXFTPhandshakes
}
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
let username = proxyUsername transportSession
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
ProtocolServer _ host port keyHash = srv
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
@@ -108,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
clientVar <- newTVarIO Nothing
let usePort = if null port then "443" else port
clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client socksCreds useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
let HTTP2Client {sessionId, sessionALPN} = http2Client
v = VersionXFTP 1
thServerVRange = versionToRange v
+6 -3
View File
@@ -16,6 +16,7 @@ import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
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)
@@ -30,6 +31,7 @@ type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
data XFTPClientAgent = XFTPClientAgent
{ xftpClients :: TMap XFTPServer XFTPClientVar,
startedAt :: UTCTime,
config :: XFTPClientAgentConfig
}
@@ -56,19 +58,20 @@ data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent config = do
xftpClients <- TM.emptyIO
pure XFTPClientAgent {xftpClients, config}
startedAt <- getCurrentTime
pure XFTPClientAgent {xftpClients, startedAt, config}
type ME a = ExceptT XFTPClientAgentError IO a
getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
atomically getClientVar >>= either newXFTPClient waitForXFTPClient
where
connectClient :: ME XFTPClient
connectClient =
ExceptT $
first (XFTPClientAgentError srv)
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected
clientDisconnected :: XFTPClient -> IO ()
clientDisconnected _ = do
+6 -3
View File
@@ -33,7 +33,6 @@ import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Word (Word32)
import qualified Data.X509 as X
@@ -57,6 +56,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
@@ -399,7 +399,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
r <- runExceptT $ do
sizes <- asks $ allowedChunkSizes . config
unless (size file `elem` sizes) $ throwE SIZE
ts <- liftIO getSystemTime
ts <- liftIO getFileTime
-- TODO validate body empty
sId <- ExceptT $ addFileRetry st file 3 ts
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
@@ -412,7 +412,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
pure $ FRSndIds sId rIds
pure $ either FRErr id r
addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
addFileRetry st file n ts =
retryAdd n $ \sId -> runExceptT $ do
ExceptT $ addFile st sId file ts
@@ -531,6 +531,9 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
getFileTime :: IO RoundedSystemTime
getFileTime = getRoundedSystemTime fileTimePrecision
expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
expireServerFiles itemDelay expCfg = do
st <- asks store
+10 -6
View File
@@ -17,6 +17,7 @@ module Simplex.FileTransfer.Server.Store
expiredFilePath,
getFile,
ackFile,
fileTimePrecision,
)
where
@@ -25,12 +26,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Time.Clock.System (SystemTime (..))
import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (ifM, ($>>=))
@@ -46,9 +47,12 @@ data FileRec = FileRec
fileInfo :: FileInfo,
filePath :: TVar (Maybe FilePath),
recipientIds :: TVar (Set RecipientId),
createdAt :: SystemTime
createdAt :: RoundedSystemTime
}
fileTimePrecision :: Int64
fileTimePrecision = 3600 -- truncate creation time to 1 hour
data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
instance StrEncoding FileRecipient where
@@ -62,14 +66,14 @@ newFileStore = do
usedStorage <- newTVarIO 0
pure FileStore {files, recipients, usedStorage}
addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())
addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
addFile FileStore {files} sId fileInfo createdAt =
ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
f <- newFileRec sId fileInfo createdAt
TM.insert sId f files
pure $ Right ()
newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
newFileRec senderId fileInfo createdAt = do
recipientIds <- newTVar S.empty
filePath <- newTVar Nothing
@@ -120,8 +124,8 @@ getFile st party fId = case party of
expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath))
expiredFilePath FileStore {files} sId old =
TM.lookup sId files
$>>= \FileRec {filePath, createdAt} ->
if systemSeconds createdAt < old
$>>= \FileRec {filePath, createdAt = RoundedSystemTime createdAt} ->
if createdAt + fileTimePrecision < old
then Just <$> readTVar filePath
else pure Nothing
+3 -3
View File
@@ -28,18 +28,18 @@ 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.Time.Clock.System (SystemTime)
import Simplex.FileTransfer.Protocol (FileInfo (..))
import Simplex.FileTransfer.Server.Store
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Util (bshow, whenM)
import System.Directory (doesFileExist, renameFile)
import System.IO
data FileStoreLogRecord
= AddFile SenderId FileInfo SystemTime
= AddFile SenderId FileInfo RoundedSystemTime
| PutFile SenderId FilePath
| AddRecipients SenderId (NonEmpty FileRecipient)
| DeleteFile SenderId
@@ -64,7 +64,7 @@ instance StrEncoding FileStoreLogRecord where
logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord = writeStoreLogRecord
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
logAddFile s = logFileStoreRecord s .:. AddFile
logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
+56 -47
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -166,7 +167,7 @@ import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (ProtocolClient (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -181,7 +182,7 @@ import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBod
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion, THandleParams (sessionId))
import Simplex.Messaging.Transport (SMPVersion)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Simplex.RemoteControl.Client
@@ -473,14 +474,14 @@ testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do
changed <- atomically $ do
setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do
(spChanged, changed) <- atomically $ do
(_, cfg) <- readTVar useNetworkConfig
if cfg == cfg'
then pure False
else
let cfgSlow = slowNetworkConfig cfg'
in True <$ (cfgSlow `seq` writeTVar useNetworkConfig (cfgSlow, cfg'))
let changed = cfg /= cfg'
!cfgSlow = slowNetworkConfig cfg'
when changed $ writeTVar useNetworkConfig (cfgSlow, cfg')
pure (socksProxy cfg /= socksProxy cfg', changed)
when spChanged $ getCurrentTime >>= atomically . writeTVar proxySessTs
when changed $ reconnectAllServers c
setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
@@ -778,7 +779,7 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
when enableNtfs $ do
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
case cMode of
SCMContact -> pure (connId, CRContactUri crData)
@@ -923,7 +924,7 @@ createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVers
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
when enableNtfs $ do
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
pure qInfo
-- | Approve confirmation (LET command) in Reader monad
@@ -1013,14 +1014,13 @@ subscribeConnections' c connIds = do
order _ = 4
sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId SomeConn -> AM' ()
sendNtfCreate ns rcvRs cs = do
-- TODO this needs to be batched end to end.
-- Currently, the only change is to ignore failed subscriptions.
let oks = M.keysSet $ M.filter (either temporaryAgentError $ const True) rcvRs
forM_ (M.restrictKeys cs oks) $ \case
SomeConn _ conn -> do
let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
ConnData {connId} = toConnData conn
atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
cs' = M.restrictKeys cs oks
(csCreate, csDelete) = M.partition (\(SomeConn _ conn) -> enableNtfs $ toConnData conn) cs'
sendNtfCmd NSCCreate csCreate
sendNtfCmd NSCSmpDelete csDelete
where
sendNtfCmd cmd cs' = forM_ (L.nonEmpty $ M.keys cs') $ \cids -> atomically $ writeTBQueue (ntfSubQ ns) (cmd, cids)
resumeDelivery :: Map ConnId SomeConn -> AM ()
resumeDelivery conns = do
conns' <- M.restrictKeys conns . S.fromList <$> withStore' c getConnectionsForDelivery
@@ -1259,7 +1259,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
withStore' c $ \db -> deleteConnRcvQueue db rq'
when (enableNtfs cData) $ do
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
let conn' = DuplexConnection cData (rq'' :| rqs') sqs
notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
_ -> internalErr "ICQDelete: cannot delete the only queue in connection"
@@ -1716,12 +1716,6 @@ connRcvQueues = \case
SndConnection _ _ -> []
NewConnection _ -> []
disableConn :: AgentClient -> ConnId -> AM' ()
disableConn c connId = do
atomically $ removeSubscription c connId
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
deleteConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
deleteConnections' = deleteConnections_ getConns False False
@@ -1748,7 +1742,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
(delRs, rcvQs) = M.mapEither rcvQueues cs
rqs = concat $ M.elems rcvQs
connIds' = M.keys rcvQs
lift . forM_ connIds' $ disableConn c
lift $ forM_ (L.nonEmpty connIds') unsubConnIds
-- ! delRs is not used to notify about the result in any of the calling functions,
-- ! it is only used to check results count in deleteConnections_;
-- ! if it was used to notify about the result, it might be necessary to differentiate
@@ -1762,6 +1756,12 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
rcvQueues (SomeConn _ conn) = case connRcvQueues conn of
[] -> Left $ Right ()
rqs -> Right rqs
unsubConnIds :: NonEmpty ConnId -> AM' ()
unsubConnIds connIds' = do
forM_ connIds' $ \connId ->
atomically $ removeSubscription c connId
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds')
notify = atomically . writeTBQueue (subQ c)
deleteConnQueues :: AgentClient -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
@@ -1902,7 +1902,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
cron <- asks $ ntfCron . config
agentNtfEnableCron c tknId tkn cron
when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
-- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
pure ntfTknStatus
| otherwise -> replaceToken tknId
@@ -1984,7 +1984,7 @@ deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
deleteNtfToken' c deviceToken =
withStore' c getSavedNtfToken >>= \case
Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "deleteNtfToken: different token"
when (deviceToken /= savedDeviceToken) $ logWarn "deleteNtfToken: different token"
deleteToken_ c tkn
deleteNtfSubs c NSCSmpDelete
_ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
@@ -2017,21 +2017,22 @@ toggleConnectionNtfs' c connId enable = do
| otherwise = do
withStore' c $ \db -> setConnectionNtfs db connId enable
ns <- asks ntfSupervisor
let cmd = if enable then NSCCreate else NSCDelete
atomically $ sendNtfSubCommand ns (connId, cmd)
let cmd = if enable then NSCCreate else NSCSmpDelete
atomically $ sendNtfSubCommand ns (cmd, [connId])
deleteToken_ :: AgentClient -> NtfToken -> AM ()
deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
deleteToken_ c@AgentClient {subQ} tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
ns <- asks ntfSupervisor
forM_ ntfTokenId $ \tknId -> do
let ntfTknAction = Just NTADelete
withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
agentNtfDeleteToken c tknId tkn `catchAgentError` \case
NTF _ AUTH -> pure ()
e -> throwE e
agentNtfDeleteToken c tknId tkn `catchAgentError` \e -> notify (ERR e) -- TODO cleanup task
withStore' c $ \db -> removeNtfToken db tkn
atomically $ nsRemoveNtfToken ns
where
notify :: forall e. AEntityI e => AEvent e -> AM ()
notify cmd = atomically $ writeTBQueue subQ ("", "", AEvt (sAEntity @e) cmd)
withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
@@ -2065,13 +2066,24 @@ deleteNtfSubs c deleteCmd = do
sendNtfConnCommands :: AgentClient -> NtfSupervisorCommand -> AM ()
sendNtfConnCommands c cmd = do
ns <- asks ntfSupervisor
connIds <- liftIO $ getSubscriptions c
forM_ connIds $ \connId -> do
withStore' c (`getConnData` connId) >>= \case
Just (ConnData {enableNtfs}, _) ->
when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
_ ->
atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ ERR $ INTERNAL "no connection data")
connIds <- liftIO $ S.toList <$> getSubscriptions c
rs <- lift $ withStoreBatch' c (\db -> map (getConnData db) connIds)
let (connIds', cErrs) = enabledNtfConns (zip connIds rs)
forM_ (L.nonEmpty connIds') $ \connIds'' ->
atomically $ writeTBQueue (ntfSubQ ns) (cmd, connIds'')
unless (null cErrs) $ atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS cErrs)
where
enabledNtfConns :: [(ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode)))] -> ([ConnId], [(ConnId, AgentErrorType)])
enabledNtfConns = foldr addEnabledConn ([], [])
where
addEnabledConn ::
(ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode))) ->
([ConnId], [(ConnId, AgentErrorType)]) ->
([ConnId], [(ConnId, AgentErrorType)])
addEnabledConn cData_ (cIds, errs) = case cData_ of
(_, Right (Just (ConnData {connId, enableNtfs}, _))) -> if enableNtfs then (connId : cIds, errs) else (cIds, errs)
(connId, Right Nothing) -> (cIds, (connId, INTERNAL "no connection data") : errs)
(connId, Left e) -> (cIds, (connId, e) : errs)
setNtfServers :: AgentClient -> [NtfServer] -> IO ()
setNtfServers c = atomically . writeTVar (ntfServers c)
@@ -2450,17 +2462,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
handleNotifyAck :: AM ACKd -> AM ACKd
handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack
SMP.END ->
atomically (TM.lookup tSess (smpClients c) $>>= (tryReadTMVar . sessionVar) >>= processEND)
atomically (ifM (activeClientSession c tSess sessId) (removeSubscription c connId $> True) (pure False))
>>= notifyEnd
where
processEND = \case
Just (Right clnt)
| sessId == sessionId (thParams $ connectedClient clnt) ->
removeSubscription c connId $> True
_ -> pure False
notifyEnd removed
| removed = notify END >> logServer "<--" c srv rId "END"
| otherwise = logServer "<--" c srv rId "END from disconnected client - ignored"
-- Possibly, we need to add some flag to connection that it was deleted
SMP.DELD -> atomically (removeSubscription c connId) >> notify DELD
SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e
r -> unexpected r
where
+85 -28
View File
@@ -56,8 +56,10 @@ module Simplex.Messaging.Agent.Client
secureQueue,
secureSndQueue,
enableQueueNotifications,
EnableQueueNtfReq (..),
enableQueuesNtfs,
disableQueueNotifications,
DisableQueueNtfReq,
disableQueuesNtfs,
sendAgentMessage,
getQueueInfo,
@@ -115,6 +117,7 @@ module Simplex.Messaging.Agent.Client
hasWorkToDo,
hasWorkToDo',
withWork,
withWorkItems,
agentOperations,
agentOperationBracket,
waitUntilActive,
@@ -185,7 +188,7 @@ import qualified Data.ByteString.Char8 as B
import Data.Either (isRight, partitionEithers)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (deleteFirstsBy, foldl', partition, (\\))
import Data.List (deleteFirstsBy, find, foldl', partition, (\\))
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
@@ -256,8 +259,8 @@ import Simplex.Messaging.Protocol
VersionSMPC,
XFTPServer,
XFTPServerWithAuth,
pattern NoEntity,
sameSrvAddr',
pattern NoEntity,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.QueueStore.QueueInfo
@@ -333,6 +336,7 @@ data AgentClient = AgentClient
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
clientId :: Int,
agentEnv :: Env,
proxySessTs :: TVar UTCTime,
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats,
@@ -461,6 +465,7 @@ newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
let cfg = config agentEnv
qSize = tbqSize cfg
proxySessTs <- newTVarIO =<< getCurrentTime
acThread <- newTVarIO Nothing
active <- newTVarIO True
subQ <- newTBQueueIO qSize
@@ -533,6 +538,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
smpSubWorkers,
clientId,
agentEnv,
proxySessTs,
smpServersStats,
xftpServersStats,
ntfServersStats,
@@ -657,7 +663,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v =
newProtocolClient c tSess smpClients connectClient v
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
where
@@ -667,7 +673,8 @@ smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
g <- asks random
env <- ask
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) $ smpClientDisconnected c tSess env v' prs
ts <- readTVarIO proxySessTs
smp <- ExceptT $ getProtocolClient g tSess cfg (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 ()
@@ -756,7 +763,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess ntfClients ts)
@@ -768,8 +775,9 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv,
connectClient v = do
cfg <- lift $ getClientConfig c ntfCfg
g <- asks random
ts <- readTVarIO proxySessTs
liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
getProtocolClient g tSess cfg Nothing $
getProtocolClient g tSess cfg Nothing ts $
clientDisconnected v
clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -779,7 +787,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv,
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess xftpClients ts)
@@ -791,8 +799,9 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv
connectClient v = do
cfg <- asks $ xftpCfg . config
xftpNetworkConfig <- getNetworkConfig c
ts <- readTVarIO proxySessTs
liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
X.getXFTPClient tSess cfg {xftpNetworkConfig} $
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts $
clientDisconnected v
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
@@ -1199,7 +1208,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
g <- asks random
liftIO $ do
let tSess = (userId, srv, Nothing)
getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
ts <- readTVarIO $ proxySessTs c
getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
Right smp -> do
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
@@ -1229,7 +1239,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
rcvPath <- getTempFilePath workDir
liftIO $ do
let tSess = (userId, srv, Nothing)
X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
ts <- readTVarIO $ proxySessTs c
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts (\_ -> pure ()) >>= \case
Right xftp -> withTestChunk filePath $ do
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1273,7 +1284,8 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
g <- asks random
liftIO $ do
let tSess = (userId, srv, Nothing)
getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
ts <- readTVarIO $ proxySessTs c
getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
Right ntf -> do
(nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
(dhKey, _) <- atomically $ C.generateKeyPair g
@@ -1410,7 +1422,7 @@ subscribeQueues c qs = do
checkQueue rq = do
prohibited <- liftIO $ hasGetLock c rq
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
subscribeQueues_ env session smp qs' = do
let (userId, srv, _) = transportSession' smp
atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
@@ -1441,31 +1453,33 @@ activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClien
Just (Right (SMPConnectedClient smp _)) -> sessId == sessionId (thParams smp)
_ -> False
type BatchResponses e r = NonEmpty (RcvQueue, Either e r)
type BatchResponses q e r = NonEmpty (q, Either e r)
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType 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 =
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
where
batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
batchQueues = do
mode <- getSessionMode c
pure . M.assocs $ foldl' (batch mode) M.empty qs
pure . M.assocs $ foldr (batch mode) M.empty qs
where
batch mode m q =
batch mode q m =
let tSess = mkSMPTSession (toRQ q) mode
in M.alter (Just . maybe [q] (q <|)) tSess m
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r)
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
sendClientBatch (tSess@(_, srv, _), qs') =
tryAgentError' (getSMPServerClient c tSess) >>= \case
Left e -> pure $ L.map ((,Left e) . toRQ) qs'
Left e -> pure $ L.map (,Left e) qs'
Right (SMPConnectedClient smp _) -> liftIO $ do
logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
L.map agentError <$> action smp qs'
where
agentError = second . first $ protocolClientError SMP $ clientServer smp
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
where
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1594,22 +1608,39 @@ enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtf
withSMPClient c rq "NKEY <nkey>" $ \smp ->
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_
data EnableQueueNtfReq = EnableQueueNtfReq
{ eqnrNtfSub :: NtfSubscription,
eqnrRq :: RcvQueue,
eqnrAuthKeyPair :: C.AAuthKeyPair,
eqnrRcvKeyPair :: C.KeyPairX25519
}
enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
where
fst3 (x, _, _) = x
enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
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')
queueCreds :: EnableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
queueCreds EnableQueueNtfReq {eqnrRq, eqnrAuthKeyPair, eqnrRcvKeyPair} =
let RcvQueue {rcvPrivateKey, rcvId} = eqnrRq
(ntfPublicKey, _) = eqnrAuthKeyPair
(rcvNtfPubDhKey, _) = eqnrRcvKeyPair
in (rcvPrivateKey, rcvId, ntfPublicKey, rcvNtfPubDhKey)
disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "NDEL" $ \smp ->
disableSMPQueueNotifications smp rcvPrivateKey rcvId
disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs
type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
where
disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
queueCreds :: DisableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId)
queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
@@ -1800,12 +1831,38 @@ withWork c doWork getWork action =
withStore' c getWork >>= \case
Right (Just r) -> action r
Right Nothing -> noWork
-- worker is stopped here (noWork) because the next iteration is likely to produce the same result
Left e@SEWorkItemError {} -> noWork >> notifyErr (CRITICAL False) e
Left e -> notifyErr INTERNAL e
where
noWork = liftIO $ noWorkToDo doWork
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
withWorkItems :: AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError [Either StoreError a])) -> (NonEmpty a -> AM ()) -> AM ()
withWorkItems c doWork getWork action = do
withStore' c getWork >>= \case
Right rs -> do
let (errs, items) = partitionEithers rs
case L.nonEmpty items of
Just items' -> action items'
Nothing -> do
let criticalErr = find workItemError errs
forM_ criticalErr $ \err -> do
notifyErr (CRITICAL False) err
when (all workItemError errs) noWork
unless (null errs) $
atomically $
writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS $ map (\e -> ("", INTERNAL $ show e)) errs)
Left e
| workItemError e -> noWork >> notifyErr (CRITICAL False) e
| otherwise -> notifyErr INTERNAL e
where
workItemError = \case
SEWorkItemError {} -> True
_ -> False
noWork = liftIO $ noWorkToDo doWork
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
noWorkToDo :: TMVar () -> IO ()
noWorkToDo = void . atomically . tryTakeTMVar
{-# INLINE noWorkToDo #-}
+5 -3
View File
@@ -150,6 +150,7 @@ data AgentConfig = AgentConfig
xftpMaxRecipientsPerRequest :: Int,
deleteErrorCount :: Int,
ntfCron :: Word16,
ntfBatchSize :: Int,
ntfSubCheckInterval :: NominalDiffTime,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
@@ -193,7 +194,7 @@ defaultAgentConfig =
rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
connIdBytes = 12,
tbqSize = 64,
tbqSize = 128,
smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
xftpCfg = defaultXFTPClientConfig,
@@ -219,6 +220,7 @@ defaultAgentConfig =
xftpMaxRecipientsPerRequest = 200,
deleteErrorCount = 10,
ntfCron = 20, -- minutes
ntfBatchSize = 200,
ntfSubCheckInterval = nominalDay,
-- CA certificate private key is not needed for initialization
-- ! we do not generate these
@@ -254,12 +256,12 @@ createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey k
data NtfSupervisor = NtfSupervisor
{ ntfTkn :: TVar (Maybe NtfToken),
ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
ntfWorkers :: TMap NtfServer Worker,
ntfSMPWorkers :: TMap SMPServer Worker
}
data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
deriving (Show)
newNtfSubSupervisor :: Natural -> IO NtfSupervisor
+247 -137
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@@ -22,22 +23,30 @@ import Control.Logger.Simple (logError, logInfo)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import Data.Foldable (foldr')
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Text (Text)
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Clock (diffUTCTime)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
import System.Random (randomR)
import UnliftIO
@@ -48,90 +57,126 @@ runNtfSupervisor :: AgentClient -> AM' ()
runNtfSupervisor c = do
ns <- asks ntfSupervisor
forever $ do
cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
handleErr connId . agentOperationBracket c AONtfNetwork waitUntilActive $
runExceptT (processNtfSub c cmd) >>= \case
Left e -> notifyErr connId e
cmd <- atomically . readTBQueue $ ntfSubQ ns
handleErr . agentOperationBracket c AONtfNetwork waitUntilActive $
runExceptT (processNtfCmd c cmd) >>= \case
Left e -> notifyErr e
Right _ -> return ()
where
handleErr :: ConnId -> AM' () -> AM' ()
handleErr connId = E.handle $ \(e :: E.SomeException) -> do
handleErr :: AM' () -> AM' ()
handleErr = E.handle $ \(e :: E.SomeException) -> do
logError $ "runNtfSupervisor error " <> tshow e
notifyErr connId e
notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
notifyErr e
notifyErr e = notifyInternalError' c $ "runNtfSupervisor error " <> show e
processNtfSub :: AgentClient -> (ConnId, NtfSupervisorCommand) -> AM ()
processNtfSub c (connId, cmd) = do
logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
partitionErrs :: (a -> ConnId) -> [a] -> [Either AgentErrorType b] -> ([(ConnId, AgentErrorType)], [b])
partitionErrs f xs = partitionEithers . zipWith (\x -> first (f x,)) xs
{-# INLINE partitionErrs #-}
ntfSubConnId :: NtfSubscription -> ConnId
ntfSubConnId NtfSubscription {connId} = connId
processNtfCmd :: AgentClient -> (NtfSupervisorCommand, NonEmpty ConnId) -> AM ()
processNtfCmd c (cmd, connIds) = do
logInfo $ "processNtfCmd - cmd = " <> tshow cmd
let connIds' = L.toList connIds
case cmd of
NSCCreate -> do
(a, RcvQueue {userId, server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
a <- liftIO $ getNtfSubscription db connId
q <- ExceptT $ getPrimaryRcvQueue db connId
pure (a, q)
logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
case a of
Nothing -> do
(cErrs, rqSubActions) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueueSub db) connIds')
notifyErrs c cErrs
logInfo $ "processNtfCmd, NSCCreate - length rqSubs = " <> tshow (length rqSubActions)
let (ns, rs, css, cns) = partitionQueueSubActions rqSubActions
createNewSubs ns
resetSubs rs
lift $ do
mapM_ (getNtfSMPWorker True c) (S.fromList css)
mapM_ (getNtfNTFWorker True c) (S.fromList cns)
where
getQueueSub ::
DB.Connection ->
ConnId ->
IO (Either AgentErrorType (RcvQueue, Maybe NtfSupervisorSub))
getQueueSub db connId = fmap (first storeError) $ runExceptT $ do
rq <- ExceptT $ getPrimaryRcvQueue db connId
sub <- liftIO $ getNtfSubscription db connId
pure (rq, sub)
createNewSubs :: [RcvQueue] -> AM ()
createNewSubs rqs = do
withTokenServer $ \ntfServer -> do
case clientNtfCreds of
Just ClientNtfCreds {notifierId} -> do
let newSub = newNtfSubscription userId connId smpServer (Just notifierId) ntfServer NASKey
withStore c $ \db -> createNtfSubscription db newSub $ NSANtf NSACreate
lift . void $ getNtfNTFWorker True c ntfServer
Nothing -> do
let newSub = newNtfSubscription userId connId smpServer Nothing ntfServer NASNew
withStore c $ \db -> createNtfSubscription db newSub $ NSASMP NSASmpKey
lift . void $ getNtfSMPWorker True c smpServer
(Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
case (clientNtfCreds, ntfQueueId) of
(Just ClientNtfCreds {notifierId}, Just ntfQueueId')
| sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
| otherwise -> rotate
(Nothing, Nothing) -> create
_ -> rotate
let newSubs = map (rqToNewSub ntfServer) rqs
(cErrs, _) <- lift $ partitionErrs ntfSubConnId newSubs <$> withStoreBatch c (\db -> map (storeNewSub db) newSubs)
notifyErrs c cErrs
kickSMPWorkers rqs
where
create :: AM ()
create = case action_ of
-- action was set to NULL after worker internal error
Nothing -> resetSubscription
Just (action, _)
-- subscription was marked for deletion / is being deleted
| isDeleteNtfSubAction action -> do
if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
then resetSubscription
else withTokenServer $ \ntfServer -> do
withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NSANtf NSACreate)
lift . void $ getNtfNTFWorker True c ntfServer
| otherwise -> case action of
NSANtf _ -> lift . void $ getNtfNTFWorker True c subNtfServer
NSASMP _ -> lift . void $ getNtfSMPWorker True c smpServer
rotate :: AM ()
rotate = do
withStore' c $ \db -> supervisorUpdateNtfSub db sub (NSANtf NSARotate)
lift . void $ getNtfNTFWorker True c subNtfServer
resetSubscription :: AM ()
resetSubscription =
withTokenServer $ \ntfServer -> do
let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NSASMP NSASmpKey)
lift . void $ getNtfSMPWorker True c smpServer
NSCDelete -> do
sub_ <- withStore' c $ \db -> do
supervisorUpdateNtfAction db connId (NSANtf NSADelete)
getNtfSubscription db connId
logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
case sub_ of
(Just (NtfSubscription {ntfServer}, _)) -> lift . void $ getNtfNTFWorker True c ntfServer
_ -> pure () -- err "NSCDelete - no subscription"
rqToNewSub :: NtfServer -> RcvQueue -> NtfSubscription
rqToNewSub ntfServer RcvQueue {userId, connId, server} = newNtfSubscription userId connId server Nothing ntfServer NASNew
storeNewSub :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType ())
storeNewSub db sub = first storeError <$> createNtfSubscription db sub (NSASMP NSASmpKey)
resetSubs :: [(RcvQueue, NtfSubscription)] -> AM ()
resetSubs rqSubs = do
withTokenServer $ \ntfServer -> do
let subsToReset = map (toResetSub ntfServer) rqSubs
(cErrs, _) <- lift $ partitionErrs ntfSubConnId subsToReset <$> withStoreBatch' c (\db -> map (storeResetSub db) subsToReset)
notifyErrs c cErrs
let rqs = map fst rqSubs
kickSMPWorkers rqs
where
toResetSub :: NtfServer -> (RcvQueue, NtfSubscription) -> NtfSubscription
toResetSub ntfServer (rq, sub) =
let RcvQueue {server = smpServer} = rq
in sub {smpServer, ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
storeResetSub :: DB.Connection -> NtfSubscription -> IO ()
storeResetSub db sub = supervisorUpdateNtfSub db sub (NSASMP NSASmpKey)
partitionQueueSubActions ::
[(RcvQueue, Maybe NtfSupervisorSub)] ->
( [RcvQueue], -- new subs
[(RcvQueue, NtfSubscription)], -- reset subs
[SMPServer], -- continue work (SMP)
[NtfServer] -- continue work (Ntf)
)
partitionQueueSubActions = foldr' decideSubWork ([], [], [], [])
where
-- sub = Nothing, needs to be created
decideSubWork (rq, Nothing) (ns, rs, css, cns) = (rq : ns, rs, css, cns)
decideSubWork (rq, Just (sub, subAction_)) (ns, rs, css, cns) =
case (clientNtfCreds rq, ntfQueueId sub) of
-- notifier ID created on SMP server (on ntf server subscription can be registered or not yet),
-- need to clarify action
(Just ClientNtfCreds {notifierId}, Just ntfQueueId')
| sameSrvAddr (qServer rq) subSMPServer && notifierId == ntfQueueId' -> contOrReset
| otherwise -> reset
(Nothing, Nothing) -> contOrReset
_ -> reset
where
NtfSubscription {ntfServer = subNtfServer, smpServer = subSMPServer} = sub
contOrReset = case subAction_ of
-- action was set to NULL after worker internal error
Nothing -> reset
Just (action, _)
-- subscription was marked for deletion / is being deleted
| isDeleteNtfSubAction action -> reset
-- continue work on subscription (e.g. supervisor was repeatedly tasked with creating a subscription)
| otherwise -> case action of
NSASMP _ -> (ns, rs, qServer rq : css, cns)
NSANtf _ -> (ns, rs, css, subNtfServer : cns)
reset = (ns, (rq, sub) : rs, css, cns)
NSCSmpDelete -> do
withStore' c (`getPrimaryRcvQueue` connId) >>= \case
Right rq@RcvQueue {server = smpServer} -> do
logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
withStore' c $ \db -> supervisorUpdateNtfAction db connId (NSASMP NSASmpDelete)
lift . void $ getNtfSMPWorker True c smpServer
_ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
NSCNtfWorker ntfServer -> lift . void $ getNtfNTFWorker True c ntfServer
NSCNtfSMPWorker smpServer -> lift . void $ getNtfSMPWorker True c smpServer
(cErrs, rqs) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueue db) connIds')
logInfo $ "processNtfCmd, NSCSmpDelete - length rqs = " <> tshow (length rqs)
(cErrs', _) <- lift $ partitionErrs qConnId rqs <$> withStoreBatch' c (\db -> map (updateAction db) rqs)
notifyErrs c (cErrs <> cErrs')
kickSMPWorkers rqs
where
getQueue :: DB.Connection -> ConnId -> IO (Either AgentErrorType RcvQueue)
getQueue db connId = first storeError <$> getPrimaryRcvQueue db connId
updateAction :: DB.Connection -> RcvQueue -> IO ()
updateAction db rq = supervisorUpdateNtfAction db (qConnId rq) (NSASMP NSASmpDelete)
NSCDeleteSub -> void $ lift $ withStoreBatch' c $ \db -> map (deleteNtfSubscription' db) connIds'
where
kickSMPWorkers :: [RcvQueue] -> AM ()
kickSMPWorkers rqs = do
let smpServers = S.fromList $ map qServer rqs
lift $ mapM_ (getNtfSMPWorker True c) smpServers
getNtfNTFWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
getNtfNTFWorker hasWork c server = do
@@ -193,24 +238,24 @@ runNtfWorker c srv Worker {doWork} =
NSAuth -> do
withStore' c $ \db ->
updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NSASMP NSASmpKey) ts
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
lift . void $ getNtfSMPWorker True c smpServer
status -> updateSubNextCheck ts status
atomically $ incNtfServerStat c userId ntfServer ntfChecked
Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
_ -> workerInternalError c connId "NSACheck - no active token"
-- NSADelete and NSARotate are deprecated, but their processing is kept for legacy db records
NSADelete ->
deleteNtfSub $ do
let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
lift . void $ getNtfSMPWorker True c smpServer
NSARotate ->
deleteNtfSub $ do
withStore' c $ \db -> deleteNtfSubscription db connId
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
atomically $ writeTBQueue (ntfSubQ ns) (NSCCreate, [connId]) -- TODO [batch ntf] loop
where
-- deleteNtfSub is only used in NSADelete and NSARotate, so also deprecated
deleteNtfSub continue = case ntfSubId of
Just nSubId ->
lift getNtfToken >>= \case
@@ -231,51 +276,102 @@ runNtfWorker c srv Worker {doWork} =
updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
runNtfSMPWorker c srv Worker {doWork} = do
env <- ask
forever $ do
waitForWork doWork
ExceptT . liftIO . agentOperationBracket c AONtfNetwork throwWhenInactive $
runReaderT (runExceptT runNtfSMPOperation) env
runNtfSMPWorker c srv Worker {doWork} = forever $ do
waitForWork doWork
ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfSMPOperation
where
runNtfSMPOperation =
withWork c doWork (`getNextNtfSubSMPAction` srv) $
\nextSub@(NtfSubscription {connId}, _, _) -> do
logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop -> do
liftIO $ waitWhileSuspended c
liftIO $ waitForUserNetwork c
processSub nextSub
`catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
ts <- liftIO getCurrentTime
unlessM (lift $ rescheduleAction doWork ts actionTs) $
case smpAction of
NSASmpKey ->
lift getNtfToken >>= \case
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
rq <- withStore c (`getPrimaryRcvQueue` connId)
C.AuthAlg a <- asks (rcvAuthAlg . config)
g <- asks random
(ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
(notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
withStore' c $ \db -> do
setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
_ -> workerInternalError c connId "NSASmpKey - no active token"
NSASmpDelete -> do
-- TODO should we remove it after successful removal from the server?
rq_ <- withStore' c $ \db -> do
setRcvQueueNtfCreds db connId Nothing
getPrimaryRcvQueue db connId
mapM_ (disableQueueNotifications c) rq_
withStore' c $ \db -> deleteNtfSubscription db connId
runNtfSMPOperation :: AM ()
runNtfSMPOperation = do
ntfBatchSize <- asks $ ntfBatchSize . config
withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
let (creates, deletes) = splitActions nextSubs
retrySubActions creates createNotifierKeys
retrySubActions deletes deleteNotifierKeys
splitActions :: NonEmpty (NtfSubSMPAction, NtfSubscription) -> ([NtfSubscription], [NtfSubscription])
splitActions = foldr addAction ([], [])
where
addAction action (creates, deletes) = case action of
(NSASmpKey, sub) -> (sub : creates, deletes)
(NSASmpDelete, sub) -> (creates, sub : deletes)
retrySubActions :: [NtfSubscription] -> ([NtfSubscription] -> AM' [NtfSubscription]) -> AM ()
retrySubActions subs action = do
v <- newTVarIO subs
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop -> do
liftIO $ waitWhileSuspended c
liftIO $ waitForUserNetwork c
subs' <- readTVarIO v
retrySubs <- lift $ action subs'
unless (null retrySubs) $ do
atomically $ writeTVar v retrySubs
retryNetworkLoop c loop
createNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
createNotifierKeys ntfSubs =
getNtfToken >>= \case
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
(errs1, subRqKeys) <- prepareQueueSmpKey ntfSubs
rs <- enableQueuesNtfs c subRqKeys
let (subRqKeys', errs2, successes) = splitResults rs
ntfSubs' = map eqnrNtfSub subRqKeys'
errs2' = map (first (qConnId . eqnrRq)) errs2
ts <- liftIO getCurrentTime
(errs3, srvs) <- partitionErrs (qConnId . eqnrRq . fst) successes <$> withStoreBatch' c (\db -> map (storeNtfSubCreds db ts) successes)
mapM_ (getNtfNTFWorker True c) $ S.fromList srvs
workerErrors c $ errs1 <> errs2' <> errs3
pure ntfSubs'
_ -> do
let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSASmpKey - no active token")) ntfSubs
workerErrors c errs
pure []
where
prepareQueueSmpKey :: [NtfSubscription] -> AM' ([(ConnId, AgentErrorType)], [EnableQueueNtfReq])
prepareQueueSmpKey subs = do
alg <- asks (rcvAuthAlg . config)
g <- asks random
partitionErrs ntfSubConnId subs <$> withStoreBatch c (\db -> map (getQueue db alg g) subs)
where
getQueue :: DB.Connection -> C.AuthAlg -> TVar ChaChaDRG -> NtfSubscription -> IO (Either AgentErrorType EnableQueueNtfReq)
getQueue db (C.AuthAlg a) g sub = fmap (first storeError) $ runExceptT $ do
rq <- ExceptT $ getPrimaryRcvQueue db (ntfSubConnId sub)
authKeyPair <- atomically $ C.generateAuthKeyPair a g
rcvNtfKeyPair <- atomically $ C.generateKeyPair g
pure (EnableQueueNtfReq sub rq authKeyPair rcvNtfKeyPair)
storeNtfSubCreds :: DB.Connection -> UTCTime -> (EnableQueueNtfReq, (SMP.NotifierId, SMP.RcvNtfPublicDhKey)) -> IO NtfServer
storeNtfSubCreds db ts (EnableQueueNtfReq {eqnrNtfSub, eqnrAuthKeyPair = (ntfPublicKey, ntfPrivateKey), eqnrRcvKeyPair = (_, pk)}, (notifierId, srvPubDhKey)) = do
let NtfSubscription {ntfServer} = eqnrNtfSub
rcvNtfDhSecret = C.dh' srvPubDhKey pk
setRcvQueueNtfCreds db (ntfSubConnId eqnrNtfSub) $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
updateNtfSubscription db eqnrNtfSub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
pure ntfServer
deleteNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
deleteNotifierKeys ntfSubs = do
(errs1, subRqs) <- partitionErrs ntfSubConnId ntfSubs <$> withStoreBatch c (\db -> map (resetCredsGetQueue db) ntfSubs)
rs <- disableQueuesNtfs c subRqs
let (subRqs', errs2, successes) = splitResults rs
ntfSubs' = map fst subRqs'
errs2' = map (first (qConnId . snd)) errs2
disabledRqs = map (snd . fst) successes
(errs3, _) <- partitionErrs qConnId disabledRqs <$> withStoreBatch' c (\db -> map (deleteSub db) disabledRqs)
workerErrors c $ errs1 <> errs2' <> errs3
pure ntfSubs'
where
resetCredsGetQueue :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType DisableQueueNtfReq)
resetCredsGetQueue db sub@NtfSubscription {connId} = fmap (first storeError) $ runExceptT $ do
liftIO $ setRcvQueueNtfCreds db connId Nothing
rq <- ExceptT $ getPrimaryRcvQueue db connId
pure (sub, rq)
deleteSub :: DB.Connection -> RcvQueue -> IO ()
deleteSub db rq = deleteNtfSubscription db (qConnId rq)
-- (temporary errs, other errs, successes)
splitResults :: [(a, Either AgentErrorType r)] -> ([a], [(a, AgentErrorType)], [(a, r)])
splitResults = foldr' addRes ([], [], [])
where
addRes (a, r_) (as, errs, rs) = case r_ of
Right r -> (as, errs, (a, r) : rs)
Left e
| temporaryOrHostError e -> (a : as, errs, rs)
| otherwise -> (as, (a, e) : errs, rs)
rescheduleAction :: TMVar () -> UTCTime -> UTCTime -> AM' Bool
rescheduleAction doWork ts actionTs
@@ -290,16 +386,22 @@ rescheduleAction doWork ts actionTs
retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
retryOnError c name loop done e = do
logError $ name <> " error: " <> tshow e
case e of
BROKER _ NETWORK -> retryLoop
BROKER _ TIMEOUT -> retryLoop
_ -> done e
where
retryLoop = do
atomically $ endAgentOperation c AONtfNetwork
liftIO $ throwWhenInactive c
atomically $ beginAgentOperation c AONtfNetwork
loop
if temporaryOrHostError e
then retryNetworkLoop c loop
else done e
retryNetworkLoop :: AgentClient -> AM () -> AM ()
retryNetworkLoop c loop = do
atomically $ endAgentOperation c AONtfNetwork
liftIO $ throwWhenInactive c
atomically $ beginAgentOperation c AONtfNetwork
loop
workerErrors :: AgentClient -> [(ConnId, AgentErrorType)] -> AM' ()
workerErrors c connErrs =
unless (null connErrs) $ do
void $ withStoreBatch' c (\db -> map (setNullNtfSubscriptionAction db . fst) connErrs)
notifyErrs c connErrs
workerInternalError :: AgentClient -> ConnId -> String -> AM ()
workerInternalError c connId internalErrStr = do
@@ -311,6 +413,14 @@ notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
{-# INLINE notifyInternalError #-}
notifyInternalError' :: MonadIO m => AgentClient -> String -> m ()
notifyInternalError' AgentClient {subQ} internalErrStr = atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
{-# INLINE notifyInternalError' #-}
notifyErrs :: MonadIO m => AgentClient -> [(ConnId, AgentErrorType)] -> m ()
notifyErrs AgentClient {subQ} connErrs = unless (null connErrs) $ atomically $ writeTBQueue subQ ("", "", AEvt SAENone $ ERRS connErrs)
{-# INLINE notifyErrs #-}
getNtfToken :: AM' (Maybe NtfToken)
getNtfToken = do
tkn <- asks $ ntfTkn . ntfSupervisor
@@ -322,7 +432,7 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
nsRemoveNtfToken :: NtfSupervisor -> STM ()
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
sendNtfSubCommand ns cmd = do
tkn <- readTVar (ntfTkn ns)
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
+10 -4
View File
@@ -277,14 +277,14 @@ supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPA
e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
e2eEncConnInfoLength v = \case
-- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
_ -> 14848
PQSupportOn | v >= pqdrSMPAgentVersion -> 11106
_ -> 14832
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength v = \case
-- reduced by 2222 (the increase of message ratchet header size)
PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
_ -> 15856
PQSupportOn | v >= pqdrSMPAgentVersion -> 13618
_ -> 15840
-- | SMP agent event
type ATransmission = (ACorrId, AEntityId, AEvt)
@@ -344,6 +344,7 @@ data AEvent (e :: AEntity) where
INFO :: PQSupport -> ConnInfo -> AEvent AEConn
CON :: PQEncryption -> AEvent AEConn -- notification that connection is established
END :: AEvent AEConn
DELD :: AEvent AEConn
CONNECT :: AProtocolType -> TransportHost -> AEvent AENone
DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone
DOWN :: SMPServer -> [ConnId] -> AEvent AENone
@@ -365,6 +366,7 @@ data AEvent (e :: AEntity) where
OK :: AEvent AEConn
JOINED :: SndQueueSecured -> AEvent AEConn
ERR :: AgentErrorType -> AEvent AEConn
ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
SUSPENDED :: AEvent AENone
RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
RFDONE :: FilePath -> AEvent AERcvFile
@@ -413,6 +415,7 @@ data AEventTag (e :: AEntity) where
INFO_ :: AEventTag AEConn
CON_ :: AEventTag AEConn
END_ :: AEventTag AEConn
DELD_ :: AEventTag AEConn
CONNECT_ :: AEventTag AENone
DISCONNECT_ :: AEventTag AENone
DOWN_ :: AEventTag AENone
@@ -434,6 +437,7 @@ data AEventTag (e :: AEntity) where
OK_ :: AEventTag AEConn
JOINED_ :: AEventTag AEConn
ERR_ :: AEventTag AEConn
ERRS_ :: AEventTag AENone
SUSPENDED_ :: AEventTag AENone
-- XFTP commands and responses
RFDONE_ :: AEventTag AERcvFile
@@ -466,6 +470,7 @@ aEventTag = \case
INFO {} -> INFO_
CON _ -> CON_
END -> END_
DELD -> DELD_
CONNECT {} -> CONNECT_
DISCONNECT {} -> DISCONNECT_
DOWN {} -> DOWN_
@@ -487,6 +492,7 @@ aEventTag = \case
OK -> OK_
JOINED _ -> JOINED_
ERR _ -> ERR_
ERRS _ -> ERRS_
SUSPENDED -> SUSPENDED_
RFPROG {} -> RFPROG_
RFDONE {} -> RFDONE_
+51 -31
View File
@@ -151,6 +151,7 @@ module Simplex.Messaging.Agent.Store.SQLite
updateNtfToken,
removeNtfToken,
-- Notification subscription persistence
NtfSupervisorSub,
getNtfSubscription,
createNtfSubscription,
supervisorUpdateNtfSub,
@@ -158,9 +159,10 @@ module Simplex.Messaging.Agent.Store.SQLite
updateNtfSubscription,
setNullNtfSubscriptionAction,
deleteNtfSubscription,
deleteNtfSubscription',
getNextNtfSubNTFAction,
markNtfSubActionNtfFailed_, -- exported for tests
getNextNtfSubSMPAction,
getNextNtfSubSMPActions,
markNtfSubActionSMPFailed_, -- exported for tests
getActiveNtfToken,
getNtfRcvQueue,
@@ -1061,17 +1063,26 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
getWorkItem itemName getId getItem markFailed =
runExceptT $ handleErr "getId" getId >>= mapM tryGetItem
runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed)
getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a])
getWorkItems itemName getIds getItem markFailed =
runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
where
tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwE e
mark itemId = handleErr ("markFailed ID " <> bshow itemId) $ markFailed itemId
catchStoreErrors = catchAllErrors (SEInternal . bshow)
-- Errors caught by this function will suspend worker as if there is no more work,
handleErr :: ByteString -> IO a -> ExceptT StoreError IO a
handleErr opName action = ExceptT $ first mkError <$> E.try action
where
mkError :: E.SomeException -> StoreError
mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
catchStoreError = catchAllErrors (SEInternal . bshow)
-- Errors caught by this function will suspend worker as if there is no more work,
handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
where
mkError :: E.SomeException -> StoreError
mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
@@ -1475,7 +1486,9 @@ removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
|]
(provider, token, host, port)
getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe (NtfSubscription, Maybe (NtfSubAction, NtfActionTs)))
type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs))
getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub)
getNtfSubscription db connId =
maybeFirstRow ntfSubscription $
DB.query
@@ -1491,7 +1504,7 @@ getNtfSubscription db connId =
|]
(Only connId)
where
ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash ) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
let smpServer = SMPServer smpHost smpPort smpKeyHash
ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
action = case (ntfAction_, smpAction_, actionTs_) of
@@ -1521,16 +1534,19 @@ createNtfSubscription db ntfSubscription action = runExceptT $ do
(ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
supervisorUpdateNtfSub db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
ts <- getCurrentTime
DB.execute
db
[sql|
UPDATE ntf_subscriptions
SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
SET smp_host = ?, smp_port = ?, smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?,
ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
WHERE conn_id = ?
|]
((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId))
( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId)
:. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId)
)
where
(ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
@@ -1605,7 +1621,11 @@ deleteNtfSubscription db connId = do
WHERE conn_id = ?
|]
(Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId)
else DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
else deleteNtfSubscription' db connId
deleteNtfSubscription' :: DB.Connection -> ConnId -> IO ()
deleteNtfSubscription' db connId = do
DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
@@ -1651,14 +1671,14 @@ markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
markNtfSubActionNtfFailed_ db connId =
DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId)
getNextNtfSubSMPAction :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubSMPAction, NtfActionTs)))
getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
getWorkItem "ntf SMP" getNtfConnId getNtfSubAction (markNtfSubActionSMPFailed_ db)
getNextNtfSubSMPActions :: DB.Connection -> SMPServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubSMPAction, NtfSubscription)])
getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize =
getWorkItems "ntf SMP" getNtfConnIds getNtfSubAction (markNtfSubActionSMPFailed_ db)
where
getNtfConnId :: IO (Maybe ConnId)
getNtfConnId =
maybeFirstRow fromOnly $
DB.query
getNtfConnIds :: IO [ConnId]
getNtfConnIds =
map fromOnly
<$> DB.query
db
[sql|
SELECT conn_id
@@ -1666,10 +1686,10 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL
AND (smp_failed = 0 OR updated_by_supervisor = 1)
ORDER BY ntf_sub_action_ts ASC
LIMIT 1
LIMIT ?
|]
(smpHost, smpPort)
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubSMPAction, NtfActionTs))
(smpHost, smpPort, ntfBatchSize)
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubSMPAction, NtfSubscription))
getNtfSubAction connId = do
markUpdatedByWorker db connId
firstRow ntfSubAction err $
@@ -1677,7 +1697,7 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
db
[sql|
SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action
FROM ntf_subscriptions ns
JOIN connections c USING (conn_id)
JOIN ntf_servers s USING (ntf_host, ntf_port)
@@ -1686,10 +1706,10 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
(Only connId)
where
err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) =
let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
in (ntfSubscription, action, actionTs)
in (action, ntfSubscription)
markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO ()
markNtfSubActionSMPFailed_ db connId =
@@ -2004,7 +2024,7 @@ setConnDeleted db waitDelivery connId
DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO ()
setConnUserId db oldUserId connId newUserId =
setConnUserId db oldUserId connId newUserId =
DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId)
setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO ()
+39 -16
View File
@@ -80,10 +80,11 @@ module Simplex.Messaging.Client
defaultSMPClientConfig,
defaultNetworkConfig,
transportClientConfig,
clientSocksCredentials,
chooseTransportHost,
proxyUsername,
temporaryClientError,
smpProxyError,
textToHostMode,
ServerTransmissionBatch,
ServerTransmission (..),
ClientCommand,
@@ -116,16 +117,20 @@ import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Network.Socket (ServiceName)
import Network.Socks5 (SocksCredentials (..))
import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -136,7 +141,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 (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
@@ -236,6 +241,12 @@ data HostMode
HMPublic
deriving (Eq, Show)
textToHostMode :: Text -> Either String HostMode
textToHostMode = \case
"public" -> Right HMPublic
"onion" -> Right HMOnionViaSocks
s -> Left $ T.unpack $ "Invalid host_mode: " <> s
data SocksMode
= -- | always use SOCKS proxy when enabled
SMAlways
@@ -257,7 +268,7 @@ instance StrEncoding SocksMode where
-- | network configuration for the client
data NetworkConfig = NetworkConfig
{ -- | use SOCKS5 proxy
socksProxy :: Maybe SocksProxy,
socksProxy :: Maybe SocksProxyWithAuth,
-- | when to use SOCKS proxy
socksMode :: SocksMode,
-- | determines critera which host is chosen from the list
@@ -288,7 +299,7 @@ data NetworkConfig = NetworkConfig
}
deriving (Eq, Show)
data TransportSessionMode = TSMUser | TSMEntity
data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
deriving (Eq, Show)
-- SMP proxy mode for sending messages
@@ -338,7 +349,7 @@ defaultNetworkConfig =
socksMode = SMAlways,
hostMode = HMOnionViaSocks,
requiredHostMode = False,
sessionMode = TSMUser,
sessionMode = TSMSession,
smpProxyMode = SPMNever,
smpProxyFallback = SPFAllow,
tcpConnectTimeout = defaultTcpConnectTimeout,
@@ -355,11 +366,27 @@ transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
where
useSocksProxy SMAlways = socksProxy
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
useSocksProxy SMAlways = socksProxy'
useSocksProxy SMOnion = case host of
THOnionHost _ -> socksProxy
THOnionHost _ -> socksProxy'
_ -> Nothing
{-# INLINE transportClientConfig #-}
clientSocksCredentials :: ProtocolTypeI (ProtoType msg) => NetworkConfig -> UTCTime -> TransportSession msg -> Maybe SocksCredentials
clientSocksCredentials NetworkConfig {socksProxy, sessionMode} proxySessTs (userId, srv, entityId_) = case socksProxy of
Just (SocksProxyWithAuth auth _) -> case auth of
SocksAuthUsername {username, password} -> Just $ SocksCredentials username password
SocksAuthNull -> Nothing
SocksIsolateByAuth -> Just $ SocksCredentials sessionUsername ""
Nothing -> Nothing
where
sessionUsername =
B64.encode $ C.sha256Hash $
bshow userId <> case sessionMode of
TSMUser -> ""
TSMSession -> ":" <> bshow proxySessTs
TSMServer -> ":" <> bshow proxySessTs <> "@" <> strEncode srv
TSMEntity -> ":" <> bshow proxySessTs <> "@" <> strEncode srv <> maybe "" ("/" <>) entityId_
-- | protocol client configuration.
data ProtocolClientConfig v = ProtocolClientConfig
@@ -449,8 +476,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 -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> 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, serverVRange, agreeSecret} msgQ proxySessTs disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -489,9 +516,9 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
runClient (port', ATransport t) useHost c = do
cVar <- newEmptyTMVarIO
let tcConfig = (transportClientConfig networkConfig useHost) {alpn = clientALPN}
username = proxyUsername transportSession
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
tId <-
runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
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)
case c_ of
@@ -597,10 +624,6 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
unexpectedResponse :: Show r => r -> ProtocolClientError err
unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
proxyUsername :: TransportSession msg -> ByteString
proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
{-# INLINE proxyUsername #-}
-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient v err msg -> IO ()
closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action
+5 -2
View File
@@ -95,6 +95,7 @@ defaultSMPClientAgentConfig =
data SMPClientAgent = SMPClientAgent
{ agentCfg :: SMPClientAgentConfig,
active :: TVar Bool,
startedAt :: UTCTime,
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
agentQ :: TBQueue SMPClientAgentEvent,
randomDrg :: TVar ChaChaDRG,
@@ -111,6 +112,7 @@ type OwnServer = Bool
newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
active <- newTVarIO True
startedAt <- getCurrentTime
msgQ <- newTBQueueIO msgQSize
agentQ <- newTBQueueIO agentQSize
smpClients <- TM.emptyIO
@@ -123,6 +125,7 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
SMPClientAgent
{ agentCfg,
active,
startedAt,
msgQ,
agentQ,
randomDrg,
@@ -194,8 +197,8 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
-- | Run an SMP client for SMPClientVar
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg} srv v =
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
where
clientDisconnected :: SMPClient -> IO ()
clientDisconnected smp = do
+27
View File
@@ -152,6 +152,12 @@ module Simplex.Messaging.Crypto
unsafeSbKey,
randomSbKey,
-- * secret_box chains
SbChainKey,
SbKeyNonce,
sbcInit,
sbcHkdf,
-- * pseudo-random bytes
randomBytes,
@@ -198,6 +204,7 @@ import qualified Crypto.Cipher.Types as AES
import qualified Crypto.Cipher.XSalsa as XSalsa
import qualified Crypto.Error as CE
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
import qualified Crypto.KDF.HKDF as H
import qualified Crypto.MAC.Poly1305 as Poly1305
import qualified Crypto.PubKey.Curve25519 as X25519
import qualified Crypto.PubKey.Curve448 as X448
@@ -1334,6 +1341,26 @@ unsafeSbKey s = either error id $ sbKey s
randomSbKey :: TVar ChaChaDRG -> STM SbKey
randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar
newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
deriving (Eq, Show)
sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
where
prk = H.extract salt secret :: H.PRK SHA512
out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
(ck1, ck2) = B.splitAt 32 out
type SbKeyNonce = (SbKey, CbNonce)
sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
where
prk = H.extract B.empty ck :: H.PRK SHA512
out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
(ck', rest) = B.splitAt 32 out
(sk, nonce) = B.splitAt 32 rest
xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
xSalsa20 secret nonce msg = (rs, msg')
where
+16 -1
View File
@@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy
kcbEncryptTailTag,
sbDecryptTailTag,
kcbDecryptTailTag,
sbEncryptTailTagNoPad,
sbDecryptTailTagNoPad,
fastReplicate,
secretBox,
secretBoxTailTag,
@@ -49,7 +51,7 @@ import Data.Composition ((.:.))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Foreign (sizeOf)
import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, SbKeyNonce, pattern CbNonce, pattern SbKey)
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..))
import Simplex.Messaging.Encoding
@@ -142,6 +144,10 @@ sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString ->
sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen =
LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
sbEncryptTailTagNoPad :: SbKeyNonce -> LazyByteString -> Either CryptoError LazyByteString
sbEncryptTailTagNoPad (SbKey key, CbNonce nonce) msg =
LB.fromChunks <$> secretBoxTailTag sbEncryptChunk key nonce msg
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag.
sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
@@ -165,6 +171,15 @@ sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet =
where
(c, tag') = LB.splitAt paddedLen packet
sbDecryptTailTagNoPad :: SbKeyNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
sbDecryptTailTagNoPad (SbKey key, CbNonce nonce) paddedLen packet =
result <$> secretBox sbDecryptChunk key nonce c
where
result (tag :| cs) =
let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
in (valid, LB.fromChunks cs)
(c, tag') = LB.splitAt paddedLen packet
secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
where
@@ -443,6 +443,8 @@ data NtfSubStatus
NSInactive
| -- | END received
NSEnd
| -- | DELD received (connection was deleted)
NSDeleted
| -- | SMP AUTH error
NSAuth
| -- | SMP error other than AUTH
@@ -456,6 +458,7 @@ ntfShouldSubscribe = \case
NSActive -> True
NSInactive -> True
NSEnd -> False
NSDeleted -> False
NSAuth -> False
NSErr _ -> False
@@ -466,6 +469,7 @@ instance Encoding NtfSubStatus where
NSActive -> "ACTIVE"
NSInactive -> "INACTIVE"
NSEnd -> "END"
NSDeleted -> "DELETED"
NSAuth -> "AUTH"
NSErr err -> "ERR " <> err
smpP =
@@ -475,6 +479,7 @@ instance Encoding NtfSubStatus where
"ACTIVE" -> pure NSActive
"INACTIVE" -> pure NSInactive
"END" -> pure NSEnd
"DELETED" -> pure NSDeleted
"AUTH" -> pure NSAuth
"ERR" -> NSErr <$> (A.space *> A.takeByteString)
_ -> fail "bad NtfSubStatus"
@@ -226,6 +226,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
Right SMP.END ->
whenM (atomically $ activeClientSession' ca sessionId srv) $
updateSubStatus smpQueue NSEnd
Right SMP.DELD -> updateSubStatus smpQueue NSDeleted
Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
Right _ -> logError "SMP server unexpected response"
Left e -> logError $ "SMP client error: " <> tshow e
@@ -16,7 +16,7 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
@@ -85,13 +85,19 @@ ntfServerCLI cfgPath logPath =
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
<> "log_stats: off\n\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
\# Host is only used to print server address on start.\n\
\# You can specify multiple server ports.\n"
<> ("host: " <> T.pack host <> "\n")
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> "log_tls_errors: off\n"
<> "websockets: off\n\n\
<> "log_tls_errors: off\n\n\
\# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
\websockets: off\n\n\
\[SUBSCRIBER]\n\
\# Network configuration for notification server client.\n\
\# `host_mode` can be 'public' (default) or 'onion'.\n\
\# It defines prefferred hostname for destination servers with multiple hostnames.\n\
\# host_mode: public\n\
\# required_host_mode: off\n\n\
\# SOCKS proxy port for subscribing to SMP servers.\n\
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
\# socks_proxy: localhost:9050\n\n\
@@ -134,6 +140,8 @@ ntfServerCLI cfgPath logPath =
defaultNetworkConfig
{ socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini,
socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
smpPingInterval = 60_000_000 -- 1 minutes
}
},
+2 -2
View File
@@ -99,8 +99,8 @@ type NtfActionTs = UTCTime
data NtfSubNTFAction
= NSACreate
| NSACheck
| NSADelete
| NSARotate
| NSADelete -- deprecated
| NSARotate -- deprecated
deriving (Show)
instance Encoding NtfSubNTFAction where
+9 -1
View File
@@ -484,6 +484,7 @@ data BrokerMsg where
RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
PRES :: EncResponse -> BrokerMsg -- proxy to client
END :: BrokerMsg
DELD :: BrokerMsg
INFO :: QueueInfo -> BrokerMsg
OK :: BrokerMsg
ERR :: ErrorType -> BrokerMsg
@@ -705,6 +706,7 @@ data BrokerMsgTag
| RRES_
| PRES_
| END_
| DELD_
| INFO_
| OK_
| ERR_
@@ -778,6 +780,7 @@ instance Encoding BrokerMsgTag where
RRES_ -> "RRES"
PRES_ -> "PRES"
END_ -> "END"
DELD_ -> "DELD"
INFO_ -> "INFO"
OK_ -> "OK"
ERR_ -> "ERR"
@@ -794,6 +797,7 @@ instance ProtocolMsgTag BrokerMsgTag where
"RRES" -> Just RRES_
"PRES" -> Just PRES_
"END" -> Just END_
"DELD" -> Just DELD_
"INFO" -> Just INFO_
"OK" -> Just OK_
"ERR" -> Just ERR_
@@ -1274,7 +1278,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
command <- A.takeByteString
pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
type ProtoCommand msg = cmd | cmd -> msg
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
@@ -1423,6 +1427,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
END -> e END_
DELD
| v >= deletedEventSMPVersion -> e DELD_
| otherwise -> e END_
INFO info -> e (INFO_, ' ', info)
OK -> e OK_
ERR err -> e (ERR_, ' ', err)
@@ -1448,6 +1455,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
END_ -> pure END
DELD_ -> pure DELD
INFO_ -> INFO <$> _smpP
OK_ -> pure OK
ERR_ -> ERR <$> _smpP
+47 -41
View File
@@ -136,9 +136,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
expired <- restoreServerMessages
restoreServerStats expired
raceAny_
( serverThread s "server subscribedQ" subscribedQ subscribers pendingENDs subscriptions cancelSub
: serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers pendingNtfENDs ntfSubscriptions (\_ -> pure ())
: sendPendingENDsThread s
( serverThread s "server subscribedQ" True subscribedQ subscribers pendingENDs subscriptions cancelSub
: serverThread s "server deletedQ" False deletedQ subscribers pendingDELDs subscriptions cancelSub
: serverThread s "server ntfSubscribedQ" True ntfSubscribedQ Env.notifiers pendingNtfENDs ntfSubscriptions (\_ -> pure ())
: serverThread s "server ntfDeletedQ" False ntfDeletedQ Env.notifiers pendingNtfDELDs ntfSubscriptions (\_ -> pure ())
: sendPendingEvtsThread s
: receiveFromProxyAgent pa
: map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
)
@@ -163,13 +165,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
forall s.
Server ->
String ->
(Server -> TQueue (QueueId, ClientId, Subscribed)) ->
Subscribed ->
(Server -> TQueue (QueueId, ClientId)) ->
(Server -> TMap QueueId (TVar Client)) ->
(Server -> TVar (IM.IntMap (NonEmpty RecipientId))) ->
(Client -> TMap QueueId s) ->
(s -> IO ()) ->
M ()
serverThread s label subQ subs ends clientSubs unsub = do
serverThread s label subscribed subQ subs pendingEvts clientSubs unsub = do
labelMyThread label
cls <- asks clients
liftIO . forever $
@@ -177,8 +180,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
$>>= endPreviousSubscriptions
>>= mapM_ unsub
where
updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, ClientId, Bool) -> STM (Maybe (QueueId, Client))
updateSubscribers cls (qId, clntId, subscribed) =
updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, ClientId) -> STM (Maybe (QueueId, Client))
updateSubscribers cls (qId, clntId) =
-- Client lookup by ID is in the same STM transaction.
-- In case client disconnects during the transaction,
-- it will be re-evaluated, and the client won't be stored as subscribed.
@@ -201,37 +204,41 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
| otherwise = (\yes -> if yes then Just (qId, c') else Nothing) <$> readTVar (connected c')
endPreviousSubscriptions :: (QueueId, Client) -> IO (Maybe s)
endPreviousSubscriptions (qId, c) = do
atomically $ modifyTVar' (ends s) $ IM.alter (Just . maybe [qId] (qId <|)) (clientId c)
atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qId] (qId <|)) (clientId c)
atomically $ TM.lookupDelete qId (clientSubs c)
sendPendingENDsThread :: Server -> M ()
sendPendingENDsThread s = do
sendPendingEvtsThread :: Server -> M ()
sendPendingEvtsThread s = do
endInt <- asks $ pendingENDInterval . config
cls <- asks clients
forever $ do
threadDelay endInt
sendPending cls $ pendingENDs s
sendPending cls $ pendingNtfENDs s
sendPending cls END $ pendingENDs s
sendPending cls DELD $ pendingDELDs s
sendPending cls END $ pendingNtfENDs s
sendPending cls DELD $ pendingNtfDELDs s
where
sendPending cls ref = do
sendPending cls evt ref = do
ends <- atomically $ swapTVar ref IM.empty
unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qIds) ->
mapM_ (queueENDs qIds) . join . IM.lookup cId =<< readTVarIO cls
queueENDs qIds c@Client {connected, sndQ = q} =
mapM_ (queueEvts qIds evt) . join . IM.lookup cId =<< readTVarIO cls
queueEvts qIds evt c@Client {connected, sndQ = q} =
whenM (readTVarIO connected) $ do
sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True)
if sent
then updateEndStats
else -- if queue is full it can block
forkClient c ("sendPendingENDsThread.queueENDs") $
forkClient c ("sendPendingEvtsThread.queueEvts") $
atomically (writeTBQueue q ts) >> updateEndStats
where
ts = L.map (CorrId "",,END) qIds
updateEndStats = do
stats <- asks serverStats
let len = L.length qIds
liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs in the batch
ts = L.map (CorrId "",,evt) qIds
updateEndStats = case evt of
END -> do
stats <- asks serverStats
let len = L.length qIds
liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs in the batch
_ -> pure ()
receiveFromProxyAgent :: ProxyAgent -> M ()
receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} =
@@ -892,7 +899,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do
client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, deletedQ, ntfSubscribedQ, ntfDeletedQ, subscribers, notifiers} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
forever $
atomically (readTBQueue rcvQ)
@@ -985,11 +992,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
processCommand (qr_, (corrId, entId, cmd)) = case cmd of
Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
Cmd SSender command -> Just <$> case command of
SKEY sKey -> (corrId,entId,) <$> case qr_ of
Just qr@QueueRec {sndSecure}
| sndSecure -> secureQueue_ "SKEY" qr sKey
| otherwise -> pure $ ERR AUTH
Nothing -> pure $ ERR INTERNAL
SKEY sKey ->
withQueue $ \QueueRec {sndSecure, recipientId} ->
(corrId,entId,) <$> if sndSecure then secureQueue_ "SKEY" recipientId sKey else pure $ ERR AUTH
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
PING -> pure (corrId, NoEntity, PONG)
RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
@@ -1009,9 +1014,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
SUB -> withQueue (`subscribeQueue` entId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> (corrId,entId,) <$> case qr_ of
Just qr -> secureQueue_ "KEY" qr sKey
Nothing -> pure $ ERR INTERNAL
KEY sKey ->
withQueue $ \QueueRec {recipientId} ->
(corrId,entId,) <$> secureQueue_ "KEY" recipientId sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
@@ -1063,10 +1068,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
n <- asks $ queueIdBytes . config
liftM2 (,) (randomId n) (randomId n)
secureQueue_ :: T.Text -> QueueRec -> SndPublicAuthKey -> M BrokerMsg
secureQueue_ name qr@QueueRec {recipientId = rId} sKey = time name $ do
secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg
secureQueue_ name rId sKey = time name $ do
withLog $ \s -> logSecureQueue s rId sKey
updateQueueDate qr
st <- asks queueStore
stats <- asks serverStats
incStat $ qSecured stats
@@ -1086,20 +1090,22 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
liftIO (addQueueNotifier st entId ntfCreds) >>= \case
Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
Left e -> pure $ ERR e
Right _ -> do
Right nId_ -> do
withLog $ \s -> logAddNotifier s entId ntfCreds
incStat . ntfCreated =<< asks serverStats
forM_ nId_ $ \nId -> atomically $ writeTQueue ntfDeletedQ (nId, clientId)
pure $ NID notifierId rcvPublicDhKey
deleteQueueNotifier_ :: QueueStore -> M (Transmission BrokerMsg)
deleteQueueNotifier_ st = do
withLog (`logDeleteNotifier` entId)
liftIO (deleteQueueNotifier st entId) >>= \case
Right () -> do
Right (Just nId) -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue ntfSubscribedQ (entId, clientId, False)
atomically $ writeTQueue ntfDeletedQ (nId, clientId)
incStat . ntfDeleted =<< asks serverStats
pure ok
Right Nothing -> pure ok
Left e -> pure $ err e
suspendQueue_ :: QueueStore -> M (Transmission BrokerMsg)
@@ -1124,7 +1130,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
where
newSub :: M Sub
newSub = time "SUB newSub" . atomically $ do
writeTQueue subscribedQ (rId, clientId, True)
writeTQueue subscribedQ (rId, clientId)
sub <- newSubscription NoSub
TM.insert rId sub subscriptions
pure sub
@@ -1199,7 +1205,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
pure ok
where
newSub = do
writeTQueue ntfSubscribedQ (entId, clientId, True)
writeTQueue ntfSubscribedQ (entId, clientId)
TM.insert entId () ntfSubscriptions
acknowledgeMsg :: QueueRec -> MsgId -> M (Transmission BrokerMsg)
@@ -1480,9 +1486,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
liftIO (deleteQueue st entId $>>= \q -> delMsgQueue ms entId $> Right q) >>= \case
Right q -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue subscribedQ (entId, clientId, False)
atomically $ writeTQueue deletedQ (entId, clientId)
forM_ (notifierId <$> notifier q) $ \nId ->
atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
atomically $ writeTQueue ntfDeletedQ (nId, clientId)
updateDeletedStats q
pure ok
Left e -> pure $ err e
+11 -3
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Server.CLI where
@@ -16,6 +17,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue)
import Data.List ((\\))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
@@ -275,9 +277,15 @@ checkSavedFingerprint cfgPath x509cfg = do
iniTransports :: Ini -> [(String, ATransport)]
iniTransports ini =
let port = T.unpack $ strictIni "TRANSPORT" "port" ini
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
ws = strictIni "TRANSPORT" "websockets" ini
wsPorts
| ws == "off" = []
| ws == "on" = ["80"]
| otherwise = ports ws \\ smpPorts
in map (,transport @TLS) smpPorts <> map (,transport @WS) wsPorts
where
ports = map T.unpack . T.splitOn ","
printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
printServerConfig transports logFile = do
+11 -3
View File
@@ -136,12 +136,16 @@ data Env = Env
type Subscribed = Bool
data Server = Server
{ subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
{ subscribedQ :: TQueue (RecipientId, ClientId),
deletedQ :: TQueue (RecipientId, ClientId),
subscribers :: TMap RecipientId (TVar Client),
ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
ntfSubscribedQ :: TQueue (NotifierId, ClientId),
ntfDeletedQ :: TQueue (NotifierId, ClientId),
notifiers :: TMap NotifierId (TVar Client),
pendingENDs :: TVar (IntMap (NonEmpty RecipientId)),
pendingDELDs :: TVar (IntMap (NonEmpty RecipientId)),
pendingNtfENDs :: TVar (IntMap (NonEmpty NotifierId)),
pendingNtfDELDs :: TVar (IntMap (NonEmpty NotifierId)),
savingLock :: Lock
}
@@ -181,13 +185,17 @@ data Sub = Sub
newServer :: IO Server
newServer = do
subscribedQ <- newTQueueIO
deletedQ <- newTQueueIO
subscribers <- TM.emptyIO
ntfSubscribedQ <- newTQueueIO
ntfDeletedQ <- newTQueueIO
notifiers <- TM.emptyIO
pendingENDs <- newTVarIO IM.empty
pendingDELDs <- newTVarIO IM.empty
pendingNtfENDs <- newTVarIO IM.empty
pendingNtfDELDs <- newTVarIO IM.empty
savingLock <- atomically createLock
return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, pendingENDs, pendingNtfENDs, savingLock}
return Server {subscribedQ, deletedQ, subscribers, ntfSubscribedQ, ntfDeletedQ, notifiers, pendingENDs, pendingDELDs, pendingNtfENDs, pendingNtfDELDs, savingLock}
newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
newClient clientId qSize thVersion sessionId createdAt = do
+7 -10
View File
@@ -29,7 +29,7 @@ import qualified Data.Text.IO as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Agent.Protocol (connReqUriP')
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
@@ -168,10 +168,12 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
\# control_port_admin_password:\n\
\# control_port_user_password:\n\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
\# Host is only used to print server address on start.\n\
\# You can specify multiple server ports.\n"
<> ("host: " <> T.pack host <> "\n")
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> "log_tls_errors: off\n\
<> "log_tls_errors: off\n\n\
\# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
\websockets: off\n\
\# control_port: 5224\n\n\
\[PROXY]\n\
@@ -254,7 +256,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
ServerConfig
{ transports = iniTransports ini,
smpHandshakeTimeout = 120000000,
tbqSize = 64,
tbqSize = 128,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
@@ -307,7 +309,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
defaultNetworkConfig
{ socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
}
},
@@ -318,11 +320,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
information = serverPublicInfo ini
}
textToHostMode :: Text -> HostMode
textToHostMode = \case
"public" -> HMPublic
"onion" -> HMOnionViaSocks
s -> error . T.unpack $ "Invalid host_mode: " <> s
textToOwnServers :: Text -> [ByteString]
textToOwnServers = map encodeUtf8 . T.words
+11 -8
View File
@@ -74,23 +74,26 @@ secureQueue QueueStore {queues} rId sKey = toResult <$> do
let !q' = q {senderKey = Just sKey}
in writeTVar qVar q' $> Just q'
addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType QueueRec)
addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $
withQueue rId queues $ \qVar -> do
TM.lookupIO rId queues >>= \case
Just qVar -> atomically $ ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
q <- readTVar qVar
forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
let !q' = q {notifier = Just ntfCreds}
writeTVar qVar q'
TM.insert nId rId notifiers
pure q'
pure $ Right nId_
Nothing -> pure $ Left AUTH
deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType ())
deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType (Maybe NotifierId))
deleteQueueNotifier QueueStore {queues, notifiers} rId =
withQueue rId queues $ \qVar -> do
q <- readTVar qVar
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
writeTVar qVar $! q {notifier = Nothing}
forM (notifier q) $ \NtfCreds {notifierId} -> do
TM.delete notifierId notifiers
writeTVar qVar $! q {notifier = Nothing}
pure notifierId
suspendQueue :: QueueStore -> RecipientId -> IO (Either ErrorType ())
suspendQueue QueueStore {queues} rId =
+16 -2
View File
@@ -47,6 +47,7 @@ module Simplex.Messaging.Transport
authCmdsSMPVersion,
sendingProxySMPVersion,
sndAuthKeySMPVersion,
deletedEventSMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -71,6 +72,7 @@ module Simplex.Messaging.Transport
THandle (..),
THandleParams (..),
THandleAuth (..),
TSbChainKeys (..),
TransportError (..),
HandshakeError (..),
smpServerHandshake,
@@ -84,6 +86,7 @@ module Simplex.Messaging.Transport
where
import Control.Applicative (optional)
import Control.Concurrent.STM
import Control.Monad (forM, (<$!>))
import Control.Monad.Except
import Control.Monad.Trans.Except (throwE)
@@ -130,6 +133,9 @@ smpBlockSize = 16384
-- 5 - basic auth for SMP servers (11/12/2022)
-- 6 - allow creating queues without subscribing (9/10/2023)
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
-- 8 - SMP proxy for sender commands
-- 9 - faster handshake: SKEY command for sender to secure queue
-- 10 - DELD event to subscriber when queue is deleted via another connnection
data SMPVersion
@@ -160,14 +166,17 @@ sendingProxySMPVersion = VersionSMP 8
sndAuthKeySMPVersion :: VersionSMP
sndAuthKeySMPVersion = VersionSMP 9
deletedEventSMPVersion :: VersionSMP
deletedEventSMPVersion = VersionSMP 10
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 9
currentClientSMPRelayVersion = VersionSMP 10
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 9
currentServerSMPRelayVersion = VersionSMP 10
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
@@ -386,6 +395,11 @@ data THandleAuth (p :: TransportPeer) where
} ->
THandleAuth 'TServer
data TSbChainKeys = TSbChainKeys
{ sndKey :: TVar C.SbChainKey,
rcvKey :: TVar C.SbChainKey
}
-- | TLS-unique channel binding
type SessionId = ByteString
+58 -21
View File
@@ -13,9 +13,13 @@ module Simplex.Messaging.Transport.Client
defaultSMPPort,
defaultTcpConnectTimeout,
defaultTransportClientConfig,
defaultSocksProxyWithAuth,
defaultSocksProxy,
defaultSocksHost,
TransportClientConfig (..),
SocksProxy,
SocksProxy (..),
SocksProxyWithAuth (..),
SocksAuth (..),
TransportHost (..),
TransportHosts (..),
TransportHosts_ (..),
@@ -23,7 +27,7 @@ module Simplex.Messaging.Transport.Client
)
where
import Control.Applicative (optional)
import Control.Applicative (optional, (<|>))
import Control.Logger.Simple (logError)
import Control.Monad (when)
import Data.Aeson (FromJSON (..), ToJSON (..))
@@ -79,7 +83,7 @@ instance StrEncoding TransportHost where
strP =
A.choice
[ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> A.takeWhile1 (\c -> isHexDigit c || c == ':'),
maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> ipv6StrP,
THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
]
@@ -87,6 +91,9 @@ instance StrEncoding TransportHost where
ipNum = validIP <$?> (A.decimal <* A.char '.')
validIP :: Int -> Either String Word8
validIP n = if 0 <= n && n <= 255 then Right $ fromIntegral n else Left "invalid IP address"
ipv6StrP =
A.char '[' *> A.takeWhile1 (/= ']') <* A.char ']'
<|> A.takeWhile1 (\c -> isHexDigit c || c == ':')
notOnion s = if ".onion" `B.isSuffixOf` s then Left "invalid onion host" else Right s
instance ToJSON TransportHost where
@@ -134,16 +141,16 @@ clientTransportConfig TransportClientConfig {logTLSErrors} =
TransportConfig {logTLSErrors, transportTimeout = Nothing}
-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} socksCreds host port keyHash client = do
serverCert <- newEmptyTMVarIO
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
connectTCP = case socksProxy of
Just proxy -> connectSocksClient proxy proxyUsername (hostAddr host)
Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
_ -> connectTCPClient hostName
c <- do
sock <- connectTCP port
@@ -191,40 +198,70 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
defaultSMPPort :: PortNumber
defaultSMPPort = 5223
connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket
connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do
connectSocksClient :: SocksProxy -> Maybe SocksCredentials -> SocksHostAddress -> ServiceName -> IO Socket
connectSocksClient (SocksProxy addr) socksCreds hostAddr _port = do
let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
fst <$> case proxyUsername of
Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "")
fst <$> case socksCreds of
Just creds -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) creds
_ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
defaultSocksHost :: HostAddress
defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
defaultSocksHost :: (Word8, Word8, Word8, Word8)
defaultSocksHost = (127, 0, 0, 1)
defaultSocksProxyWithAuth :: SocksProxyWithAuth
defaultSocksProxyWithAuth = SocksProxyWithAuth SocksIsolateByAuth defaultSocksProxy
defaultSocksProxy :: SocksProxy
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress defaultSocksHost
newtype SocksProxy = SocksProxy SockAddr
deriving (Eq)
data SocksProxyWithAuth = SocksProxyWithAuth SocksAuth SocksProxy
deriving (Eq, Show)
data SocksAuth
= SocksAuthUsername {username :: ByteString, password :: ByteString}
| SocksAuthNull
| SocksIsolateByAuth -- this is default
deriving (Eq, Show)
instance Show SocksProxy where show (SocksProxy addr) = show addr
instance StrEncoding SocksProxy where
strEncode = B.pack . show
strP = do
host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
host <- fromMaybe (THIPv4 defaultSocksHost) <$> optional strP
port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
pure . SocksProxy $ SockAddrInet port host
SocksProxy <$> socksAddr port host
where
ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
ipNum = A.decimal <* A.char '.'
socksAddr port = \case
THIPv4 addr -> pure $ SockAddrInet port $ tupleToHostAddress addr
THIPv6 addr -> pure $ SockAddrInet6 port 0 addr 0
_ -> fail "SOCKS5 host should be IPv4 or IPv6 address"
instance ToJSON SocksProxy where
instance StrEncoding SocksProxyWithAuth where
strEncode (SocksProxyWithAuth auth proxy) = strEncode auth <> strEncode proxy
strP = SocksProxyWithAuth <$> strP <*> strP
instance ToJSON SocksProxyWithAuth where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON SocksProxy where
parseJSON = strParseJSON "SocksProxy"
instance FromJSON SocksProxyWithAuth where
parseJSON = strParseJSON "SocksProxyWithAuth"
instance StrEncoding SocksAuth where
strEncode = \case
SocksAuthUsername {username, password} -> username <> ":" <> password <> "@"
SocksAuthNull -> "@"
SocksIsolateByAuth -> ""
strP = usernameP <|> (SocksAuthNull <$ A.char '@') <|> pure SocksIsolateByAuth
where
usernameP = do
username <- A.takeTill (== ':') <* A.char ':'
password <- A.takeTill (== '@') <* A.char '@'
pure SocksAuthUsername {username, password}
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =
@@ -11,7 +11,6 @@ import Control.Concurrent.Async
import Control.Exception (IOException, try)
import qualified Control.Exception as E
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.X509 as X
@@ -20,6 +19,7 @@ import Network.HPACK (BufferSize)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
import qualified Network.HTTP2.Client as H
import Network.Socket (HostName, ServiceName)
import Network.Socks5 (SocksCredentials)
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
@@ -91,10 +91,10 @@ data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOExcepti
getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getHTTP2Client host port = getVerifiedHTTP2Client Nothing (THDomainName host) port Nothing
getVerifiedHTTP2Client :: Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2Client proxyUsername host port keyHash caStore config disconnected = getVerifiedHTTP2ClientWith config host port disconnected setup
getVerifiedHTTP2Client :: Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2Client socksCreds host port keyHash caStore config disconnected = getVerifiedHTTP2ClientWith config host port disconnected setup
where
setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) proxyUsername host port keyHash
setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) socksCreds host port keyHash
attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
@@ -178,11 +178,11 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash = runHTTP2ClientWith bufferSize host setup
runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
runHTTP2Client tlsParams caStore tcConfig bufferSize socksCreds host port keyHash = runHTTP2ClientWith bufferSize host setup
where
setup :: (TLS -> IO a) -> IO a
setup = runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash
setup = runTLSTransportClient tlsParams caStore tcConfig socksCreds host port keyHash
runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a
runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls
+25 -19
View File
@@ -23,6 +23,9 @@ module Simplex.RemoteControl.Client
rcEncryptBody,
rcDecryptBody,
xrcpBlockSize,
-- for tests only
sendRCPacket,
receiveRCPacket,
) where
import Control.Applicative ((<|>))
@@ -33,6 +36,7 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.Bitraversable (bimapM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
@@ -43,6 +47,7 @@ import qualified Data.List.NonEmpty as L
import Data.Maybe (isNothing)
import qualified Data.Text as T
import Data.Time.Clock.System (getSystemTime)
import Data.Tuple (swap)
import Data.Word (Word16)
import qualified Data.X509 as X509
import Data.X509.Validation (Fingerprint (..), getFingerprint)
@@ -57,7 +62,7 @@ import Simplex.Messaging.Crypto.SNTRUP761
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (TLS (..), cGet, cPut)
import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), cGet, cPut)
import Simplex.Messaging.Transport.Buffer (peekBuffered)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -214,15 +219,16 @@ prepareHostSession
hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
unless (ca == tlsHostFingerprint) $ throwE RCEIdentity
(kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
let KEMHybridSecret hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
unless (isCompatible v supportedRCPVRange) $ throwE RCEVersion
let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
(sndKey, rcvKey) <- bimapM newTVarIO newTVarIO $ C.sbcInit "" hybridKey
let keys = HostSessKeys {chainKeys = TSbChainKeys {sndKey, rcvKey}, idPrivKey, sessPrivKey}
knownHost' <- updateKnownHost ca dhPubKey
let ctrlHello = RCCtrlHello {}
-- TODO send error response if something fails
nonce' <- liftIO . atomically $ C.randomCbNonce drg
encBody' <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt hybridKey nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'}
(sk, nonce') <- atomically $ stateTVar sndKey C.sbcHkdf
encBody' <- liftEitherWith (const RCEBlockSize) $ C.sbEncrypt sk nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, encBody = encBody'}
pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'})
where
updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
@@ -349,13 +355,16 @@ prepareCtrlSession
RCInvitation {skey, dh = dhPubKey}
sharedKey
kemPrivKey = \case
RCCtrlEncHello {kem = kemCiphertext, nonce, encBody} -> do
RCCtrlEncHello {kem = kemCiphertext, encBody} -> do
kemSharedKey <- liftIO $ sntrup761Dec kemCiphertext kemPrivKey
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt hybridKey nonce encBody
let KEMHybridSecret hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
-- keys are swapped in controller
(sndKey, rcvKey) <- swap <$> bimapM newTVarIO newTVarIO (C.sbcInit "" hybridKey)
(sk, nonce) <- atomically $ stateTVar rcvKey C.sbcHkdf
helloBody <- liftEitherWith (const RCEDecrypt) $ C.sbDecrypt sk nonce encBody
logDebug "Decrypted ctrl HELLO"
RCCtrlHello {} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
pure CtrlSessKeys {chainKeys = TSbChainKeys {sndKey, rcvKey}, idPubKey, sessPubKey = skey}
RCCtrlEncError {nonce, encMessage} -> do
message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage
throwE $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
@@ -426,17 +435,14 @@ cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do
-- * Session encryption
rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString)
rcEncryptBody drg hybridKey s = do
nonce <- atomically $ C.randomCbNonce drg
let len = LB.length s
ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8)
pure (nonce, ct)
rcEncryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcEncryptBody keyNonce s = do
liftEitherWith (const RCEEncrypt) $ LC.sbEncryptTailTagNoPad keyNonce s
rcDecryptBody :: KEMHybridSecret -> C.CbNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcDecryptBody hybridKey nonce ct = do
rcDecryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcDecryptBody keyNonce ct = do
let len = LB.length ct - 16
when (len < 0) $ throwE RCEDecrypt
(ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct
(ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.sbDecryptTailTagNoPad keyNonce len ct
unless ok $ throwE RCEDecrypt
pure s
+7 -8
View File
@@ -20,12 +20,11 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.SNTRUP761
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport (TLS)
import Simplex.Messaging.Transport (TLS, TSbChainKeys)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8)
import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
@@ -180,7 +179,7 @@ data RCHostSession = RCHostSession
}
data HostSessKeys = HostSessKeys
{ hybridKey :: KEMHybridSecret,
{ chainKeys :: TSbChainKeys,
idPrivKey :: C.PrivateKeyEd25519,
sessPrivKey :: C.PrivateKeyEd25519
}
@@ -193,7 +192,7 @@ data RCCtrlSession = RCCtrlSession
}
data CtrlSessKeys = CtrlSessKeys
{ hybridKey :: KEMHybridSecret,
{ chainKeys :: TSbChainKeys,
idPubKey :: C.PublicKeyEd25519,
sessPubKey :: C.PublicKeyEd25519
}
@@ -213,19 +212,19 @@ instance Encoding RCHostEncHello where
pure RCHostEncHello {dhPubKey, nonce, encBody}
data RCCtrlEncHello
= RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString}
= RCCtrlEncHello {kem :: KEMCiphertext, encBody :: ByteString}
| RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString}
deriving (Show)
instance Encoding RCCtrlEncHello where
smpEncode = \case
RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody)
RCCtrlEncHello {kem, encBody} -> "HELLO " <> smpEncode (kem, Tail encBody)
RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage)
smpP =
A.takeTill (== ' ') >>= \case
"HELLO" -> do
(kem, nonce, Tail encBody) <- _smpP
pure RCCtrlEncHello {kem, nonce, encBody}
(kem, Tail encBody) <- _smpP
pure RCCtrlEncHello {kem, encBody}
"ERROR" -> do
(nonce, Tail encMessage) <- _smpP
pure RCCtrlEncError {nonce, encMessage}
+2 -2
View File
@@ -85,7 +85,7 @@ import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), 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
@@ -3014,7 +3014,7 @@ testDeliveryReceiptsConcurrent t =
testTwoUsers :: HasCallStack => IO ()
testTwoUsers = withAgentClients2 $ \a b -> do
let nc = netCfg initAgentServers
sessionMode nc `shouldBe` TSMUser
sessionMode nc `shouldBe` TSMSession
runRight_ $ do
(aId1, bId1) <- makeConnectionForUsers a 1 b 1
exchangeGreetings a bId1 b aId1
+1 -1
View File
@@ -166,7 +166,7 @@ testNtfMatrix t runTest = do
it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
-- servers can be upgraded in any order
it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
+137
View File
@@ -0,0 +1,137 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module CoreTests.SOCKSSettings where
import Network.Socket (SockAddr (..), tupleToHostAddress)
import Simplex.Messaging.Client
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ErrorType)
import Simplex.Messaging.Transport.Client
import Test.Hspec
socksSettingsTests :: Spec
socksSettingsTests = do
describe "hostMode and requiredHostMode settings" testHostMode
describe "socksMode setting, independent of hostMode setting" testSocksMode
describe "socks proxy address encoding" testSocksProxyEncoding
testPublicHost :: TransportHost
testPublicHost = "smp.example.com"
testOnionHost :: TransportHost
testOnionHost = "abcdefghijklmnopqrstuvwxyz0123456789abcdefghijklmnopqrst.onion"
testHostMode :: Spec
testHostMode = do
describe "requiredHostMode = False (default)" $ do
it "without socks proxy, should choose onion host only with HMOnion" $ do
chooseTransportHost @ErrorType defaultNetworkConfig [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
chooseHost HMOnionViaSocks Nothing [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
chooseHost HMOnion Nothing [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMPublic Nothing [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
it "with socks proxy, should choose onion host with HMOnionViaSocks (default) and HMOnion" $ do
chooseTransportHost @ErrorType defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMOnionViaSocks (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMOnion (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMPublic (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
it "should choose any available host, if preferred not available" $ do
chooseHost HMOnionViaSocks Nothing [testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMOnion Nothing [testPublicHost] `shouldBe` Right testPublicHost
chooseHost HMPublic Nothing [testOnionHost] `shouldBe` Right testOnionHost
chooseHost HMOnionViaSocks (Just defaultSocksProxyWithAuth) [testPublicHost] `shouldBe` Right testPublicHost
chooseHost HMOnion (Just defaultSocksProxyWithAuth) [testPublicHost] `shouldBe` Right testPublicHost
chooseHost HMPublic (Just defaultSocksProxyWithAuth) [testOnionHost] `shouldBe` Right testOnionHost
describe "requiredHostMode = True" $ do
it "should fail, if preferred host not available" $ do
testOnionHost `incompatible` (HMOnionViaSocks, Nothing)
testPublicHost `incompatible` (HMOnion, Nothing)
testOnionHost `incompatible` (HMPublic, Nothing)
testPublicHost `incompatible` (HMOnionViaSocks, Just defaultSocksProxyWithAuth)
testPublicHost `incompatible` (HMOnion, Just defaultSocksProxyWithAuth)
testOnionHost `incompatible` (HMPublic, Just defaultSocksProxyWithAuth)
it "should choose preferred host, if available" $ do
testPublicHost `compatible` (HMOnionViaSocks, Nothing)
testOnionHost `compatible` (HMOnion, Nothing)
testPublicHost `compatible` (HMPublic, Nothing)
testOnionHost `compatible` (HMOnionViaSocks, Just defaultSocksProxyWithAuth)
testOnionHost `compatible` (HMOnion, Just defaultSocksProxyWithAuth)
testPublicHost `compatible` (HMPublic, Just defaultSocksProxyWithAuth)
where
chooseHost = chooseHostCfg defaultNetworkConfig
host `incompatible` (hostMode, socksProxy) =
chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host] `shouldBe` Left PCEIncompatibleHost
host `compatible` (hostMode, socksProxy) = do
chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host] `shouldBe` Right host
chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host, testPublicHost, testOnionHost] `shouldBe` Right host
chooseHostCfg cfg hostMode socksProxy =
chooseTransportHost @ErrorType cfg {hostMode, socksProxy}
testSocksMode :: Spec
testSocksMode = do
it "should not use SOCKS proxy if not specified" $ do
transportSocksCfg defaultNetworkConfig testPublicHost `shouldBe` Nothing
transportSocksCfg defaultNetworkConfig testOnionHost `shouldBe` Nothing
transportSocks Nothing SMAlways testPublicHost `shouldBe` Nothing
transportSocks Nothing SMAlways testOnionHost `shouldBe` Nothing
transportSocks Nothing SMOnion testPublicHost `shouldBe` Nothing
transportSocks Nothing SMOnion testOnionHost `shouldBe` Nothing
it "should always use SOCKS proxy if specified and (socksMode = SMAlways or (socksMode = SMOnion and onion host))" $ do
transportSocksCfg defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} testPublicHost `shouldBe` Just defaultSocksProxy
transportSocksCfg defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} testOnionHost `shouldBe` Just defaultSocksProxy
transportSocks (Just defaultSocksProxyWithAuth) SMAlways testPublicHost `shouldBe` Just defaultSocksProxy
transportSocks (Just defaultSocksProxyWithAuth) SMAlways testOnionHost `shouldBe` Just defaultSocksProxy
transportSocks (Just defaultSocksProxyWithAuth) SMOnion testPublicHost `shouldBe` Nothing
transportSocks (Just defaultSocksProxyWithAuth) SMOnion testOnionHost `shouldBe` Just defaultSocksProxy
where
transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
transportSocksCfg cfg host =
let TransportClientConfig {socksProxy} = transportClientConfig cfg host
in socksProxy
testSocksProxyEncoding :: Spec
testSocksProxyEncoding = do
it "should decode SOCKS proxy with isolate-by-auth mode" $ do
let authIsolate proxy = Right $ SocksProxyWithAuth SocksIsolateByAuth proxy
strDecode "" `shouldBe` authIsolate defaultSocksProxy
strDecode ":9050" `shouldBe` authIsolate defaultSocksProxy
strDecode ":8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 8080 $ tupleToHostAddress defaultSocksHost)
strDecode "127.0.0.1" `shouldBe` authIsolate defaultSocksProxy
strDecode "1.1.1.1" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress (1, 1, 1, 1))
strDecode "::1" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)
strDecode "[fd12:3456:789a:1::1]" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0xfd123456, 0x789a0001, 0, 1) 0)
strDecode "127.0.0.1:9050" `shouldBe` authIsolate defaultSocksProxy
strDecode "127.0.0.1:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 8080 $ tupleToHostAddress defaultSocksHost)
strDecode "[::1]:9050" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)
strDecode "[::1]:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 8080 0 (0, 0, 0, 1) 0)
strDecode "[fd12:3456:789a:1::1]:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
strEncode (SocksProxyWithAuth SocksIsolateByAuth defaultSocksProxy) `shouldBe` "127.0.0.1:9050"
strEncode (SocksProxyWithAuth SocksIsolateByAuth (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "[::1]:9050"
strEncode (SocksProxyWithAuth SocksIsolateByAuth (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "[fd12:3456:789a:1::1]:8080"
it "should decode SOCKS proxy without credentials" $ do
let authNull proxy = Right $ SocksProxyWithAuth SocksAuthNull proxy
strDecode "@" `shouldBe` authNull defaultSocksProxy
strDecode "@:9050" `shouldBe` authNull defaultSocksProxy
strDecode "@127.0.0.1" `shouldBe` authNull defaultSocksProxy
strDecode "@1.1.1.1" `shouldBe` authNull (SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress (1, 1, 1, 1))
strDecode "@127.0.0.1:9050" `shouldBe` authNull defaultSocksProxy
strDecode "@[fd12:3456:789a:1::1]:8080" `shouldBe` authNull (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
strEncode (SocksProxyWithAuth SocksAuthNull defaultSocksProxy) `shouldBe` "@127.0.0.1:9050"
strEncode (SocksProxyWithAuth SocksAuthNull (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "@[::1]:9050"
strEncode (SocksProxyWithAuth SocksAuthNull (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "@[fd12:3456:789a:1::1]:8080"
it "should decode SOCKS proxy with credentials" $ do
let auth = SocksAuthUsername {username = "user", password = "pass"}
authUser proxy = Right $ SocksProxyWithAuth auth proxy
strDecode "user:pass@" `shouldBe` authUser defaultSocksProxy
strDecode "user:pass@:9050" `shouldBe` authUser defaultSocksProxy
strDecode "user:pass@127.0.0.1" `shouldBe` authUser defaultSocksProxy
strDecode "user:pass@127.0.0.1:9050" `shouldBe` authUser defaultSocksProxy
strDecode "user:pass@fd12:3456:789a:1::1" `shouldBe` authUser (SocksProxy $ SockAddrInet6 9050 0 (0xfd123456, 0x789a0001, 0, 1) 0)
strDecode "user:pass@[fd12:3456:789a:1::1]:8080" `shouldBe` authUser (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
strEncode (SocksProxyWithAuth auth defaultSocksProxy) `shouldBe` "user:pass@127.0.0.1:9050"
strEncode (SocksProxyWithAuth auth (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "user:pass@[::1]:9050"
strEncode (SocksProxyWithAuth auth (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "user:pass@[fd12:3456:789a:1::1]:8080"
+23 -2
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -8,9 +9,11 @@ import AgentTests.FunctionalAPITests (runRight)
import Control.Logger.Simple
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.ByteString.Lazy.Char8 as LB
import Data.List.NonEmpty (NonEmpty (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (TSbChainKeys (..))
import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action))
import qualified Simplex.RemoteControl.Client as RC
import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress)
@@ -74,7 +77,16 @@ testNewPairing = do
logNote "c 3"
Right (sessId, _tls, r') <- atomically $ takeTMVar r
logNote "c 4"
Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r'
Right (rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r'
let RCHostSession {tls, sessionKeys = HostSessKeys {chainKeys}} = rcHostSession
TSbChainKeys {rcvKey, sndKey} = chainKeys
sndKeyNonce <- atomically $ stateTVar sndKey C.sbcHkdf
encCmd <- RC.rcEncryptBody sndKeyNonce "command message"
RC.sendRCPacket tls $ LB.toStrict encCmd
encResp <- RC.receiveRCPacket tls
rcvKeyNonce <- atomically $ stateTVar rcvKey C.sbcHkdf
resp <- RC.rcDecryptBody rcvKeyNonce $ LB.fromStrict encResp
liftIO $ resp `shouldBe` "response message"
logNote "c 5"
threadDelay 250000
logNote "ctrl: ciao"
@@ -93,7 +105,16 @@ testNewPairing = do
logNote "h 3"
liftIO $ RC.confirmCtrlSession rcCtrlClient True
logNote "h 4"
Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r'
Right (rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r'
let RCCtrlSession {tls, sessionKeys = CtrlSessKeys {chainKeys}} = rcCtrlSession
TSbChainKeys {rcvKey, sndKey} = chainKeys
encCmd <- RC.receiveRCPacket tls
rcvKeyNonce <- atomically $ stateTVar rcvKey C.sbcHkdf
cmd <- RC.rcDecryptBody rcvKeyNonce $ LB.fromStrict encCmd
liftIO $ cmd `shouldBe` "command message"
sndKeyNonce <- atomically $ stateTVar sndKey C.sbcHkdf
encResp <- RC.rcEncryptBody sndKeyNonce "response message"
RC.sendRCPacket tls $ LB.toStrict encResp
logNote "h 5"
threadDelay 250000
logNote "ctrl: adios"
+6 -3
View File
@@ -22,6 +22,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Time.Clock (getCurrentTime)
import SMPAgentClient
import SMPClient
import ServerTests (decryptMsgV3, sendRecv)
@@ -150,12 +151,13 @@ deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> S
deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
ts <- getCurrentTime
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} 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 batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ())
rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ())
rc <- either (fail . show) pure rc'
-- prepare receiving queue
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
@@ -192,7 +194,8 @@ proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO ()
proxyConnectDeadRelay n d proxyServ = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
ts <- getCurrentTime
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- get proxy session
+8 -1
View File
@@ -385,6 +385,10 @@ testSwitchSub (ATransport t) =
Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
(ok3, OK) #== "accepts ACK from the 2nd TCP connection"
Resp "cdab" _ OK <- signSendRecv rh1 rKey ("cdab", rId, DEL)
Resp "" rId' DELD <- tGet1 rh2
(rId', rId) #== "connection deleted event delivered to subscribed client"
1000 `timeout` tGet @SMPVersion @ErrorType @BrokerMsg rh1 >>= \case
Nothing -> return ()
Just _ -> error "nothing else is delivered to the 1st TCP connection"
@@ -839,7 +843,8 @@ testMessageNotifications (ATransport t) =
Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
Resp "" _ (NMSG _ _) <- tGet1 nh1
Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
Resp "" _ END <- tGet1 nh1
Resp "" nId2 END <- tGet1 nh1
nId2 `shouldBe` nId
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
Resp "" _ (Msg mId2 msg2) <- tGet1 rh
Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
@@ -849,6 +854,8 @@ testMessageNotifications (ATransport t) =
Nothing -> pure ()
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
Resp "" nId3 DELD <- tGet1 nh2
nId3 `shouldBe` nId
Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
Resp "" _ (Msg mId3 msg3) <- tGet1 rh
(dec mId3 msg3, Right "hello there") #== "delivered from queue again"
+2
View File
@@ -12,6 +12,7 @@ import CoreTests.CryptoFileTests
import CoreTests.CryptoTests
import CoreTests.EncodingTests
import CoreTests.RetryIntervalTests
import CoreTests.SOCKSSettings
import CoreTests.TRcvQueuesTests
import CoreTests.UtilTests
import CoreTests.VersionRangeTests
@@ -52,6 +53,7 @@ main = do
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Retry interval tests" retryIntervalTests
describe "SOCKS settings tests" socksSettingsTests
describe "TRcvQueues tests" tRcvQueuesTests
describe "Util tests" utilTests
describe "SMP server via TLS" $ serverTests (transport @TLS)
+2 -2
View File
@@ -429,7 +429,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
("", sfId', SFPROG _ _) <- sfGet sndr'
liftIO $ sfId' `shouldBe` sfId
threadDelay 100000
threadDelay 200000
withXFTPServerStoreLogOn $ \_ -> do
-- send file - should continue uploading with server up
@@ -443,7 +443,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
pure rfd1
-- prefix path should be removed after sending file
threadDelay 100000
threadDelay 200000
doesDirectoryExist prefixPath `shouldReturn` False
doesFileExist encPath `shouldReturn` False
+4 -2
View File
@@ -8,6 +8,7 @@ module XFTPClient where
import Control.Concurrent (ThreadId, threadDelay)
import Data.String (fromString)
import Data.Time.Clock (getCurrentTime)
import Network.Socket (ServiceName)
import SMPClient (serverBracket)
import Simplex.FileTransfer.Client
@@ -135,7 +136,8 @@ testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient = testXFTPClientWith testXFTPClientConfig
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith cfg client =
getXFTPClient (1, testXFTPServer, Nothing) cfg (\_ -> pure ()) >>= \case
testXFTPClientWith cfg client = do
ts <- getCurrentTime
getXFTPClient (1, testXFTPServer, Nothing) cfg ts (\_ -> pure ()) >>= \case
Right c -> client c
Left e -> error $ show e
+3 -1
View File
@@ -18,6 +18,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List (isInfixOf)
import Data.Time.Clock (getCurrentTime)
import ServerTests (logSize)
import Simplex.FileTransfer.Client
import Simplex.FileTransfer.Description (kb)
@@ -220,7 +221,8 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
testInactiveClientExpiration :: Expectation
testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
disconnected <- newEmptyTMVarIO
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
ts <- liftIO getCurrentTime
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig ts (\_ -> atomically $ putTMVar disconnected ())
pingXFTP c
liftIO $ do
threadDelay 100000