Compare commits

..
Author SHA1 Message Date
spaced4ndy cb46906aae Merge branch 'master' into ep/test-coverage 2023-06-02 18:05:07 +04:00
Evgeny Poberezkin 1d87f8e420 test coverage 2023-05-29 09:36:37 +01:00
62 changed files with 913 additions and 3389 deletions
-44
View File
@@ -1,47 +1,3 @@
# 5.2.0 (NTF server 1.5.0)
Agent:
- treat agent INACTIVE error as temporary - fixes failed message delivery in some race conditions.
- restore connection confirmations after client restart - fixes failed connections.
- ratchet resynchronization protocol and API.
- increase connection version to mutually supported by both peers on each received message.
Client:
- make timeout for batched functions dependent on the number of batches - fixes expiry on large batches.
Servers:
- add timeout in case of sending TCP traffic and in case of partial delivery of requested blocks to avoid resource leaks.
# 5.1.2, 5.1.3 (NTF server 1.4.1, 1.4.2)
Agent:
- ACK message on decryption error (fixes stuck message delivery bug)
- more robust connection switching logic, API to abort switching the address
Notification server:
- batch subscriptions to SMP servers
# 5.1.1 (NTF server 1.4.0)
Agent:
- store and check hashes of previous encrypted messages to differentiate between duplicates and decryption errors
Server:
- larger processing queues
- expire messages when restoring them
# 5.1.0
XFTP client:
- check encrypted file exists when uploading
- remove user ID from deletion API
Agent:
- vacuum database on migrations
SMP server:
- configure message expiration time in INI file
# 5.0.0
SimpleX File Transfer Protocol (XFTP):
+1 -1
View File
@@ -150,7 +150,7 @@ You can install and setup servers automatically using our script:
```sh
curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
&& if echo 'b8cf2be103f21f9461d9a500bcd3db06ab7d01d68871b07f4bd245195cbead1d simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
&& if echo '1268d605e90bca1a8c7ef476038a8bd9aa9b1a28f79ea0a1485669ccf8fc23cd simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm /simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
```
### Build from source
+8
View File
@@ -3,6 +3,14 @@ packages: .
-- packages: . ../hs-socks
-- packages: . ../http2
package *
coverage: True
library-coverage: True
package attoparsec
coverage: False
library-coverage: False
source-repository-package
type: git
location: https://github.com/simplex-chat/aeson.git
+5 -8
View File
@@ -11,7 +11,6 @@ scripts_systemd_smp="$scripts/smp-server.service"
scripts_systemd_xftp="$scripts/xftp-server.service"
scripts_update="$scripts/simplex-servers-update"
scripts_uninstall="$scripts/simplex-servers-uninstall"
scripts_stopscript="$scripts/simplex-servers-stopscript"
# Default installation paths
path_bin="/usr/local/bin"
@@ -19,7 +18,6 @@ path_bin_smp="$path_bin/smp-server"
path_bin_xftp="$path_bin/xftp-server"
path_bin_update="$path_bin/simplex-servers-update"
path_bin_uninstall="$path_bin/simplex-servers-uninstall"
path_bin_stopscript="$path_bin/simplex-servers-stopscript"
path_conf_etc="/etc/opt"
path_conf_var="/var/opt"
@@ -62,8 +60,8 @@ ${GRN}3.${NC} Setup user for each server:
${GRN}4.${NC} Create systemd services:
- smp: ${YLW}${path_systemd_smp}${NC}
- xftp: ${YLW}${path_systemd_xftp}${NC}
${GRN}5.${NC} Install stopscript (systemd), update and uninstallation script:
- all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}, ${YLW}${path_bin_stopscript}${NC}
${GRN}5.${NC} Install update and uninstallation script:
- all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}
Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
@@ -89,9 +87,9 @@ setup_users() {
setup_dirs() {
# Unquoted varibles, so field splitting can occur
mkdir -p $path_conf_smp
chown "$user_smp":"$user_smp" $path_conf_smp
chown "$user_smp":"$user_smp" "$path_conf_smp"
mkdir -p $path_conf_xftp
chown "$user_xftp":"$user_xftp" $path_conf_xftp
chown "$user_xftp":"$user_xftp" "$path_conf_xftp"
}
setup_systemd() {
@@ -102,7 +100,6 @@ setup_systemd() {
setup_scripts() {
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_bin_update" && chmod +x "$path_bin_update"
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_bin_uninstall" && chmod +x "$path_bin_uninstall"
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_bin_stopscript" && chmod +x "$path_bin_stopscript"
}
checks() {
@@ -134,7 +131,7 @@ main() {
setup_systemd
printf "${GRN} Done!${NC}\n"
printf "Installing stopscript, update and uninstallation script..."
printf "Installing update and uninstallation script..."
setup_scripts
printf "${GRN} Done!${NC}\n"
+3 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.2.1
version: 5.1.1
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -144,6 +144,8 @@ tests:
- silently == 1.2.*
- main-tester == 0.2.*
- timeit == 2.0.*
ghc-options:
- -fhpc
ghc-options:
# - -haddock
-366
View File
@@ -1,366 +0,0 @@
# Re-sync encryption ratchets
## Problem
See https://github.com/simplex-chat/simplexmq/pull/743/files for problem and high-level solution.
## Implementation
### Diagnosing ratchet de-synchronization
Message decryption happens in `agentClientMsg`, in `agentRatchetDecrypt`, which can return decryption result or error. Decryption error can be differentiated in `agentClientMsg` result pattern match, in Left cases, where we already differentiate duplicate error (`AGENT A_DUPLICATE`).
Question: Which decryption errors can be diagnosed as ratchet de-synchronization?
Possibly any `AGENT A_CRYPTO` error. Definitely on `RATCHET_HEADER`, TBC other. See `cryptoError :: C.CryptoError -> AgentErrorType` for conversion from decryption errors to `A_CRYPTO` or other agent errors. We're only interested in crypto errors, as other are either other client implementation errors, internal errors, or already processed duplicate error.
Proposed classification of crypto errors, based on `AgentCryptoError`:
`DECRYPT_AES` -> re-sync allowed (recommended/required?)
`DECRYPT_CB` -> re-sync allowed (recommended/required?)
`RATCHET_HEADER` -> **re-sync required**
`RATCHET_EARLIER` -> re-sync allowed
`RATCHET_SKIPPED` -> **re-sync required**
Ratchet re-synchronization could be started automatically on diagnosing de-synchronization, based on these errors. As a potentially dangerous feature (e.g., implementation error could lead to infinite re-sync loop causing large traffic consumption), initially it will be available via agent functional api for client to call. Ratchet de-synchronization will instead produce an event prompting client to re-synchronize.
Diagnosing possible ratchet de-synchronization also will be recorded as connection state - `ratchet_desync_state` field in `connections` table. Client should be prohibited to start ratchet re-synchronization unless `ratchet_desync_state` is set.
Event should not be repeated for following received messages that can't be decrypted - based on `ratchet_desync_state`. If a received message can be decrypted, `ratchet_desync_state` should be set to NULL and a new event sent, indicating ratchet has healed.
New event - `RDESYNC :: RatchetDesyncState -> ConnectionStats -> ACommand Agent AEConn`
```haskell
data RatchetDesyncState
= RDResyncAllowed
| RDResyncRequired
| RDHealed
```
New field should be added to `ConnectionStats` - `ratchetDesyncState :: Maybe RatchetDesyncState`, based on `ratchet_desync_state`.
> On `RDESYNC` events chat should create chat item, prompting ratchet re-synchronization or notifying it has healed.
> If connection has diagnosed ratchet de-sync, chat item should have a button to start ratchet re-sync.
> We'd have to get `ConnectionStats` on chat level for this instead of chat info.
> This wouldn't work for groups. One option is to add `ConnectionStats` to `GroupMember` type and update on events.
> Same could be done for `Contact` then.
To consider - allow to start ratchet re-synchronization at any time regardless of this field as an experimental feature. In chat it could be behind "Developer tools" + additional "Experimental" toggle. Agent api would have `force :: Bool` as parameter, allowing to bypass `ratchet_desync_state`. Should `ratchet_resync_state` (see below) still be honored in this case?
### Re-synchronization process
\*\*\*\*\*
Basic idea is the following:
Both agents send new ratchet keys and compute a new shared secret. Agent that starts re-synchronization should record this fact in the connection state. Agent that receives a new key should respond with a key of its own, unless it has recorded that it itself started re-synchronization in the connection state.
It can happen that both agents start re-synchronizing simultaneously. In this case they both would record it in the connection state and would not respond with a new message - instead they would use each other's already sent keys.
Agent has both keys if:
- It initiates with the first key, and then receives the second key;
- It receives the first key and then generates its own in response.
After agent has both keys, it initiates new ratchet depending on keys ordering. The agent that sent the lower key should use `initRcvRatchet` function, the agent that sent the greater key should use `initSndRatchet` (or vice versa - but they should deterministically choose different sides).
\*\*\*\*\*
State whether the ratchet re-synchronization is in progress should be tracked in database via `connections` table new `ratchet_resync_state` field.
New functional api:
```haskell
resyncConnectionRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
```
or if we want to allow re-synchronizing ratchet at any time even if de-synchronization wasn't diagnosed:
```haskell
resyncConnectionRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
resyncConnectionRatchet c connId force = ...
```
Possibly client command?
``` haskell
data ACommand (p :: AParty) (e :: AEntity) where
...
RESYNC_RATCHET :: Bool -> ACommand Client AEConn
```
New event - `RRESYNC :: RatchetResyncState -> ConnectionStats -> ACommand Agent AEConn`
```haskell
data RatchetResyncState
= RRStarted
| RRAgreedSnd
| RRAgreedRcv
| RRComplete
```
New `ConnectionStats` field - `ratchetResyncState :: Maybe RatchetResyncState`.
When called, it should:
- Generate new keys.
- Update database connection state.
- Set `ratchet_desync_state` to NULL.
- Set `ratchet_resync_state` to `RRStarted`.
- Delete old ratchet from `ratchets` (is it safe?), create new ratchet.
- Send `AgentRatchetKey` message.
- Return updated `ConnectionStats` to client.
> On `RRESYNC` events chat should create chat item, and reset connection verification.
> Parameterized `RRESYNC` allows to distinguish: start and end of re-synchronization for initiating party; chat item direction - `RRESYNC RRStarted` is snd, `RRESYNC RRAgreedSnd/Rcv` and `RRESYNC RRComplete` are rcv (`RRESYNC RRAgreedSnd/Rcv` chat item could be omitted).
AgentRatchetKey is a new message on the level of AgentMsgEnvelope - encrypted with queue level e2e encryption, but not with connection level e2e encryption (since ratchet de-synchronized).
```haskell
data AgentMsgEnvelope
= ...
| AgentRatchetKey
{ agentVersion :: Version,
e2eEncryption :: E2ERatchetParams 'C.X448,
info :: ByteString -- for extension
}
```
On receiving `AgentRatchetKey`, if the receiving client hasn't started the ratchet re-synchronization itself (check `ratchet_resync_state`), it should:
- Generate new keys and compute new shared secret, initializing ratchet based on keys comparison.
- Update database connection state.
- Set `ratchet_resync_state` to `RRAgreedSnd/Rcv` (depending on whether ratchet was initialized as sending or receiving).
- Delete old ratchet from `ratchets`, create new ratchet.
- Reply with its own `AgentRatchetKey`.
- Notify client with `RRESYNC RRAgreedSnd/Rcv`.
- If ratchet was initialized as sending, send `EREADY` message, notifying other agent ratchet is re-synced.
New agent message:
```haskell
data AMessage
= ...
| -- ratchet re-synchronization is complete, with last decrypted sender message id
EREADY PrevExternalSndId
```
On receiving `AgentRatchetKey`, if the receiving client started re-sync:
- Compute new shared secret, initializing ratchet based on keys comparison.
- Update database connection state.
- Set `ratchet_resync_state` to `RRAgreedSnd/Rcv` (depending on whether ratchet was initialized as sending or receiving).
- Update ratchet.
- Notify client with `RRESYNC RRAgreedSnd/Rcv`.
- If ratchet was initialized as sending, send `EREADY` message.
After agent receives `EREADY` (or any other message that successfully decrypts):
- Reset `ratchet_resync_state` to NULL.
- Notify client with `RRESYNC RRComplete`.
- If ratchet was initialized as receiving, send reply `EREADY` message.
### State transitions
For initiating party:
```
+------------+
| Ratchet ok |
+------------+
|
| message received, decryption error
* ---->|-----------------------------------+
| |
V new (clarifying) V
+-----------------+ error +------------------+
| Re-sync allowed |--------------->| Re-sync required |
+-----------------+ +------------------+
| |
|-----------------------------------|
| | alternative - message received,
| re-sync started by client | successfully decrypted
V V
+-----------------+ +------------+
| Re-sync started | | Ratchet ok |
+-----------------+ +------------+
|
| other party replied with new ratchet key
V
+----------------+
| Re-sync agreed |----> * message received, decryption error
| snd / rcv | (should remember agreed state for reply EREADY?)
+----------------+
|
| message received, successfully decrypted
| (can be, but not necessarily, EREADY)
V
+------------+
| Ratchet ok |
+------------+
```
For replying party:
```
+------------+
| Ratchet ok |
+------------+
|
| other party sent new ratchet key
V
+----------------+
| Re-sync agreed |
| snd / rcv |
+----------------+
|
| message received, successfully decrypted
| (can be, but not necessarily, EREADY)
V
+------------+
| Ratchet ok |
+------------+
```
### Ratchet state model
#### 2 state variables
Above we considered model with separate de-sync and re-sync state.
| Desync \ Resync | Nothing | RRStarted | RRAgreedSnd | RRAgreedRcv |
| --- | :---: | :---: | :---: | :---: |
| **Nothing** | 1 | 3 | 4 | 4 |
| **RDResyncAllowed** | 2 | | 5 | 5 |
| **RDResyncRequired** | 2 | | 5 | 5 |
1: Ratchet is ok.
2: Re-sync diagnosed, not in progress.
3: Rs-sync started, diagnosing de-sync is prohibited.
4: Re-sync agreed.
5: Re-sync agreed, new de-sync is diagnosed.
Combination 5 is possible in case de-sync was diagnosed before message that could be decrypted is received, for example if `EREADY` failed to deliver and no other decryptable message followed. We shouldn't prohibit diagnosing de-sync in this case, because agent may never exit "Agreed" state (if new decryptable message is never received). We also shouldn't overwrite/forget state of re-sync, even if we diagnose new possible de-sync, because if the decryptable `EREADY` is received and ratchet is in `RRAgreedRcv` state, it should respond with reply `EREADY`.
Some combinations should be impossible:
- `RDResyncAllowed` with `RRStarted`.
- `RDResyncRequired` with `RRStarted`.
`RDHealed` is equivalent to `Nothing` and only used for `RDESYNC` event, `Maybe RatchetDesyncState` can be replaced with `RatchetDesyncState`, with single new constructor `RDNoDesync` replacing `Nothing` and `RDHealed`.
`RRComplete` is equivalent to `Nothing` and only used for `RRESYNC` event, `Maybe RatchetResyncState` can be replaced with `RatchetResyncState`, with single new constructor `RDNoResync` replacing `Nothing` and `RRComplete`.
#### Single state variable
Another option is two have a single state variable describing ratchet.
```haskell
data RatchetState
= RSOk
| RSResyncAllowed
| RSResyncRequired
| RSResyncStarted
| RRResyncAgreedSnd
| RRResyncAgreedRcv
-- When `resyncConnectionRatchet` is not prohibited. Can override with `force`.
-- Currently we check:`(isJust ratchetDesyncState || force) && ratchetResyncState /= Just RRStarted`.
resyncConnectionRatchetAllowed :: RatchetState -> Bool
resyncConnectionRatchetAllowed = \case
RSOk -> False
RSResyncAllowed -> True
RSResyncRequired -> True
RSResyncStarted -> False -- `force` shouldn't override
RRResyncAgreedSnd -> False
RRResyncAgreedRcv -> False
-- When we register and notify about ratchet de-synchronization.
-- Currently we check: `(isNothing ratchetDesyncState && ratchetResyncState /= Just RRStarted)`.
-- We should also allow to update from Allowed to Required.
shouldNotifyRDESYNC :: RatchetState -> Bool
shouldNotifyRDESYNC = \case
RSOk -> True
RSResyncAllowed -> False -- only if new error implies Required
RSResyncRequired -> False
RSResyncStarted -> False
RRResyncAgreedSnd -> True
RRResyncAgreedRcv -> True
-- When we prohibit connection switch, for `checkRatchetDesync`.
-- Currently we check: `(ratchetDesyncState == Just RDResyncRequired || ratchetResyncState == Just RRStarted)`
-- Also use in `runSmpQueueMsgDelivery` to pause delivery?
ratchetDesynced :: RatchetState -> Bool
ratchetDesynced = \case
RSOk -> False
RSResyncAllowed -> False
RSResyncRequired -> True
RSResyncStarted -> True
RRResyncAgreedSnd -> False
RRResyncAgreedRcv -> False
```
Having a single state variable limits differentiation described for combination 5 in matrix. It also limits possible differentiations in client between events when ratchet is healed on its own, and when ratchet re-sync is completed after agents negotiation. Overall, since matrix is not very sparse and allows for more fine-grained decision-making, having separate state variables for de-sync and re-sync seems preferred.
#### Single state variable simplified (final version)
```haskell
data RatchetSyncState
= RSOk
| RSAllowed
| RSRequired
| RSStarted
| RSAgreed
-- event
RSYNC :: RatchetSyncState -> ConnectionStats -> ACommand Agent AEConn`
-- ConnectionStats field
ratchetSyncState :: RatchetSyncState
```
Updated design decisions:
1. Single constructor for "Agreed" state. Differentiating `RRResyncAgreedSnd` and `RRResyncAgreedRcv` allowed for easier processing of `EREADY` by helping to determine whether reply `EREADY` has to be sent. However, it duplicated information already present in ratchet's state, and can be instead worked around by remembering and analyzing ratchet state pre decryption.
2. Prohibit transition from "Agreed" state to "Desync" states. This would make possible edge-cases that leave ratchet in de-synchronized state without ability to progress (e.g. failed delivery of `AgentRatchetKey`), but would simplify state machine by removing dedicated "Desync" variable. Besides, there's still a recovery way with a `force` option.
3. Treat "Agreed" as unfinished state - prohibit new messages to be enqueued, etc. Reception of any decryptable message transitions ratchet to "Ok" state.
Possible improvements:
- Repeatedly triggering re-synchronization while in "Started"/"Agreed" state re-sends same keys and EREADY.
- Cooldown period, during which repeat re-synchronization is prohibited.
### Skipped messages
Options:
1. Ignore skipped messages.
2. Stop sending new messages while connection re-synchronizes (can use `ratchet_resync_state`).
- Initiator shouldn't send new messages until receives `AgentRatchetKey` from second party.
- Second party knows new shared secret immediately after processing first `AgentRatchetKey`, so it's not necessary to limit?
3. 2 + Re-send skipped messages first.
- Add `last_external_snd_msg_id` to `AgentRatchetKey`? + see link above
4. Re-send only messages after the latest ratchet step. \*
It may be okay to ignore skipped messages, or at most implement option 2, as ratchet de-synchronization is usually caused by misuse (human error) - the most common cause of ratchet de-sync seems to be sending and receiving messages after running agent with old database backup. In this case user has already seen most skipped messages, and it can be expected to not have them after switching to an old backup. So in this case the only "really skipped" messages are those that were sent during the latest ratchet step and failed to decrypt, triggering ratchet re-sync (\* another option is to only re-send those).
Besides, depending on time of backup there may be an arbitrary large number of skipped messages, which may consume a lot of traffic and may halt delivery of up-to-date messages for some time.
It may be better to have request for repeat delivery as a separate feature, that can be requested in necessary contexts - for example for group stability.
Can servers delivery failure lead to de-sync? If message is lost on server and never delivered, ratchet wouldn't advance, so there's no room for de-sync? If yes, re-evaluate.
-30
View File
@@ -1,30 +0,0 @@
#!/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"
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
}
backup_xftp() {
if [ -e "$path_conf_storelog_xftp" ]; then
cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
fi
}
if [ "$1" = 'smp-server' ]; then
backup_smp
elif [ "$1" = 'xftp-server' ]; then
backup_xftp
else
backup_smp
backup_xftp
fi
+1 -6
View File
@@ -13,11 +13,6 @@ fi
printf "${RED}This action will permanently remove all configs, directories, binaries from Installation Script. Please backup any relevant configs if they are needed.${NC}\n\nPress ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
read ans
systemctl stop smp-server
systemctl stop xftp-server
rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall
userdel smp && userdel xftp
rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall && userdel smp && userdel xftp
printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"
+14 -28
View File
@@ -11,7 +11,6 @@ scripts_systemd_smp="$scripts/smp-server.service"
scripts_systemd_xftp="$scripts/xftp-server.service"
scripts_update="$scripts/simplex-servers-update"
scripts_uninstall="$scripts/simplex-servers-uninstall"
scripts_stopscript="$scripts/simplex-servers-stopscript"
# Default installation paths
path_bin="/usr/local/bin"
@@ -19,7 +18,6 @@ path_bin_smp="$path_bin/smp-server"
path_bin_xftp="$path_bin/xftp-server"
path_bin_update="$path_bin/simplex-servers-update"
path_bin_uninstall="$path_bin/simplex-servers-uninstall"
path_bin_stopscript="$path_bin/simplex-servers-stopscript"
path_systemd="/etc/systemd/system"
path_systemd_smp="$path_systemd/smp-server.service"
@@ -29,7 +27,6 @@ path_systemd_xftp="$path_systemd/xftp-server.service"
path_tmp_bin="$(mktemp -d)"
path_tmp_bin_update="$path_tmp_bin/simplex-servers-update"
path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall"
path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
path_tmp_systemd_smp="$path_tmp_bin/smp-server.service"
path_tmp_systemd_xftp="$path_tmp_bin/xftp-server.service"
@@ -46,9 +43,8 @@ remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com
update_scripts() {
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_tmp_bin_uninstall" && chmod +x "$path_tmp_bin_uninstall"
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_tmp_bin_stopscript" && chmod +x "$path_tmp_bin_stopscript"
if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null 2>&1; then
if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null; then
printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n"
rm "$path_tmp_bin_uninstall"
else
@@ -56,15 +52,7 @@ update_scripts() {
mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
printf "${GRN}Done!${NC}\n"
fi
if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
rm "$path_tmp_bin_stopscript"
else
printf -- "- Updating stopscript script..."
mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
printf "${GRN}Done!${NC}\n"
fi
if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null; then
printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
rm "$path_tmp_bin_update"
else
@@ -80,7 +68,7 @@ update_systemd() {
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_tmp_systemd_smp"
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_tmp_systemd_xftp"
if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null 2>&1; then
if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null; then
printf -- "- ${YLW}smp-server service is up-to-date${NC}.\n"
rm "$path_tmp_systemd_smp"
else
@@ -89,7 +77,7 @@ update_systemd() {
systemctl daemon-reload
printf "${GRN}Done!${NC}\n"
fi
if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null 2>&1; then
if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null; then
printf -- "- ${YLW}xftp-server service is up-to-date${NC}.\n"
rm "$path_tmp_systemd_xftp"
else
@@ -107,16 +95,16 @@ update_bins() {
systemctl stop smp-server
printf "${GRN}Done!${NC}\n"
printf -- "- Updating smp-server bin to %s..." "$remote_version"
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
print -- "- Updating smp-server bin to %s..." "$remote_version"
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
printf "${GRN}Done!${NC}\n"
printf -- "- Starting smp-server service..."
systemctl start smp-server
systemctl stop smp-server
printf "${GRN}Done!${NC}\n"
else
printf -- "- Updating smp-server bin..."
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
print -- "- Updating smp-server bin..."
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
printf "${GRN}Done!${NC}\n"
fi
@@ -125,16 +113,16 @@ update_bins() {
systemctl stop xftp-server
printf "${GRN}Done!${NC}\n"
printf -- "- Updating xftp-server bin to %s..." "$remote_version"
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
print -- "- Updating xftp-server bin to %s..." "$remote_version"
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
printf "${GRN}Done!${NC}\n"
printf -- "- Starting xftp-server service..."
systemctl start xftp-server
systemctl stop xftp-server
printf "${GRN}Done!${NC}\n"
else
printf -- "- Updating xftp-server bin..."
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
print -- "- Updating xftp-server bin..."
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
printf "${GRN}Done!${NC}\n"
fi
else
@@ -167,8 +155,6 @@ main() {
printf "Updating simplex server binaries...\n"
update_bins
rm -rf "$path_tmp_bin"
}
main "$@"
+1 -1
View File
@@ -6,7 +6,7 @@ User=smp
Group=smp
Type=simple
ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS
ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%FT%T)'
LimitNOFILE=65535
KillSignal=SIGINT
TimeoutStopSec=infinity
+1 -1
View File
@@ -6,7 +6,7 @@ User=xftp
Group=xftp
Type=simple
ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%FT%T)'
LimitNOFILE=65535
KillSignal=SIGINT
TimeoutStopSec=infinity
+2 -6
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.2.1
version: 5.1.1
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -63,7 +63,6 @@ library
Simplex.Messaging.Agent.Server
Simplex.Messaging.Agent.Store
Simplex.Messaging.Agent.Store.SQLite
Simplex.Messaging.Agent.Store.SQLite.Common
Simplex.Messaging.Agent.Store.SQLite.Migrations
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
@@ -83,8 +82,6 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
Simplex.Messaging.Agent.TAsyncs
Simplex.Messaging.Agent.TRcvQueues
Simplex.Messaging.Client
@@ -534,7 +531,6 @@ test-suite simplexmq-test
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
CoreTests.RetryIntervalTests
CoreTests.UtilTests
CoreTests.VersionRangeTests
FileDescriptionTests
NtfClient
@@ -549,7 +545,7 @@ test-suite simplexmq-test
Paths_simplexmq
hs-source-dirs:
tests
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -fhpc
build-depends:
HUnit ==1.6.*
, QuickCheck ==2.14.*
+15 -14
View File
@@ -71,6 +71,7 @@ import System.FilePath (takeFileName, (</>))
import UnliftIO
import UnliftIO.Concurrent
import UnliftIO.Directory
import qualified UnliftIO.Exception as E
startWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
startWorkers c workDir = do
@@ -161,7 +162,7 @@ addWorker c wsSel runWorker runWorkerNoSrv srv_ = do
let runWorker' = case srv_ of
Just srv -> runWorker c srv doWork
Nothing -> runWorkerNoSrv c doWork
worker <- async $ runWorker' `agentFinally` atomically (TM.delete srv_ ws)
worker <- async $ runWorker' `E.finally` atomically (TM.delete srv_ ws)
atomically $ TM.insert srv_ (doWork, worker) ws
Just (doWork, _) ->
void . atomically $ tryPutTMVar doWork ()
@@ -186,10 +187,10 @@ runXFTPRcvWorker c srv doWork = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryInterval ri' $ \delay' loop ->
downloadFileChunk fc replica
`catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
`catchError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
flip catchError (\_ -> pure ()) $ do
notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
closeXFTPServerClient c userId server digest
@@ -248,7 +249,7 @@ runXFTPRcvLocalWorker c doWork = do
case nextFile of
Nothing -> noWorkToDo
Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
decryptFile f `catchError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
decryptFile :: RcvFile -> m ()
decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
@@ -299,7 +300,7 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
createDirectory outputDir
let tempPath = workPath </> "snd"
createDirectoryIfMissing False tempPath
runSend fileName outputDir tempPath `catchAgentError` \e -> do
runSend fileName outputDir tempPath `catchError` \e -> do
cleanup outputDir tempPath
notify c sndFileId $ SFERR e
where
@@ -369,7 +370,7 @@ runXFTPSndPrepareWorker c doWork = do
case nextFile of
Nothing -> noWorkToDo
Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
prepareFile f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
prepareFile f `catchError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
prepareFile :: SndFile -> m ()
prepareFile SndFile {prefixPath = Nothing} =
@@ -423,7 +424,7 @@ runXFTPSndPrepareWorker c doWork = do
usedSrvs <- newTVarIO ([] :: [XFTPServer])
withRetryInterval (riFast ri) $ \_ loop ->
createWithNextSrv usedSrvs
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
`catchError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
where
retryLoop loop = atomically (assertAgentForeground c) >> loop
createWithNextSrv usedSrvs = do
@@ -459,10 +460,10 @@ runXFTPSndWorker c srv doWork = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryInterval ri' $ \delay' loop ->
uploadFileChunk fc replica
`catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
`catchError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
flip catchError (\_ -> pure ()) $ do
notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
closeXFTPServerClient c userId server digest
@@ -578,8 +579,8 @@ deleteSndFileInternal c sndFileEntityId = do
deleteSndFileRemote :: forall m. AgentMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
deleteSndFileRemote c userId sndFileEntityId (ValidFileDescription FileDescription {chunks}) = do
deleteSndFileInternal c sndFileEntityId `catchAgentError` (notify c sndFileEntityId . SFERR)
forM_ chunks $ \ch -> deleteFileChunk ch `catchAgentError` (notify c sndFileEntityId . SFERR)
deleteSndFileInternal c sndFileEntityId `catchError` (notify c sndFileEntityId . SFERR)
forM_ chunks $ \ch -> deleteFileChunk ch `catchError` (notify c sndFileEntityId . SFERR)
where
deleteFileChunk :: FileChunk -> m ()
deleteFileChunk FileChunk {digest, replicas = replica@FileChunkReplica {server} : _} = do
@@ -593,7 +594,7 @@ addXFTPDelWorker c srv = do
atomically (TM.lookup srv ws) >>= \case
Nothing -> do
doWork <- newTMVarIO ()
worker <- async $ runXFTPDelWorker c srv doWork `agentFinally` atomically (TM.delete srv ws)
worker <- async $ runXFTPDelWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
atomically $ TM.insert srv (doWork, worker) ws
Just (doWork, _) ->
void . atomically $ tryPutTMVar doWork ()
@@ -618,10 +619,10 @@ runXFTPDelWorker c srv doWork = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryInterval ri' $ \delay' loop ->
deleteChunkReplica replica
`catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
`catchError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
flip catchError (\_ -> pure ()) $ do
notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
when notifyOnRetry $ notify c "" $ SFERR e
closeXFTPServerClient c userId server chunkDigest
+6 -5
View File
@@ -38,8 +38,9 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (toLower)
import Data.Function (on)
import Data.Int (Int64)
import Data.List (foldl', sortOn)
import Data.List (foldl', groupBy, sortOn)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map (Map)
@@ -65,7 +66,7 @@ import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth)
import Simplex.Messaging.Server.CLI (getCliCommand')
import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM)
import Simplex.Messaging.Util (ifM, tshow, whenM)
import System.Exit (exitFailure)
import System.FilePath (splitFileName, (</>))
import System.IO.Temp (getCanonicalTemporaryDirectory)
@@ -74,7 +75,7 @@ import UnliftIO
import UnliftIO.Directory
xftpClientVersion :: String
xftpClientVersion = "1.0.1"
xftpClientVersion = "0.1.0"
chunkSize1 :: Word32
chunkSize1 = kb 256
@@ -315,7 +316,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
srvs <- liftIO $ replicateM (length chunks) $ getXFTPServer gen xftpSrvs
let thd3 (_, _, x) = x
chunks' = groupAllOn thd3 $ zip3 [1 ..] chunks srvs
chunks' = groupBy ((==) `on` thd3) $ sortOn thd3 $ zip3 [1 ..] chunks srvs
-- TODO shuffle/unshuffle chunks
-- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
-- upload doesn't allow other requests within the same client until complete (but download does allow).
@@ -427,7 +428,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
liftIO $ printNoNewLine "Downloading file..."
downloadedChunks <- newTVarIO []
let srv FileChunk {replicas} = server (head replicas :: FileChunkReplica)
srvChunks = groupAllOn srv chunks
srvChunks = groupBy ((==) `on` srv) $ sortOn srv chunks
chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks)
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
+7 -4
View File
@@ -42,8 +42,9 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Function (on)
import Data.Int (Int64)
import Data.List (foldl', sortOn)
import Data.List (foldl', groupBy, sortOn)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
@@ -58,7 +59,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Util (bshow, groupAllOn, (<$?>))
import Simplex.Messaging.Util (bshow, (<$?>))
data FileDescription (p :: FileParty) = FileDescription
{ party :: SFileParty p,
@@ -257,7 +258,9 @@ instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toFiel
groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
groupReplicasByServer defChunkSize =
groupAllOn replicaServer . unfoldChunksToReplicas defChunkSize
groupBy ((==) `on` replicaServer)
. sortOn replicaServer
. unfoldChunksToReplicas defChunkSize
encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
encodeFileReplicas defChunkSize =
@@ -265,7 +268,7 @@ encodeFileReplicas defChunkSize =
where
encodeServerReplicas fs =
YAMLServerReplicas
{ server = replicaServer $ head fs, -- groupAllOn guarantees that fs is not empty
{ server = replicaServer $ head fs, -- groupBy guarantees that fs is not empty
chunks = map (B.unpack . encodeServerReplica) fs
}
+2 -2
View File
@@ -70,7 +70,7 @@ runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
restoreServerStats
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
where
@@ -79,7 +79,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig} started = do
serverParams <- asks tlsServerParams
env <- ask
liftIO $
runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig $ \sessionId r sendResponse -> do
runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams logTLSErrors $ \sessionId r sendResponse -> do
reqBody <- getHTTP2Body r xftpBlockSize
processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
+2 -2
View File
@@ -26,7 +26,7 @@ import Simplex.FileTransfer.Server.StoreLog
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Util (tshow)
import System.IO (IOMode (..))
import UnliftIO.STM
@@ -55,7 +55,7 @@ data XFTPServerConfig = XFTPServerConfig
logStatsStartTime :: Int64,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath,
transportConfig :: TransportServerConfig
logTLSErrors :: Bool
}
data XFTPEnv = XFTPEnv
+2 -6
View File
@@ -25,14 +25,13 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
xftpServerVersion :: String
xftpServerVersion = "1.0.1"
xftpServerVersion = "1.0.0"
xftpServerCLI :: FilePath -> FilePath -> IO ()
xftpServerCLI cfgPath logPath = do
@@ -152,10 +151,7 @@ xftpServerCLI cfgPath logPath = do
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
data CliCommand
File diff suppressed because it is too large Load Diff
+23 -38
View File
@@ -41,9 +41,7 @@ module Simplex.Messaging.Agent.Client
temporaryOrHostError,
secureQueue,
enableQueueNotifications,
enableQueuesNtfs,
disableQueueNotifications,
disableQueuesNtfs,
sendAgentMessage,
agentNtfRegisterToken,
agentNtfVerifyToken,
@@ -163,6 +161,9 @@ import Simplex.Messaging.Protocol
ErrorType,
MsgFlags (..),
MsgId,
NotifierId,
NtfPrivateSignKey,
NtfPublicVerifyKey,
NtfServer,
ProtoServer,
ProtoServerWithAuth (..),
@@ -399,7 +400,7 @@ instance ProtocolServerClient XFTPErrorType FileResponse where
getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
unlessM (readTVarIO active) . throwError $ INACTIVE
unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
atomically (getClientVar tSess smpClients)
>>= either
(newProtocolClient c tSess smpClients connectClient reconnectSMPClient)
@@ -443,7 +444,7 @@ reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
tryReconnectSMPClient aId = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop ->
reconnectSMPClient c tSess `catchAgentError` const loop
reconnectSMPClient c tSess `catchError` const loop
atomically . removeAsyncAction aId $ reconnections c
reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m ()
@@ -467,7 +468,7 @@ reconnectSMPClient c tSess@(_, srv, _) =
getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
unlessM (readTVarIO active) . throwError $ INACTIVE
unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
atomically (getClientVar tSess ntfClients)
>>= either
(newProtocolClient c tSess ntfClients connectClient $ \_ _ -> pure ())
@@ -487,7 +488,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient
getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
unlessM (readTVarIO active) . throwError $ INACTIVE
unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
atomically (getClientVar tSess xftpClients)
>>= either
(newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ())
@@ -640,7 +641,7 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur
withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
withClient_ c tSess@(userId, srv, _) statCmd action = do
cl <- getProtocolServerClient c tSess
(action cl <* stat cl "OK") `catchAgentError` logServerError cl
(action cl <* stat cl "OK") `catchError` logServerError cl
where
stat cl = liftIO . incClientStat c userId cl statCmd
logServerError :: Client msg -> AgentErrorType -> m a
@@ -840,7 +841,6 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do
dbQueueId = 0,
primary = True,
dbReplaceQueueId = Nothing,
rcvSwchStatus = Nothing,
smpClientVersion = maxVersion vRange,
clientNtfCreds = Nothing,
deleteErrors = 0
@@ -860,7 +860,6 @@ temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError = \case
BROKER _ NETWORK -> True
BROKER _ TIMEOUT -> True
INACTIVE -> True
_ -> False
temporaryOrHostError :: AgentErrorType -> Bool
@@ -876,13 +875,11 @@ subscribeQueues c qs = do
modifyTVar (subscrConns c) $ S.insert connId
RQ.addQueue rq $ pendingSubs c
u <- askUnliftIO
-- only "checked" queues are subscribed
(errs <>) <$> sendTSessionBatches "SUB" 90 id (subscribeQueues_ u) c qs'
(errs <>) <$> sendTSessionBatches "SUB" 90 (subscribeQueues_ u) c qs
where
checkQueue rq@RcvQueue {rcvId, server} = do
prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
subscribeQueues_ :: UnliftIO m -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
subscribeQueues_ u smp qs' = do
rs <- sendBatch subscribeSMPQueues smp qs'
mapM_ (uncurry $ processSubResult c) rs
@@ -890,25 +887,25 @@ subscribeQueues c qs = do
unliftIO u $ reconnectServer c $ transportSession' smp
pure rs
type BatchResponses e r = (NonEmpty (RcvQueue, Either e r))
type BatchResponses e = (NonEmpty (RcvQueue, Either e ()))
-- statBatchSize is not used to batch the commands, only for traffic statistics
sendTSessionBatches :: forall m q r. AgentMonad m => ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> m [(RcvQueue, Either AgentErrorType r)]
sendTSessionBatches statCmd statBatchSize toRQ action c qs =
sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
sendTSessionBatches statCmd statBatchSize action c qs =
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
where
batchQueues :: m [(SMPTransportSession, NonEmpty q)]
batchQueues :: m [(SMPTransportSession, NonEmpty RcvQueue)]
batchQueues = do
mode <- sessionMode <$> readTVarIO (useNetworkConfig c)
pure . M.assocs $ foldl' (batch mode) M.empty qs
where
batch mode m q =
let tSess = mkSMPTSession (toRQ q) mode
in M.alter (Just . maybe [q] (q <|)) tSess m
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> m (BatchResponses AgentErrorType r)
batch mode m rq =
let tSess = mkSMPTSession rq mode
in M.alter (Just . maybe [rq] (rq <|)) tSess m
sendClientBatch :: (SMPTransportSession, NonEmpty RcvQueue) -> m (BatchResponses AgentErrorType)
sendClientBatch (tSess@(userId, srv, _), qs') =
tryError (getSMPServerClient c tSess) >>= \case
Left e -> pure $ L.map ((,Left e) . toRQ) qs'
Left e -> pure $ L.map (,Left e) qs'
Right smp -> liftIO $ do
logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
rs <- L.map agentError <$> action smp qs'
@@ -918,9 +915,9 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs =
agentError = second . first $ protocolClientError SMP $ clientServer smp
statBatch =
let n = (length qs - 1) `div` statBatchSize + 1
in incClientStatN c userId smp n statCmd "OK"
in incClientStatN c userId smp n (statCmd <> "S") "OK"
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
where
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1003,28 +1000,16 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
withSMPClient c rq "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicVerifyKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey)
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
withSMPClient c rq "NKEY <nkey>" $ \smp ->
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
enableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_
where
fst3 (x, _, _) = x
enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicVerifyKey, 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.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateSignKey, SMP.RecipientId, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)
queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "NDEL" $ \smp ->
disableSMPQueueNotifications smp rcvPrivateKey rcvId
disableQueuesNtfs :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs
sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
withSMPClient c rq "ACK" $ \smp ->
@@ -1046,7 +1031,7 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
deleteSMPQueue smp rcvPrivateKey rcvId
deleteQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues
deleteQueues = sendTSessionBatches "DEL" 90 $ sendBatch deleteSMPQueues
sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg =
@@ -1079,7 +1064,7 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W
agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateSignKey -> m NtfSubscriptionId
agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId
agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
+1 -24
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
@@ -18,9 +17,6 @@ module Simplex.Messaging.Agent.Env.SQLite
NetworkConfig (..),
defaultAgentConfig,
defaultReconnectInterval,
tryAgentError,
catchAgentError,
agentFinally,
Env (..),
newSMPAgentEnv,
createAgentStore,
@@ -56,10 +52,9 @@ import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport.Client (defaultSMPPort)
import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors)
import Simplex.Messaging.Version
import System.Random (StdGen, newStdGen)
import UnliftIO (Async, SomeException)
import UnliftIO (Async)
import UnliftIO.STM
type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m)
@@ -88,7 +83,6 @@ data AgentConfig = AgentConfig
initialCleanupDelay :: Int64,
cleanupInterval :: Int64,
rcvMsgHashesTTL :: NominalDiffTime,
processedRatchetKeyHashesTTL :: NominalDiffTime,
rcvFilesTTL :: NominalDiffTime,
sndFilesTTL :: NominalDiffTime,
xftpNotifyErrsOnRetry :: Bool,
@@ -153,7 +147,6 @@ defaultAgentConfig =
initialCleanupDelay = 30 * 1000000, -- 30 seconds
cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
rcvMsgHashesTTL = 30 * nominalDay,
processedRatchetKeyHashesTTL = 30 * nominalDay,
rcvFilesTTL = 2 * nominalDay,
sndFilesTTL = nominalDay,
xftpNotifyErrsOnRetry = True,
@@ -230,19 +223,3 @@ newXFTPAgent = do
xftpSndWorkers <- TM.empty
xftpDelWorkers <- TM.empty
pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
tryAgentError :: AgentMonad m => m a -> m (Either AgentErrorType a)
tryAgentError = tryAllErrors mkInternal
{-# INLINE tryAgentError #-}
catchAgentError :: AgentMonad m => m a -> (AgentErrorType -> m a) -> m a
catchAgentError = catchAllErrors mkInternal
{-# INLINE catchAgentError #-}
agentFinally :: AgentMonad m => m a -> m b -> m a
agentFinally = allFinally mkInternal
{-# INLINE agentFinally #-}
mkInternal :: SomeException -> AgentErrorType
mkInternal = INTERNAL . show
{-# INLINE mkInternal #-}
@@ -147,7 +147,7 @@ processNtfSub c (connId, cmd) = do
atomically (TM.lookup srv ws) >>= \case
Nothing -> do
doWork <- newTMVarIO ()
worker <- async $ runWorker c srv doWork `agentFinally` atomically (TM.delete srv ws)
worker <- async $ runWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
atomically $ TM.insert srv (doWork, worker) ws
Just (doWork, _) ->
void . atomically $ tryPutTMVar doWork ()
@@ -173,7 +173,7 @@ runNtfWorker c srv doWork = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop ->
processAction a
`catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
`catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
@@ -213,7 +213,7 @@ runNtfWorker c srv doWork = do
NSADelete -> case ntfSubId of
Just nSubId ->
(getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
`agentFinally` continueDeletion
`E.finally` continueDeletion
_ -> continueDeletion
where
continueDeletion = do
@@ -224,7 +224,7 @@ runNtfWorker c srv doWork = do
NSARotate -> case ntfSubId of
Just nSubId ->
(getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
`agentFinally` deleteCreate
`E.finally` deleteCreate
_ -> deleteCreate
where
deleteCreate = do
@@ -257,7 +257,7 @@ runNtfSMPWorker c srv doWork = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop ->
processAction a
`catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
`catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
+15 -225
View File
@@ -55,14 +55,9 @@ module Simplex.Messaging.Agent.Protocol
AEntityI (..),
MsgHash,
MsgMeta (..),
RcvQueueInfo (..),
SndQueueInfo (..),
ConnectionStats (..),
SwitchPhase (..),
RcvSwitchStatus (..),
SndSwitchStatus (..),
QueueDirection (..),
RatchetSyncState (..),
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
@@ -99,7 +94,6 @@ module Simplex.Messaging.Agent.Protocol
BrokerErrorType (..),
SMPAgentError (..),
AgentCryptoError (..),
cryptoErrToSyncState,
ATransmission,
ATransmissionOrError,
ARawTransmission,
@@ -161,7 +155,7 @@ import qualified Data.Map as M
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime)
import Data.Time.ISO8601
@@ -211,7 +205,7 @@ import Text.Read
import UnliftIO.Exception (Exception)
currentSMPAgentVersion :: Version
currentSMPAgentVersion = 3
currentSMPAgentVersion = 2
supportedSMPAgentVRange :: VersionRange
supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
@@ -326,7 +320,6 @@ data ACommand (p :: AParty) (e :: AEntity) where
DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
MID :: AgentMsgId -> ACommand Agent AEConn
SENT :: AgentMsgId -> ACommand Agent AEConn
@@ -385,7 +378,6 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
DOWN_ :: ACommandTag Agent AENone
UP_ :: ACommandTag Agent AENone
SWITCH_ :: ACommandTag Agent AEConn
RSYNC_ :: ACommandTag Agent AEConn
SEND_ :: ACommandTag Client AEConn
MID_ :: ACommandTag Agent AEConn
SENT_ :: ACommandTag Agent AEConn
@@ -437,7 +429,6 @@ aCommandTag = \case
DOWN {} -> DOWN_
UP {} -> UP_
SWITCH {} -> SWITCH_
RSYNC {} -> RSYNC_
SEND {} -> SEND_
MID _ -> MID_
SENT _ -> SENT_
@@ -482,20 +473,18 @@ instance ToJSON QueueDirection where
instance FromJSON QueueDirection where
parseJSON = strParseJSON "QueueDirection"
data SwitchPhase = SPStarted | SPConfirmed | SPSecured | SPCompleted
data SwitchPhase = SPStarted | SPConfirmed | SPCompleted
deriving (Eq, Show)
instance StrEncoding SwitchPhase where
strEncode = \case
SPStarted -> "started"
SPConfirmed -> "confirmed"
SPSecured -> "secured"
SPCompleted -> "completed"
strP =
A.takeTill (== ' ') >>= \case
"started" -> pure SPStarted
"confirmed" -> pure SPConfirmed
"secured" -> pure SPSecured
"completed" -> pure SPCompleted
_ -> fail "bad SwitchPhase"
@@ -506,158 +495,19 @@ instance ToJSON SwitchPhase where
instance FromJSON SwitchPhase where
parseJSON = strParseJSON "SwitchPhase"
data RcvSwitchStatus
= RSSwitchStarted
| RSSendingQADD
| RSSendingQUSE
| RSReceivedMessage
deriving (Eq, Show)
instance StrEncoding RcvSwitchStatus where
strEncode = \case
RSSwitchStarted -> "switch_started"
RSSendingQADD -> "sending_qadd"
RSSendingQUSE -> "sending_quse"
RSReceivedMessage -> "received_message"
strP =
A.takeTill (== ' ') >>= \case
"switch_started" -> pure RSSwitchStarted
"sending_qadd" -> pure RSSendingQADD
"sending_quse" -> pure RSSendingQUSE
"received_message" -> pure RSReceivedMessage
_ -> fail "bad RcvSwitchStatus"
instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode
instance FromField RcvSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToJSON RcvSwitchStatus where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON RcvSwitchStatus where
parseJSON = strParseJSON "RcvSwitchStatus"
data SndSwitchStatus
= SSSendingQKEY
| SSSendingQTEST
deriving (Eq, Show)
instance StrEncoding SndSwitchStatus where
strEncode = \case
SSSendingQKEY -> "sending_qkey"
SSSendingQTEST -> "sending_qtest"
strP =
A.takeTill (== ' ') >>= \case
"sending_qkey" -> pure SSSendingQKEY
"sending_qtest" -> pure SSSendingQTEST
_ -> fail "bad SndSwitchStatus"
instance ToField SndSwitchStatus where toField = toField . decodeLatin1 . strEncode
instance FromField SndSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToJSON SndSwitchStatus where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON SndSwitchStatus where
parseJSON = strParseJSON "SndSwitchStatus"
data RatchetSyncState
= RSOk
| RSAllowed
| RSRequired
| RSStarted
| RSAgreed
deriving (Eq, Show)
instance StrEncoding RatchetSyncState where
strEncode = \case
RSOk -> "ok"
RSAllowed -> "allowed"
RSRequired -> "required"
RSStarted -> "started"
RSAgreed -> "agreed"
strP =
A.takeTill (== ' ') >>= \case
"ok" -> pure RSOk
"allowed" -> pure RSAllowed
"required" -> pure RSRequired
"started" -> pure RSStarted
"agreed" -> pure RSAgreed
_ -> fail "bad RatchetSyncState"
instance FromField RatchetSyncState where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToField RatchetSyncState where toField = toField . decodeLatin1 . strEncode
instance ToJSON RatchetSyncState where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON RatchetSyncState where
parseJSON = strParseJSON "RatchetSyncState"
data RcvQueueInfo = RcvQueueInfo
{ rcvServer :: SMPServer,
rcvSwitchStatus :: Maybe RcvSwitchStatus,
canAbortSwitch :: Bool
}
deriving (Eq, Show, Generic)
instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
instance StrEncoding RcvQueueInfo where
strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
"srv=" <> strEncode rcvServer
<> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
<> (";can_abort_switch=" <> strEncode canAbortSwitch)
strP = do
rcvServer <- "srv=" *> strP
rcvSwitchStatus <- optional $ ";switch=" *> strP
canAbortSwitch <- ";can_abort_switch=" *> strP
pure RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch}
data SndQueueInfo = SndQueueInfo
{ sndServer :: SMPServer,
sndSwitchStatus :: Maybe SndSwitchStatus
}
deriving (Eq, Show, Generic)
instance ToJSON SndQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
instance StrEncoding SndQueueInfo where
strEncode SndQueueInfo {sndServer, sndSwitchStatus} =
"srv=" <> strEncode sndServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) sndSwitchStatus
strP = do
sndServer <- "srv=" *> strP
sndSwitchStatus <- optional $ ";switch=" *> strP
pure SndQueueInfo {sndServer, sndSwitchStatus}
data ConnectionStats = ConnectionStats
{ connAgentVersion :: Version,
rcvQueuesInfo :: [RcvQueueInfo],
sndQueuesInfo :: [SndQueueInfo],
ratchetSyncState :: RatchetSyncState,
ratchetSyncSupported :: Bool
{ rcvServers :: [SMPServer],
sndServers :: [SMPServer]
}
deriving (Eq, Show, Generic)
instance StrEncoding ConnectionStats where
strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} =
"agent_version=" <> strEncode connAgentVersion
<> (" rcv=" <> strEncodeList rcvQueuesInfo)
<> (" snd=" <> strEncodeList sndQueuesInfo)
<> (" sync=" <> strEncode ratchetSyncState)
<> (" sync_supported=" <> strEncode ratchetSyncSupported)
strEncode ConnectionStats {rcvServers, sndServers} =
"rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
strP = do
connAgentVersion <- "agent_version=" *> strP
rcvQueuesInfo <- " rcv=" *> strListP
sndQueuesInfo <- " snd=" *> strListP
ratchetSyncState <- " sync=" *> strP
ratchetSyncSupported <- " sync_supported=" *> strP
pure ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported}
rcvServers <- "rcv=" *> strListP
sndServers <- " snd=" *> strListP
pure ConnectionStats {rcvServers, sndServers}
instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
@@ -760,7 +610,7 @@ data SMPConfirmation = SMPConfirmation
data AgentMsgEnvelope
= AgentConfirmation
{ agentVersion :: Version,
e2eEncryption_ :: Maybe (E2ERatchetParams 'C.X448),
e2eEncryption :: Maybe (E2ERatchetParams 'C.X448),
encConnInfo :: ByteString
}
| AgentMsgEnvelope
@@ -772,29 +622,22 @@ data AgentMsgEnvelope
connReq :: ConnectionRequestUri 'CMInvitation,
connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,
}
| AgentRatchetKey
{ agentVersion :: Version,
e2eEncryption :: E2ERatchetParams 'C.X448,
info :: ByteString
}
deriving (Show)
instance Encoding AgentMsgEnvelope where
smpEncode = \case
AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} ->
smpEncode (agentVersion, 'C', e2eEncryption_, Tail encConnInfo)
AgentConfirmation {agentVersion, e2eEncryption, encConnInfo} ->
smpEncode (agentVersion, 'C', e2eEncryption, Tail encConnInfo)
AgentMsgEnvelope {agentVersion, encAgentMessage} ->
smpEncode (agentVersion, 'M', Tail encAgentMessage)
AgentInvitation {agentVersion, connReq, connInfo} ->
smpEncode (agentVersion, 'I', Large $ strEncode connReq, Tail connInfo)
AgentRatchetKey {agentVersion, e2eEncryption, info} ->
smpEncode (agentVersion, 'R', e2eEncryption, Tail info)
smpP = do
agentVersion <- smpP
smpP >>= \case
'C' -> do
(e2eEncryption_, Tail encConnInfo) <- smpP
pure AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo}
(e2eEncryption, Tail encConnInfo) <- smpP
pure AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}
'M' -> do
Tail encAgentMessage <- smpP
pure AgentMsgEnvelope {agentVersion, encAgentMessage}
@@ -802,21 +645,15 @@ instance Encoding AgentMsgEnvelope where
connReq <- strDecode . unLarge <$?> smpP
Tail connInfo <- smpP
pure AgentInvitation {agentVersion, connReq, connInfo}
'R' -> do
e2eEncryption <- smpP
Tail info <- smpP
pure AgentRatchetKey {agentVersion, e2eEncryption, info}
_ -> fail "bad AgentMsgEnvelope"
-- SMP agent message formats (after double ratchet decryption,
-- or in case of AgentInvitation - in plain text body)
-- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption
data AgentMessage
= AgentConnInfo ConnInfo
| -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It makes REPLY message unnecessary.
AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
| AgentRatchetInfo ByteString
| AgentMessage APrivHeader AMessage
deriving (Show)
@@ -824,20 +661,17 @@ instance Encoding AgentMessage where
smpEncode = \case
AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
AgentRatchetInfo info -> smpEncode ('R', Tail info)
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
smpP =
smpP >>= \case
'I' -> AgentConnInfo . unTail <$> smpP
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
'R' -> AgentRatchetInfo . unTail <$> smpP
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
data AgentMessageType
= AM_CONN_INFO
| AM_CONN_INFO_REPLY
| AM_RATCHET_INFO
| AM_HELLO_
| AM_REPLY_
| AM_A_MSG_
@@ -846,14 +680,12 @@ data AgentMessageType
| AM_QKEY_
| AM_QUSE_
| AM_QTEST_
| AM_EREADY_
deriving (Eq, Show)
instance Encoding AgentMessageType where
smpEncode = \case
AM_CONN_INFO -> "C"
AM_CONN_INFO_REPLY -> "D"
AM_RATCHET_INFO -> "S"
AM_HELLO_ -> "H"
AM_REPLY_ -> "R"
AM_A_MSG_ -> "M"
@@ -862,12 +694,10 @@ instance Encoding AgentMessageType where
AM_QKEY_ -> "QK"
AM_QUSE_ -> "QU"
AM_QTEST_ -> "QT"
AM_EREADY_ -> "E"
smpP =
A.anyChar >>= \case
'C' -> pure AM_CONN_INFO
'D' -> pure AM_CONN_INFO_REPLY
'S' -> pure AM_RATCHET_INFO
'H' -> pure AM_HELLO_
'R' -> pure AM_REPLY_
'M' -> pure AM_A_MSG_
@@ -879,14 +709,12 @@ instance Encoding AgentMessageType where
'U' -> pure AM_QUSE_
'T' -> pure AM_QTEST_
_ -> fail "bad AgentMessageType"
'E' -> pure AM_EREADY_
_ -> fail "bad AgentMessageType"
agentMessageType :: AgentMessage -> AgentMessageType
agentMessageType = \case
AgentConnInfo _ -> AM_CONN_INFO
AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
AgentRatchetInfo _ -> AM_RATCHET_INFO
AgentMessage _ aMsg -> case aMsg of
-- HELLO is used both in v1 and in v2, but differently.
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
@@ -901,7 +729,6 @@ agentMessageType = \case
QKEY _ -> AM_QKEY_
QUSE _ -> AM_QUSE_
QTEST _ -> AM_QTEST_
EREADY _ -> AM_EREADY_
data APrivHeader = APrivHeader
{ -- | sequential ID assigned by the sending agent
@@ -925,7 +752,6 @@ data AMsgType
| QKEY_
| QUSE_
| QTEST_
| EREADY_
deriving (Eq)
instance Encoding AMsgType where
@@ -938,7 +764,6 @@ instance Encoding AMsgType where
QKEY_ -> "QK"
QUSE_ -> "QU"
QTEST_ -> "QT"
EREADY_ -> "E"
smpP =
A.anyChar >>= \case
'H' -> pure HELLO_
@@ -952,7 +777,6 @@ instance Encoding AMsgType where
'U' -> pure QUSE_
'T' -> pure QTEST_
_ -> fail "bad AMsgType"
'E' -> pure EREADY_
_ -> fail "bad AMsgType"
-- | Messages sent between SMP agents once SMP queue is secured.
@@ -975,8 +799,6 @@ data AMessage
QUSE (L.NonEmpty (SndQAddr, Bool))
| -- sent by the sender to test new queues and to complete switching
QTEST (L.NonEmpty SndQAddr)
| -- ratchet re-synchronization is complete, with last decrypted sender message id (recipient's `last_external_snd_msg_id`)
EREADY Int64
deriving (Show)
type SndQAddr = (SMPServer, SMP.SenderId)
@@ -991,7 +813,6 @@ instance Encoding AMessage where
QKEY qs -> smpEncode (QKEY_, qs)
QUSE qs -> smpEncode (QUSE_, qs)
QTEST qs -> smpEncode (QTEST_, qs)
EREADY lastDecryptedMsgId -> smpEncode (EREADY_, lastDecryptedMsgId)
smpP =
smpP
>>= \case
@@ -1003,7 +824,6 @@ instance Encoding AMessage where
QKEY_ -> QKEY <$> smpP
QUSE_ -> QUSE <$> smpP
QTEST_ -> QTEST <$> smpP
EREADY_ -> EREADY <$> smpP
instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
strEncode = \case
@@ -1351,8 +1171,6 @@ data AgentErrorType
AGENT {agentErr :: SMPAgentError}
| -- | agent implementation or dependency errors
INTERNAL {internalErr :: String}
| -- | agent inactive
INACTIVE
deriving (Eq, Generic, Show, Exception)
instance ToJSON AgentErrorType where
@@ -1449,20 +1267,6 @@ instance ToJSON AgentCryptoError where
toJSON = J.genericToJSON $ sumTypeJSON id
toEncoding = J.genericToEncoding $ sumTypeJSON id
instance StrEncoding AgentCryptoError where
strP =
"DECRYPT_AES" $> DECRYPT_AES
<|> "DECRYPT_CB" $> DECRYPT_CB
<|> "RATCHET_HEADER" $> RATCHET_HEADER
<|> "RATCHET_EARLIER " *> (RATCHET_EARLIER <$> strP)
<|> "RATCHET_SKIPPED " *> (RATCHET_SKIPPED <$> strP)
strEncode = \case
DECRYPT_AES -> "DECRYPT_AES"
DECRYPT_CB -> "DECRYPT_CB"
RATCHET_HEADER -> "RATCHET_HEADER"
RATCHET_EARLIER n -> "RATCHET_EARLIER " <> strEncode n
RATCHET_SKIPPED n -> "RATCHET_SKIPPED " <> strEncode n
instance ToJSON SMPAgentError where
toJSON = J.genericToJSON $ sumTypeJSON id
toEncoding = J.genericToEncoding $ sumTypeJSON id
@@ -1481,7 +1285,6 @@ instance StrEncoding AgentErrorType where
<|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
<|> "AGENT " *> (AGENT <$> parseRead1)
<|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
<|> "INACTIVE" $> INACTIVE
where
textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
strEncode = \case
@@ -1497,7 +1300,6 @@ instance StrEncoding AgentErrorType where
AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
AGENT e -> "AGENT " <> bshow e
INTERNAL e -> "INTERNAL " <> bshow e
INACTIVE -> "INACTIVE"
where
text = encodeUtf8 . T.pack
@@ -1513,14 +1315,6 @@ instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU
cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
cryptoErrToSyncState = \case
DECRYPT_AES -> RSAllowed
DECRYPT_CB -> RSAllowed
RATCHET_HEADER -> RSRequired
RATCHET_EARLIER _ -> RSAllowed
RATCHET_SKIPPED _ -> RSRequired
-- | SMP agent command and response parser for commands passed via network (only parses binary length)
networkCommandP :: Parser ACmd
networkCommandP = commandP A.takeByteString
@@ -1550,7 +1344,6 @@ instance StrEncoding ACmdTag where
"DOWN" -> nt DOWN_
"UP" -> nt UP_
"SWITCH" -> ct SWITCH_
"RSYNC" -> ct RSYNC_
"SEND" -> t SEND_
"MID" -> ct MID_
"SENT" -> ct SENT_
@@ -1604,7 +1397,6 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
DOWN_ -> "DOWN"
UP_ -> "UP"
SWITCH_ -> "SWITCH"
RSYNC_ -> "RSYNC"
SEND_ -> "SEND"
MID_ -> "MID"
SENT_ -> "SENT"
@@ -1672,7 +1464,6 @@ commandP binaryP =
DOWN_ -> s (DOWN <$> strP_ <*> connections)
UP_ -> s (UP <$> strP_ <*> connections)
SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
MID_ -> s (MID <$> A.decimal)
SENT_ -> s (SENT <$> A.decimal)
MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
@@ -1731,7 +1522,6 @@ serializeCommand = \case
DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns]
UP srv conns -> B.unwords [s UP_, s srv, connections conns]
SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
MID mId -> s (MID_, Str $ bshow mId)
SENT mId -> s (SENT_, Str $ bshow mId)
+2 -2
View File
@@ -23,7 +23,7 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer, defaultTransportServerConfig)
import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
import Simplex.Messaging.Util (bshow)
import UnliftIO.Async (race_)
import qualified UnliftIO.Exception as E
@@ -48,7 +48,7 @@ runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile,
smpAgent _ = do
-- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
runTransportServer started tcpPort tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
runTransportServer started tcpPort tlsServerParams True $ \(h :: c) -> do
liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
c <- getAgentClient initServers
logConnection c True
+5 -76
View File
@@ -21,7 +21,6 @@ import Data.Kind (Type)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (isJust)
import Data.Time (UTCTime)
import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol
@@ -67,13 +66,12 @@ data RcvQueue = RcvQueue
sndId :: SMP.SenderId,
-- | queue status
status :: QueueStatus,
-- | database queue ID (within connection)
-- | database queue ID (within connection), can be Nothing for old queues
dbQueueId :: Int64,
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
primary :: Bool,
-- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
dbReplaceQueueId :: Maybe Int64,
rcvSwchStatus :: Maybe RcvSwitchStatus,
-- | SMP client version
smpClientVersion :: Version,
-- | credentials used in context of notifications
@@ -82,22 +80,6 @@ data RcvQueue = RcvQueue
}
deriving (Eq, Show)
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
canAbortRcvSwitch :: RcvQueue -> Bool
canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
where
canAbort = \case
RSSwitchStarted -> True
RSSendingQADD -> True
-- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
RSSendingQUSE -> False
-- if switch is in RSReceivedMessage status, aborting switch (deleting new queue)
-- will break the connection because the sender would have original queue deleted
RSReceivedMessage -> False
data ClientNtfCreds = ClientNtfCreds
{ -- | key pair to be used by the notification server to sign transmissions
ntfPublicKey :: NtfPublicVerifyKey,
@@ -125,22 +107,17 @@ data SndQueue = SndQueue
e2eDhSecret :: C.DhSecretX25519,
-- | queue status
status :: QueueStatus,
-- | database queue ID (within connection)
-- | database queue ID (within connection), can be Nothing for old queues
dbQueueId :: Int64,
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
primary :: Bool,
-- | ID of the queue this one is replacing
dbReplaceQueueId :: Maybe Int64,
sndSwchStatus :: Maybe SndSwitchStatus,
-- | SMP client version
smpClientVersion :: Version
}
deriving (Eq, Show)
sndQueueInfo :: SndQueue -> SndQueueInfo
sndQueueInfo SndQueue {server, sndSwchStatus} =
SndQueueInfo {sndServer = server, sndSwitchStatus = sndSwchStatus}
instance SMPQueue RcvQueue where
qServer RcvQueue {server} = server
{-# INLINE qServer #-}
@@ -178,20 +155,10 @@ findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
findRQ sAddr = find $ sameQAddress sAddr . sndAddress
{-# INLINE findRQ #-}
switchingRQ :: NonEmpty RcvQueue -> Maybe RcvQueue
switchingRQ = find $ isJust . rcvSwchStatus
{-# INLINE switchingRQ #-}
updatedQs :: SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
updatedQs q = L.map $ \q' -> if dbQId q == dbQId q' then q else q'
{-# INLINE updatedQs #-}
class SMPQueue q => SMPQueueRec q where
qUserId :: q -> UserId
qConnId :: q -> ConnId
queueId :: q -> QueueId
dbQId :: q -> Int64
dbReplaceQId :: q -> Maybe Int64
instance SMPQueueRec RcvQueue where
qUserId = userId
@@ -200,10 +167,6 @@ instance SMPQueueRec RcvQueue where
{-# INLINE qConnId #-}
queueId = rcvId
{-# INLINE queueId #-}
dbQId = dbQueueId
{-# INLINE dbQId #-}
dbReplaceQId = dbReplaceQueueId
{-# INLINE dbReplaceQId #-}
instance SMPQueueRec SndQueue where
qUserId = userId
@@ -212,10 +175,6 @@ instance SMPQueueRec SndQueue where
{-# INLINE qConnId #-}
queueId = sndId
{-# INLINE queueId #-}
dbQId = dbQueueId
{-# INLINE dbQId #-}
dbReplaceQId = dbReplaceQueueId
{-# INLINE dbReplaceQId #-}
-- * Connection types
@@ -243,22 +202,14 @@ deriving instance Eq (Connection d)
deriving instance Show (Connection d)
toConnData :: Connection d -> ConnData
toConnData = \case
connData :: Connection d -> ConnData
connData = \case
NewConnection cData -> cData
RcvConnection cData _ -> cData
SndConnection cData _ -> cData
DuplexConnection cData _ _ -> cData
ContactConnection cData _ -> cData
updateConnection :: ConnData -> Connection d -> Connection d
updateConnection cData = \case
NewConnection _ -> NewConnection cData
RcvConnection _ rq -> RcvConnection cData rq
SndConnection _ sq -> SndConnection cData sq
DuplexConnection _ rqs sqs -> DuplexConnection cData rqs sqs
ContactConnection _ rq -> ContactConnection cData rq
data SConnType :: ConnType -> Type where
SCNew :: SConnType CNew
SCRcv :: SConnType CRcv
@@ -301,25 +252,10 @@ data ConnData = ConnData
connAgentVersion :: Version,
enableNtfs :: Bool,
duplexHandshake :: Maybe Bool, -- added in agent protocol v2
lastExternalSndId :: PrevExternalSndId,
deleted :: Bool,
ratchetSyncState :: RatchetSyncState
deleted :: Bool
}
deriving (Eq, Show)
-- this function should be mirrored in the clients
ratchetSyncAllowed :: ConnData -> Bool
ratchetSyncAllowed cData@ConnData {ratchetSyncState} =
ratchetSyncSupported' cData && (ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]))
ratchetSyncSupported' :: ConnData -> Bool
ratchetSyncSupported' ConnData {connAgentVersion} = connAgentVersion >= 3
-- this function should be mirrored in the clients
ratchetSyncSendProhibited :: ConnData -> Bool
ratchetSyncSendProhibited ConnData {ratchetSyncState} =
ratchetSyncState `elem` ([RSRequired, RSStarted, RSAgreed] :: [RatchetSyncState])
data PendingCommand = PendingCommand
{ corrId :: ACorrId,
userId :: UserId,
@@ -372,7 +308,6 @@ data InternalCommand
| ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
| ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
| ICDeleteConn
| ICDeleteRcvQueue SMP.RecipientId
| ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
| ICQDelete SMP.RecipientId
@@ -382,7 +317,6 @@ data InternalCommandTag
| ICAllowSecure_
| ICDuplexSecure_
| ICDeleteConn_
| ICDeleteRcvQueue_
| ICQSecure_
| ICQDelete_
deriving (Show)
@@ -394,7 +328,6 @@ instance StrEncoding InternalCommand where
ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
ICDeleteConn -> strEncode ICDeleteConn_
ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId)
ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
ICQDelete rId -> strEncode (ICQDelete_, rId)
strP =
@@ -404,7 +337,6 @@ instance StrEncoding InternalCommand where
ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
ICDeleteConn_ -> pure ICDeleteConn
ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP
ICQSecure_ -> ICQSecure <$> _strP <*> _strP
ICQDelete_ -> ICQDelete <$> _strP
@@ -415,7 +347,6 @@ instance StrEncoding InternalCommandTag where
ICAllowSecure_ -> "ALLOW_SECURE"
ICDuplexSecure_ -> "DUPLEX_SECURE"
ICDeleteConn_ -> "DELETE_CONN"
ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE"
ICQSecure_ -> "QSECURE"
ICQDelete_ -> "QDELETE"
strP =
@@ -425,7 +356,6 @@ instance StrEncoding InternalCommandTag where
"ALLOW_SECURE" -> pure ICAllowSecure_
"DUPLEX_SECURE" -> pure ICDuplexSecure_
"DELETE_CONN" -> pure ICDeleteConn_
"DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_
"QSECURE" -> pure ICQSecure_
"QDELETE" -> pure ICQDelete_
_ -> fail "bad InternalCommandTag"
@@ -442,7 +372,6 @@ internalCmdTag = \case
ICAllowSecure {} -> ICAllowSecure_
ICDuplexSecure {} -> ICDuplexSecure_
ICDeleteConn -> ICDeleteConn_
ICDeleteRcvQueue {} -> ICDeleteRcvQueue_
ICQSecure {} -> ICQSecure_
ICQDelete _ -> ICQDelete_
+95 -204
View File
@@ -52,26 +52,16 @@ module Simplex.Messaging.Agent.Store.SQLite
getDeletedConns,
getConnData,
setConnDeleted,
setConnAgentVersion,
getDeletedConnIds,
setConnRatchetSync,
addProcessedRatchetKeyHash,
checkProcessedRatchetKeyHashExists,
deleteProcessedRatchetKeyHashesExpired,
getRcvConn,
getRcvQueueById,
getSndQueueById,
deleteConn,
upgradeRcvConnToDuplex,
upgradeSndConnToDuplex,
addConnRcvQueue,
addConnSndQueue,
setRcvQueueStatus,
setRcvSwitchStatus,
setRcvQueueDeleted,
setRcvQueueConfirmedE2E,
setSndQueueStatus,
setSndSwitchStatus,
setRcvQueuePrimary,
setSndQueuePrimary,
deleteConnRcvQueue,
@@ -79,7 +69,6 @@ module Simplex.Messaging.Agent.Store.SQLite
deleteConnSndQueue,
getPrimaryRcvQueue,
getRcvQueue,
getDeletedRcvQueue,
setRcvQueueNtfCreds,
-- Confirmations
createConfirmation,
@@ -112,11 +101,7 @@ module Simplex.Messaging.Agent.Store.SQLite
-- Double ratchet persistence
createRatchetX3dhKeys,
getRatchetX3dhKeys,
createRatchetX3dhKeys',
getRatchetX3dhKeys',
setRatchetX3dhKeys,
createRatchet,
deleteRatchet,
getRatchet,
getSkippedMsgKeys,
updateRatchet,
@@ -206,6 +191,7 @@ module Simplex.Messaging.Agent.Store.SQLite
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (stateTVar)
import Control.Monad.Except
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
@@ -216,10 +202,11 @@ import Data.Bifunctor (second)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as U
import Data.Char (toLower)
import Data.Function (on)
import Data.Functor (($>))
import Data.IORef
import Data.Int (Int64)
import Data.List (foldl', intercalate, sortBy)
import Data.List (foldl', groupBy, intercalate, sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
@@ -228,7 +215,7 @@ import Data.Ord (Down (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Word (Word32)
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
import qualified Database.SQLite.Simple as DB
@@ -245,7 +232,6 @@ import Simplex.FileTransfer.Types
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite.Common
import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRError, Migration (..), MigrationsToRun (..), mtrErrorDescription)
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
@@ -258,18 +244,25 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
import Simplex.Messaging.Protocol
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ($>>=), (<$$>))
import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, ($>>=), (<$$>))
import Simplex.Messaging.Version
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory)
import System.IO (hFlush, stdout)
import UnliftIO.Exception (onException)
import UnliftIO.Exception (bracket, onException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
-- * SQLite Store implementation
data SQLiteStore = SQLiteStore
{ dbFilePath :: FilePath,
dbEncrypted :: TVar Bool,
dbConnection :: TMVar DB.Connection,
dbNew :: Bool
}
data MigrationError
= MEUpgrade {upMigrations :: [UpMigration]}
| MEDowngrade {downMigrations :: [String]}
@@ -326,35 +319,35 @@ createSQLiteStore dbFilePath dbKey migrations confirmMigrations = do
Left e -> closeSQLiteStore st $> Left e
migrateSchema :: SQLiteStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
migrateSchema st migrations confirmMigrations = do
Migrations.initialize st
Migrations.get st migrations >>= \case
migrateSchema st migrations confirmMigrations = withConnection st $ \db -> do
Migrations.initialize db
Migrations.get db migrations >>= \case
Left e -> do
when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
pure . Left $ MigrationError e
Right MTRNone -> pure $ Right ()
Right ms@(MTRUp ums)
| dbNew st -> Migrations.run st ms $> Right ()
| dbNew st -> Migrations.run db ms $> Right ()
| otherwise -> case confirmMigrations of
MCYesUp -> run ms
MCYesUpDown -> run ms
MCConsole -> confirm err >> run ms
MCYesUp -> run db ms
MCYesUpDown -> run db ms
MCConsole -> confirm err >> run db ms
MCError -> pure $ Left err
where
err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
Right ms@(MTRDown dms) -> case confirmMigrations of
MCYesUpDown -> run ms
MCConsole -> confirm err >> run ms
MCYesUpDown -> run db ms
MCConsole -> confirm err >> run db ms
MCYesUp -> pure $ Left err
MCError -> pure $ Left err
where
err = MEDowngrade $ map downName dms
where
confirm err = confirmOrExit $ migrationErrorDescription err
run ms = do
run db ms = do
let f = dbFilePath st
copyFile f (f <> ".bak")
Migrations.run st ms
Migrations.run db ms
pure $ Right ()
confirmOrExit :: String -> IO ()
@@ -368,10 +361,9 @@ confirmOrExit s = do
connectSQLiteStore :: FilePath -> String -> IO SQLiteStore
connectSQLiteStore dbFilePath dbKey = do
dbNew <- not <$> doesFileExist dbFilePath
dbConn <- dbBusyLoop $ connectDB dbFilePath dbKey
dbConnVar <- newTMVarIO dbConn
dbConnection <- newTMVarIO =<< connectDB dbFilePath dbKey
dbEncrypted <- newTVarIO . not $ null dbKey
pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection = dbConnVar, dbNew}
pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew}
connectDB :: FilePath -> String -> IO DB.Connection
connectDB path key = do
@@ -383,11 +375,13 @@ connectDB path key = do
prepare db = do
let exec = SQLite3.exec $ DB.connectionHandle db
unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
exec "PRAGMA busy_timeout = 100;"
exec "PRAGMA foreign_keys = ON;"
-- exec "PRAGMA trusted_schema = OFF;"
exec "PRAGMA secure_delete = ON;"
exec "PRAGMA auto_vacuum = FULL;"
exec . fromQuery $
[sql|
PRAGMA foreign_keys = ON;
-- PRAGMA trusted_schema = OFF;
PRAGMA secure_delete = ON;
PRAGMA auto_vacuum = FULL;
|]
closeSQLiteStore :: SQLiteStore -> IO ()
closeSQLiteStore st = atomically (takeTMVar $ dbConnection st) >>= DB.close
@@ -430,6 +424,37 @@ handleSQLError err e
| DB.sqlError e == DB.ErrorConstraint = err
| otherwise = SEInternal $ bshow e
withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
withConnection SQLiteStore {dbConnection} =
bracket
(atomically $ takeTMVar dbConnection)
(atomically . putTMVar dbConnection)
withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransaction = withTransactionCtx Nothing
withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransactionCtx ctx_ st action = withConnection st $ loop 500 3_000_000
where
loop :: Int -> Int -> DB.Connection -> IO a
loop t tLim db =
transactionWithCtx `E.catch` \(e :: SQLError) ->
if tLim > t && DB.sqlError e == DB.ErrorBusy
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t) db
else E.throwIO e
where
transactionWithCtx = case ctx_ of
Nothing -> DB.withImmediateTransaction db (action db)
Just ctx -> do
t1 <- getCurrentTime
r <- DB.withImmediateTransaction db (action db)
t2 <- getCurrentTime
putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
putStrLn $ "withTransactionCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
pure r
createUserRecord :: DB.Connection -> IO UserId
createUserRecord db = do
DB.execute_ db "INSERT INTO users DEFAULT VALUES"
@@ -536,7 +561,7 @@ getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreE
getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
rq@RcvQueue {connId} <-
ExceptT . firstRow toRcvQueue SEConnNotFound $
DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId)
DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?") (host, port, rcvId)
(rq,) <$> ExceptT (getConn db connId)
deleteConn :: DB.Connection -> ConnId -> IO ()
@@ -595,29 +620,6 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
|]
[":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do
DB.execute
db
[sql|
UPDATE rcv_queues
SET switch_status = ?
WHERE host = ? AND port = ? AND rcv_id = ?
|]
(rcvSwchStatus, host, port, rcvId)
pure rq {rcvSwchStatus}
setRcvQueueDeleted :: DB.Connection -> RcvQueue -> IO ()
setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = do
DB.execute
db
[sql|
UPDATE rcv_queues
SET deleted = 1
WHERE host = ? AND port = ? AND rcv_id = ?
|]
(host, port, rcvId)
setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
DB.executeNamed
@@ -649,18 +651,6 @@ setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} stat
|]
[":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue
setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do
DB.execute
db
[sql|
UPDATE snd_queues
SET switch_status = ?
WHERE host = ? AND port = ? AND snd_id = ?
|]
(sndSwchStatus, host, port, sndId)
pure sq {sndSwchStatus}
setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO ()
setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do
DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId)
@@ -697,12 +687,7 @@ getPrimaryRcvQueue db connId =
getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
getRcvQueue db connId (SMPServer host port _) rcvId =
firstRow toRcvQueue SEConnNotFound $
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId)
getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
getDeletedRcvQueue db connId (SMPServer host port _) rcvId =
firstRow toRcvQueue SEConnNotFound $
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId)
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ?") (connId, host, port, rcvId)
setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO ()
setRcvQueueNtfCreds db connId clientNtfCreds =
@@ -933,7 +918,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do
(dbRcvId, srvMsgId) <-
ExceptT . firstRow id SEMsgNotFound $
DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
rq <- ExceptT $ getRcvQueueById db connId dbRcvId
rq <- ExceptT $ getRcvQueueById_ db connId dbRcvId
pure (rq, srvMsgId)
getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
@@ -999,35 +984,6 @@ getRatchetX3dhKeys db connId =
Right (Just k1, Just k2) -> Right (k1, k2)
_ -> Left SEX3dhKeysNotFound
createRatchetX3dhKeys' :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
createRatchetX3dhKeys' db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
DB.execute
db
"INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2) VALUES (?,?,?,?,?)"
(connId, x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2)
getRatchetX3dhKeys' :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448))
getRatchetX3dhKeys' db connId =
fmap hasKeys $
firstRow id SEX3dhKeysNotFound $
DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
where
hasKeys = \case
Right (Just pk1, Just pk2, Just k1, Just k2) -> Right (pk1, pk2, k1, k2)
_ -> Left SEX3dhKeysNotFound
-- used to remember new keys when starting ratchet re-synchronization
setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
DB.execute
db
[sql|
UPDATE ratchets
SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?
WHERE conn_id = ?
|]
(x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2, connId)
createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO ()
createRatchet db connId rc =
DB.executeNamed
@@ -1038,16 +994,10 @@ createRatchet db connId rc =
ON CONFLICT (conn_id) DO UPDATE SET
ratchet_state = :ratchet_state,
x3dh_priv_key_1 = NULL,
x3dh_priv_key_2 = NULL,
x3dh_pub_key_1 = NULL,
x3dh_pub_key_2 = NULL
x3dh_priv_key_2 = NULL
|]
[":conn_id" := connId, ":ratchet_state" := rc]
deleteRatchet :: DB.Connection -> ConnId -> IO ()
deleteRatchet db connId =
DB.execute db "DELETE FROM ratchets WHERE conn_id = ?" (Only connId)
getRatchet :: DB.Connection -> ConnId -> IO (Either StoreError RatchetX448)
getRatchet db connId =
firstRow' ratchet SERatchetNotFound $ DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId)
@@ -1096,9 +1046,7 @@ insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
getPendingCommands :: DB.Connection -> ConnId -> IO [(Maybe SMPServer, [AsyncCmdId])]
getPendingCommands db connId = do
-- `groupOn` is used instead of `groupAllOn` to avoid extra sorting by `server + cmdId`, as the query already sorts by them.
-- TODO review whether this can break if, e.g., the server has another key hash.
map (\ids -> (fst $ head ids, map snd ids)) . groupOn fst . map srvCmdId
map (\ids -> (fst $ head ids, map snd ids)) . groupBy ((==) `on` fst) . map srvCmdId
<$> DB.query
db
[sql|
@@ -1427,7 +1375,7 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId}
[sql|
SELECT conn_id, rcv_ntf_dh_secret
FROM rcv_queues
WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
WHERE host = ? AND port = ? AND ntf_id = ?
|]
(host, port, notifierId)
where
@@ -1648,61 +1596,22 @@ getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAn
handleDBError = pure . Left . SEInternal . bshow
getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
getConnData db connId' =
maybeFirstRow cData $
DB.query
db
[sql|
SELECT
user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake,
last_external_snd_msg_id, deleted, ratchet_sync_state
FROM connections
WHERE conn_id = ?
|]
(Only connId')
getConnData dbConn connId' =
maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
where
cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState) =
(ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState}, cMode)
cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode)
setConnDeleted :: DB.Connection -> ConnId -> IO ()
setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
setConnAgentVersion :: DB.Connection -> ConnId -> Version -> IO ()
setConnAgentVersion db connId aVersion =
DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
getDeletedConnIds :: DB.Connection -> IO [ConnId]
getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync db connId ratchetSyncState =
DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO ()
addProcessedRatchetKeyHash db connId hash =
DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash)
checkProcessedRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
checkProcessedRatchetKeyHashExists db connId hash = do
fromMaybe False
<$> maybeFirstRow
fromOnly
( DB.query
db
"SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
(connId, hash)
)
deleteProcessedRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
deleteProcessedRatchetKeyHashesExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs)
-- | returns all connection queues, the first queue is the primary one
getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
getRcvQueuesByConnId_ db connId =
L.nonEmpty . sortBy primaryFirst . map toRcvQueue
<$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
<$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
where
primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
-- the current primary queue is ordered first, the next primary - second
@@ -1713,7 +1622,7 @@ rcvQueueQuery =
[sql|
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors,
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
FROM rcv_queues q
JOIN servers s ON q.host = s.host AND q.port = s.port
@@ -1722,62 +1631,44 @@ rcvQueueQuery =
toRcvQueue ::
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
:. (Int64, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
:. (Int64, Bool, Maybe Int64, Maybe Version, Int)
:. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
RcvQueue
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
let server = SMPServer host port keyHash
smpClientVersion = fromMaybe 1 smpClientVersion_
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
_ -> Nothing
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds, deleteErrors}
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
getRcvQueueById db connId dbRcvId =
getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
getRcvQueueById_ db connId dbRcvId =
firstRow toRcvQueue SEConnNotFound $
DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ? AND q.deleted = 0") (connId, dbRcvId)
DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ?") (connId, dbRcvId)
-- | returns all connection queues, the first queue is the primary one
getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue))
getSndQueuesByConnId_ dbConn connId =
L.nonEmpty . sortBy primaryFirst . map toSndQueue
<$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
L.nonEmpty . sortBy primaryFirst . map sndQueue
<$> DB.query
dbConn
[sql|
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
FROM snd_queues q
JOIN servers s ON q.host = s.host AND q.port = s.port
JOIN connections c ON q.conn_id = c.conn_id
WHERE q.conn_id = ?;
|]
(Only connId)
where
sndQueue ((userId, keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
let server = SMPServer host port keyHash
in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion}
primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
-- the current primary queue is ordered first, the next primary - second
compare (Down p) (Down p') <> compare i i'
sndQueueQuery :: Query
sndQueueQuery =
[sql|
SELECT
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id,
q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
FROM snd_queues q
JOIN servers s ON q.host = s.host AND q.port = s.port
JOIN connections c ON q.conn_id = c.conn_id
|]
toSndQueue ::
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
:. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
:. (Int64, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
SndQueue
toSndQueue
( (userId, keyHash, connId, host, port, sndId)
:. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
:. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
) =
let server = SMPServer host port keyHash
in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
getSndQueueById db connId dbSndId =
firstRow toSndQueue SEConnNotFound $
DB.query db (sndQueueQuery <> " WHERE q.conn_id = ? AND q.snd_queue_id = ?") (connId, dbSndId)
-- * updateRcvIds helpers
retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
@@ -1,61 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Agent.Store.SQLite.Common
( SQLiteStore (..),
withConnection,
withTransaction,
withTransactionCtx,
dbBusyLoop,
)
where
import Control.Concurrent (threadDelay)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Database.SQLite.Simple (SQLError)
import qualified Database.SQLite.Simple as DB
import Simplex.Messaging.Util (diffToMilliseconds)
import UnliftIO.Exception (bracket)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
data SQLiteStore = SQLiteStore
{ dbFilePath :: FilePath,
dbEncrypted :: TVar Bool,
dbConnection :: TMVar DB.Connection,
dbNew :: Bool
}
withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
withConnection SQLiteStore {dbConnection} =
bracket
(atomically $ takeTMVar dbConnection)
(atomically . putTMVar dbConnection)
withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransaction = withTransactionCtx Nothing
withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransactionCtx ctx_ st action = withConnection st $ \db -> dbBusyLoop (transactionWithCtx db)
where
transactionWithCtx db = case ctx_ of
Nothing -> DB.withImmediateTransaction db (action db)
Just ctx -> do
t1 <- getCurrentTime
r <- DB.withImmediateTransaction db (action db)
t2 <- getCurrentTime
putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
putStrLn $ "withTransactionCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
pure r
dbBusyLoop :: forall a. IO a -> IO a
dbBusyLoop action = loop 500 3000000
where
loop :: Int -> Int -> IO a
loop t tLim =
action `E.catch` \(e :: SQLError) ->
if tLim > t && DB.sqlError e == DB.ErrorBusy
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t)
else E.throwIO e
@@ -42,7 +42,6 @@ import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import GHC.Generics (Generic)
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
import Simplex.Messaging.Agent.Store.SQLite.Common
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
@@ -61,8 +60,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -89,9 +86,7 @@ schemaMigrations =
("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync)
("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes)
]
-- | The list of migrations in ascending order by date
@@ -100,42 +95,44 @@ app = sortOn name $ map migration schemaMigrations
where
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
get :: SQLiteStore -> [Migration] -> IO (Either MTRError MigrationsToRun)
get st migrations = migrationsToRun migrations <$> withTransaction st getCurrent
get :: Connection -> [Migration] -> IO (Either MTRError MigrationsToRun)
get db migrations = migrationsToRun migrations <$> getCurrent db
getCurrent :: Connection -> IO [Migration]
getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
where
toMigration (name, down) = Migration {name, up = "", down}
run :: SQLiteStore -> MigrationsToRun -> IO ()
run st = \case
run :: Connection -> MigrationsToRun -> IO ()
run db = \case
MTRUp [] -> pure ()
MTRUp ms -> mapM_ runUp ms >> withConnection st (`execSQL` "VACUUM;")
MTRUp ms -> mapM_ runUp ms >> execSQL "VACUUM;"
MTRDown ms -> mapM_ runDown $ reverse ms
MTRNone -> pure ()
where
runUp Migration {name, up, down} = withTransaction st $ \db -> do
when (name == "m20220811_onion_hosts") $ updateServers db
insert db >> execSQL db up
runUp Migration {name, up, down} = do
when (name == "m20220811_onion_hosts") updateServers
DB.withImmediateTransaction db $ insert >> execSQL up
where
insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
runDown DownMigration {downName, downQuery} = withTransaction st $ \db -> do
execSQL db downQuery
DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
execSQL db = SQLite3.exec $ DB.connectionHandle db
insert = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
DB.withImmediateTransaction db $
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
runDown DownMigration {downName, downQuery} = do
DB.withImmediateTransaction db $ do
execSQL downQuery
DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
execSQL = SQLite3.exec $ DB.connectionHandle db
initialize :: SQLiteStore -> IO ()
initialize st = withTransaction st $ \db -> do
initialize :: Connection -> IO ()
initialize db = do
cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')"
case cs of
[] -> createMigrations db
[] -> createMigrations
_ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
where
createMigrations db =
createMigrations =
DB.execute_
db
[sql|
@@ -1,22 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230531_switch_status :: Query
m20230531_switch_status =
[sql|
ALTER TABLE rcv_queues ADD COLUMN switch_status TEXT;
ALTER TABLE rcv_queues ADD COLUMN deleted INTEGER NOT NULL DEFAULT 0;
ALTER TABLE snd_queues ADD COLUMN switch_status TEXT;
|]
down_m20230531_switch_status :: Query
down_m20230531_switch_status =
[sql|
ALTER TABLE snd_queues DROP COLUMN switch_status;
ALTER TABLE rcv_queues DROP COLUMN deleted;
ALTER TABLE rcv_queues DROP COLUMN switch_status;
|]
@@ -1,41 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
-- Ratchet public keys are saved when ratchet re-synchronization is started - upon receiving other party's public keys,
-- keys are compared to determine ratchet initialization ordering for both parties.
-- This solves a possible race when both parties start ratchet re-synchronization at the same time.
m20230615_ratchet_sync :: Query
m20230615_ratchet_sync =
[sql|
ALTER TABLE connections ADD COLUMN ratchet_sync_state TEXT NOT NULL DEFAULT 'ok';
ALTER TABLE ratchets ADD COLUMN x3dh_pub_key_1 BLOB;
ALTER TABLE ratchets ADD COLUMN x3dh_pub_key_2 BLOB;
CREATE TABLE processed_ratchet_key_hashes(
processed_ratchet_key_hash_id INTEGER PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
hash BLOB NOT NULL,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|]
down_m20230615_ratchet_sync :: Query
down_m20230615_ratchet_sync =
[sql|
DROP INDEX idx_processed_ratchet_key_hashes_hash;
DROP TABLE processed_ratchet_key_hashes;
ALTER TABLE ratchets DROP COLUMN x3dh_pub_key_2;
ALTER TABLE ratchets DROP COLUMN x3dh_pub_key_1;
ALTER TABLE connections DROP COLUMN ratchet_sync_state;
|]
@@ -25,8 +25,7 @@ CREATE TABLE connections(
enable_ntfs INTEGER,
deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
user_id INTEGER CHECK(user_id NOT NULL)
REFERENCES users ON DELETE CASCADE,
ratchet_sync_state TEXT NOT NULL DEFAULT 'ok'
REFERENCES users ON DELETE CASCADE
) WITHOUT ROWID;
CREATE TABLE rcv_queues(
host TEXT NOT NULL,
@@ -51,8 +50,6 @@ CREATE TABLE rcv_queues(
replace_rcv_queue_id INTEGER NULL,
delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL),
server_key_hash BLOB,
switch_status TEXT,
deleted INTEGER NOT NULL DEFAULT 0,
PRIMARY KEY(host, port, rcv_id),
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -74,7 +71,6 @@ CREATE TABLE snd_queues(
snd_primary INTEGER CHECK(snd_primary NOT NULL),
replace_snd_queue_id INTEGER NULL,
server_key_hash BLOB,
switch_status TEXT,
PRIMARY KEY(host, port, snd_id),
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE
@@ -155,9 +151,6 @@ CREATE TABLE ratchets(
-- ratchet is initially empty on the receiving side(the side offering the connection)
ratchet_state BLOB,
e2e_version INTEGER NOT NULL DEFAULT 1
,
x3dh_pub_key_1 BLOB,
x3dh_pub_key_2 BLOB
) WITHOUT ROWID;
CREATE TABLE skipped_messages(
skipped_message_id INTEGER PRIMARY KEY,
@@ -360,13 +353,6 @@ CREATE TABLE encrypted_rcv_message_hashes(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE processed_ratchet_key_hashes(
processed_ratchet_key_hash_id INTEGER PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
hash BLOB NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
@@ -457,7 +443,3 @@ CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hash
conn_id,
hash
);
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
conn_id,
hash
);
+23 -71
View File
@@ -11,7 +11,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-}
-- |
-- Module : Simplex.Messaging.Client
@@ -42,7 +41,6 @@ module Simplex.Messaging.Client
subscribeSMPQueues,
getSMPMessage,
subscribeSMPQueueNotifications,
subscribeSMPQueuesNtfs,
secureSMPQueue,
enableSMPQueueNotifications,
disableSMPQueueNotifications,
@@ -83,11 +81,10 @@ import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (rights)
import Data.Foldable (foldl')
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Time.Clock (UTCTime, getCurrentTime)
@@ -116,9 +113,6 @@ data ProtocolClient err msg = ProtocolClient
sessionId :: SessionId,
sessionTs :: UTCTime,
thVersion :: Version,
timeoutPerBlock :: Int,
blockSize :: Int,
batch :: Bool,
client_ :: PClient err msg
}
@@ -127,7 +121,6 @@ data PClient err msg = PClient
transportSession :: TransportSession msg,
transportHost :: TransportHost,
tcpTimeout :: Int,
batchDelay :: Maybe Int,
pingErrorCount :: TVar Int,
clientCorrId :: TVar Natural,
sentCommands :: TMap CorrId (Request err msg),
@@ -174,8 +167,6 @@ data NetworkConfig = NetworkConfig
tcpConnectTimeout :: Int,
-- | timeout of protocol commands (microseconds)
tcpTimeout :: Int,
-- | additional timeout per kilobyte (1024 bytes) to be sent
tcpTimeoutPerKb :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds, 0 to disable)
@@ -207,9 +198,8 @@ defaultNetworkConfig =
hostMode = HMOnionViaSocks,
requiredHostMode = False,
sessionMode = TSMUser,
tcpConnectTimeout = 15_000_000,
tcpTimeout = 10_000_000,
tcpTimeoutPerKb = 20_000, -- 20ms, should be less than 130ms to avoid Int overflow on 32 bit systems
tcpConnectTimeout = 7_500_000,
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPingInterval = 600_000_000, -- 10min
smpPingCount = 3,
@@ -228,10 +218,8 @@ data ProtocolClientConfig = ProtocolClientConfig
defaultTransport :: (ServiceName, ATransport),
-- | network configuration
networkConfig :: NetworkConfig,
-- | client-server protocol version range
serverVRange :: VersionRange,
-- | delay between sending batches of commands (microseconds)
batchDelay :: Maybe Int
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
}
-- | Default protocol client configuration.
@@ -241,8 +229,7 @@ defaultClientConfig =
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
serverVRange = supportedSMPServerVRange,
batchDelay = Nothing
smpServerVRange = supportedSMPServerVRange
}
data Request err msg = Request
@@ -288,14 +275,14 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e
where
NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb, smpPingInterval} = networkConfig
NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> STM (PClient err msg)
mkProtocolClient transportHost = do
connected <- newTVar False
@@ -310,7 +297,6 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
transportSession,
transportHost,
tcpTimeout,
batchDelay,
pingErrorCount,
clientCorrId,
sentCommands,
@@ -342,12 +328,11 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
client _ c cVar h =
runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
runExceptT (protocolClientHandshake @err @msg h (keyHash srv) smpServerVRange) >>= \case
Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
Right th@THandle {sessionId, thVersion, blockSize, batch} -> do
Right th@THandle {sessionId, thVersion} -> do
sessionTs <- getCurrentTime
let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024
c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch}
let c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs}
atomically $ do
writeTVar (connected c) True
putTMVar cVar $ Right c'
@@ -355,7 +340,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
`finally` disconnected c'
send :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h batchDelay
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
@@ -502,10 +487,6 @@ getSMPMessage c rpKey rId =
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
subscribeSMPQueueNotifications = okSMPCommand NSUB
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
subscribeSMPQueuesNtfs = okSMPCommands NSUB
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
@@ -597,61 +578,32 @@ okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
type PCTransmission err msg = (SentRawTransmission, TMVar (Response err msg))
-- | Send multiple commands with batching and collect responses
-- It will result in Int overflow on 32 bit platform for a large number of blocks (~13.4k blocks / ~1.2m subscriptions)
-- TODO switch to timeout or TimeManager that supports Int64
sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either (ProtocolClientError err) msg))
sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout, batchDelay}, batch, blockSize, timeoutPerBlock} cs = do
(h :| ts) <- mapM (runExceptT . mkTransmission c) cs
let h' :: Either (ProtocolClientError err) (PCTransmission err msg, Int) = (,timeoutPerBlock) <$> h
batchSz = if batch then either (const 0) tSize h else 0
ts' :: NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)) =
L.reverse . fst3 $ foldl' batchTimeouts ([h'], timeoutPerBlock, batchSz) ts
ts_ :: (Maybe (NonEmpty SentRawTransmission)) =
L.nonEmpty . map (fst . fst) . rights $ L.toList ts'
mapM_ (atomically . writeTBQueue sndQ) ts_
forConcurrently ts' $ \case
Right ((_t, r), bt) -> withTimeout c (tcpTimeout + bt) (atomically $ takeTMVar r)
sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ}} cs = do
ts <- mapM (runExceptT . mkTransmission c) cs
mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
forConcurrently ts $ \case
Right (_, r) -> withTimeout c $ atomically $ takeTMVar r
Left e -> pure $ Left e
where
fst3 (x, _, _) = x
-- tSize calculation matches the batching logic in tPut that does actual breaking of transmissions into blocks
tSize :: PCTransmission err msg -> Int
tSize ((sig, t), _) = maybe 0 C.signatureSize sig + B.length t + 3 -- 1 byte for signature size + 2 bytes for transmission size
batchTimeouts :: (NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)), Int, Int) -> Either (ProtocolClientError err) (PCTransmission err msg) -> (NonEmpty (Either (ProtocolClientError err) (PCTransmission err msg, Int)), Int, Int)
batchTimeouts (ts, bt, batchSz) = \case
Left e -> (Left e <| ts, bt, batchSz)
Right t
| not batch ->
(Right (t, bt') <| ts, bt', 0)
| batchSz' + 1 > blockSize ->
(Right (t, bt') <| ts, bt', tSz)
| otherwise -> -- same block in the batch
(Right (t, bt) <| ts, bt, batchSz') -- 1 byte for the number of transmissions in the batch
where
batchSz' = batchSz + tSz
bt' = bt + timeoutPerBlock + fromMaybe 0 batchDelay
tSz = tSize t
-- | Send Protocol command
sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey qId cmd = do
sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}} pKey qId cmd = do
(t, r) <- mkTransmission c (pKey, qId, cmd)
ExceptT $ sendRecv t r
where
-- two separate "atomically" needed to avoid blocking
sendRecv :: SentRawTransmission -> TMVar (Response err msg) -> IO (Response err msg)
sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c tcpTimeout (atomically $ takeTMVar r)
sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r)
withTimeout :: ProtocolClient err msg -> Int -> IO (Either (ProtocolClientError err) msg) -> IO (Either (ProtocolClientError err) msg)
withTimeout ProtocolClient {client_ = PClient {pingErrorCount}} t a = do
timeout t a >>= \case
withTimeout :: ProtocolClient err msg -> IO (Either (ProtocolClientError err) msg) -> IO (Either (ProtocolClientError err) msg)
withTimeout ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} a =
timeout tcpTimeout a >>= \case
Just r -> atomically (writeTVar pingErrorCount 0) >> pure r
_ -> pure $ Left PCEResponseTimeout
mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> ExceptT (ProtocolClientError err) IO (PCTransmission err msg)
mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> ExceptT (ProtocolClientError err) IO (SentRawTransmission, TMVar (Response err msg))
mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do
corrId <- liftIO $ atomically getNextCorrId
let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
+28 -77
View File
@@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -17,31 +16,24 @@ import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.Bifunctor (first, bimap)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import Data.Text.Encoding
import Data.Tuple (swap)
import Numeric.Natural
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer, NtfPrivateSignKey, NotifierId, RcvPrivateSignKey, RecipientId)
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_, tryE, ($>>=), toChunks)
import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO (async, forConcurrently_)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
@@ -52,8 +44,8 @@ data SMPClientAgentEvent
= CAConnected SMPServer
| CADisconnected SMPServer (Set SMPSub)
| CAReconnected SMPServer
| CAResubscribed SMPServer (NonEmpty SMPSub)
| CASubError SMPServer (NonEmpty (SMPSub, SMPClientError))
| CAResubscribed SMPServer SMPSub
| CASubError SMPServer SMPSub SMPClientError
data SMPSubParty = SPRecipient | SPNotifier
deriving (Eq, Ord, Show)
@@ -66,8 +58,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
{ smpCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
msgQSize :: Natural,
agentQSize :: Natural,
agentSubsBatchSize :: Int
agentQSize :: Natural
}
defaultSMPClientAgentConfig :: SMPClientAgentConfig
@@ -80,9 +71,8 @@ defaultSMPClientAgentConfig =
increaseAfter = 10 * second,
maxInterval = 10 * second
},
msgQSize = 256,
agentQSize = 256,
agentSubsBatchSize = 900
msgQSize = 64,
agentQSize = 64
}
where
second = 1000000
@@ -194,9 +184,9 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
_ -> TM.insert srv sVar ps
serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
serverDown ss = unless (M.null ss) $ do
serverDown ss = unless (M.null ss) . void . runExceptT $ do
notify . CADisconnected srv $ M.keysSet ss
void $ runExceptT reconnectServer
reconnectServer
reconnectServer :: ExceptT SMPClientError IO ()
reconnectServer = do
@@ -211,37 +201,27 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
reconnectClient :: ExceptT SMPClientError IO ()
reconnectClient = do
withSMP ca srv $ \smp -> do
liftIO $ notify $ CAReconnected srv
cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forM_ cs_ $ \cs -> do
subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
subscribe_ smp SPNotifier nSubs
subscribe_ smp SPRecipient rSubs
notify $ CAReconnected srv
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
unlessM (atomically $ hasSub (srvSubs ca) srv s) $
subscribe_ smp sub `catchE` handleError s
where
isNotifier = \case
SPNotifier -> True
SPRecipient -> False
subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
subscribe_ smp sub@(s, _) = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
notify $ CAResubscribed srv s
subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO ()
subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
where
subscribeBatch subs' = do
let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs'
rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) =
L.zipWith (first . const) subs' rs
rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateSignKey)] =
map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
(errs, oks) = partitionEithers rs''
(tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
mapM_ (atomically . addSubscription ca srv) oks
mapM_ (liftIO . notify . CAResubscribed srv) $ L.nonEmpty $ map fst oks
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs
mapM_ (throwE . snd) $ listToMaybe tempErrs
handleError :: SMPSub -> SMPClientError -> ExceptT SMPClientError IO ()
handleError s = \case
e@PCEResponseTimeout -> throwE e
e@PCENetworkError -> throwE e
e -> do
notify $ CASubError srv s e
atomically $ removePendingSubscription ca srv s
notify :: SMPClientAgentEvent -> IO ()
notify :: SMPClientAgentEvent -> ExceptT SMPClientError IO ()
notify evt = atomically $ writeTBQueue (agentQ ca) evt
closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
@@ -283,35 +263,6 @@ subscribeQueue ca srv sub = do
removePendingSubscription ca srv $ fst sub
throwE e
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
subscribeQueuesSMP = subscribeQueues_ SPRecipient
subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
subscribeQueuesNtfs = subscribeQueues_ SPNotifier
subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
subscribeQueues_ party ca srv subs = do
atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,)
runExceptT (getSMPServerClient' ca srv) >>= \case
Left e -> pure $ L.map ((,Left e) . fst) subs
Right smp -> smpSubscribeQueues party ca smp srv subs
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
smpSubscribeQueues party ca smp srv subs = do
rs <- L.zip subs <$> subscribe smp (L.map swap subs)
atomically $ forM rs $ \(sub, r) -> (fst sub,) <$> case r of
Right () -> do
addSubscription ca srv $ first (party,) sub
pure $ Right ()
Left e -> do
when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv $ (party,) $ fst sub
pure $ Left e
where
subscribe = case party of
SPRecipient -> subscribeSMPQueues
SPNotifier -> subscribeSMPQueuesNtfs
showServer :: SMPServer -> ByteString
showServer ProtocolServer {host, port} =
strEncode host <> B.pack (if null port then "" else ':' : port)
-3
View File
@@ -680,9 +680,6 @@ instance SignatureSize (Signature a) where
SignatureEd25519 _ -> Ed25519.signatureSize
SignatureEd448 _ -> Ed448.signatureSize
instance SignatureSize ASignature where
signatureSize (ASignature _ s) = signatureSize s
instance SignatureSize APrivateSignKey where
signatureSize (APrivateSignKey _ k) = signatureSize k
@@ -429,7 +429,7 @@ data NtfSubStatus
NSAuth
| -- | SMP error other than AUTH
NSErr ByteString
deriving (Eq, Ord, Show)
deriving (Eq, Show)
ntfShouldSubscribe :: NtfSubStatus -> Bool
ntfShouldSubscribe = \case
+51 -80
View File
@@ -16,17 +16,12 @@ import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor (second)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (intercalate, sort)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as L
import Data.List (intercalate)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
@@ -56,7 +51,7 @@ import System.Exit (exitFailure)
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
import System.Mem.Weak (deRefWeak)
import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.STM
@@ -72,7 +67,7 @@ runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtf
type M a = ReaderT NtfEnv IO a
ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
restoreServerStats
s <- asks subscriber
ps <- asks pushServer
@@ -83,7 +78,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams tCfg (runClient t)
runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
runClient :: Transport c => TProxy c -> c -> M ()
runClient _ h = do
@@ -146,27 +141,24 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
resubscribe NtfSubscriber {newSubQ} subs = do
subs' <- atomically $ filterM (fmap ntfShouldSubscribe . readTVar . subStatus) $ M.elems subs
atomically . writeTBQueue newSubQ $ map NtfSub subs'
liftIO $ logInfo $ "SMP resubscriptions queued (" <> tshow (length subs') <> " subscriptions)"
d <- asks $ resubscribeDelay . config
forM_ subs $ \sub@NtfSubData {} ->
whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
atomically $ writeTBQueue newSubQ $ NtfSub sub
threadDelay d
liftIO $ logInfo "SMP connections resubscribed"
ntfSubscriber :: NtfSubscriber -> M ()
ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
raceAny_ [subscribe, receiveSMP, receiveAgent]
where
subscribe :: M ()
subscribe = forever $ do
subs <- atomically (readTBQueue newSubQ)
let ss = L.groupAllWith server subs
batchSize <- asks $ subsBatchSize . config
forM_ ss $ \serverSubs -> do
let srv = server $ L.head serverSubs
batches = toChunks batchSize $ L.toList serverSubs
SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber srv
mapM_ (atomically . writeTQueue subscriberSubQ) batches
server :: NtfEntityRec 'Subscription -> SMPServer
server (NtfSub sub) = ntfSubServer sub
subscribe =
forever $
atomically (readTBQueue newSubQ) >>= \case
sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
atomically $ writeTQueue subscriberSubQ sub
getSMPSubscriber :: SMPServer -> M SMPSubscriber
getSMPSubscriber smpServer =
@@ -181,36 +173,21 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
runSMPSubscriber :: SMPSubscriber -> M ()
runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
forever $ do
subs <- atomically (peekTQueue subscriberSubQ)
let subs' = L.map (\(NtfSub sub) -> sub) subs
srv = server $ L.head subs
logSubStatus srv "subscribing" $ length subs
mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs'
rs <- liftIO $ subscribeQueues srv subs'
(subs'', oks, errs) <- foldM process ([], 0, []) rs
atomically $ do
void $ readTQueue subscriberSubQ
mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) $ L.nonEmpty subs''
logSubStatus srv "retrying" $ length subs''
logSubStatus srv "subscribed" oks
logSubErrors srv errs
where
process :: ([NtfSubData], Int, [NtfSubStatus]) -> (NtfSubData, Either SMPClientError ()) -> M ([NtfSubData], Int, [NtfSubStatus])
process (subs, oks, errs) (sub@NtfSubData {smpQueue}, r) = case r of
Right _ -> updateSubStatus smpQueue NSActive $> (subs, oks + 1, errs)
Left e -> update <$> handleSubError smpQueue e
where
update = \case
Just err -> (subs, oks, err : errs) -- permanent error, log and don't retry subscription
Nothing -> (sub : subs, oks, errs) -- temporary error, retry subscription
-- | Subscribe to queues. The list of results can have a different order.
subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
subscribeQueues srv subs =
L.map (second snd) . L.zip subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
where
sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey)
forever $
atomically (peekTQueue subscriberSubQ)
>>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
updateSubStatus smpQueue NSPending
let SMPQueueNtf {smpServer, notifierId} = smpQueue
liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
Right _ -> do
updateSubStatus smpQueue NSActive
void . atomically $ readTQueue subscriberSubQ
Left err -> do
handleSubError smpQueue err
case err of
PCEResponseTimeout -> pure ()
PCENetworkError -> pure ()
_ -> void . atomically $ readTQueue subscriberSubQ
receiveSMP :: M ()
receiveSMP = forever $ do
@@ -235,43 +212,37 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
atomically (readTBQueue agentQ) >>= \case
CAConnected _ -> pure ()
CADisconnected srv subs -> do
logSubStatus srv "disconnected" $ length subs
logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAReconnected srv ->
logInfo $ "SMP server reconnected " <> showServer' srv
CAResubscribed srv subs -> do
forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
logSubStatus srv "resubscribed" $ length subs
CASubError srv errs ->
forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err)
>>= logSubErrors srv . catMaybes . L.toList
CAResubscribed srv sub -> do
let ntfId = snd sub
smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSActive
CASubError srv (_, ntfId) err -> do
logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
handleSubError (SMPQueueNtf srv ntfId) err
where
showServer' = decodeLatin1 . strEncode . host
logSubStatus srv event n = when (n > 0) $
logInfo $ "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subscriptions)"
logSubErrors :: SMPServer -> [NtfSubStatus] -> M ()
logSubErrors srv errs = forM_ (L.group $ sort errs) $ \errs' -> do
logError $ "SMP subscription errors on server " <> showServer' srv <> ": " <> tshow (L.head errs') <> " (" <> tshow (length errs') <> " errors)"
showServer' = decodeLatin1 . strEncode . host
handleSubError :: SMPQueueNtf -> SMPClientError -> M (Maybe NtfSubStatus)
handleSubError :: SMPQueueNtf -> SMPClientError -> M ()
handleSubError smpQueue = \case
PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth $> Just NSAuth
PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
PCEProtocolError e -> updateErr "SMP error " e
PCEIOError e -> updateErr "IOError " e
PCEResponseError e -> updateErr "ResponseError " e
PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
PCETransportError e -> updateErr "TransportError " e
PCECryptoError e -> updateErr "CryptoError " e
PCEIncompatibleHost -> let e = NSErr "IncompatibleHost" in updateSubStatus smpQueue e $> Just e
PCEResponseTimeout -> pure Nothing
PCENetworkError -> pure Nothing
PCEIOError _ -> pure Nothing
PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
PCEResponseTimeout -> pure ()
PCENetworkError -> pure ()
where
updateErr :: Show e => ByteString -> e -> M (Maybe NtfSubStatus)
updateErr errType e = updateSubStatus smpQueue (NSErr $ errType <> bshow e) $> Just (NSErr errType)
updateErr :: Show e => ByteString -> e -> M ()
updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
updateSubStatus smpQueue status = do
st <- asks store
@@ -365,7 +336,7 @@ receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
send :: Transport c => THandle c -> NtfServerClient -> IO ()
send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h Nothing [(Nothing, encodeTransmission v sessionId t)]
void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
atomically . writeTVar activeAt =<< liftIO getSystemTime
-- instance Show a => Show (TVar a) where
@@ -533,7 +504,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
sub <- atomically $ mkNtfSubData subId newSub
resp <-
atomically (addNtfSubscription st subId sub) >>= \case
Just _ -> atomically (writeTBQueue newSubQ [NtfSub sub]) $> NRSubId subId
Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
_ -> pure $ NRErr AUTH
withNtfLog (`logCreateSubscription` sub)
incNtfStat subCreated
@@ -12,7 +12,6 @@ import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.System (SystemTime)
import Data.Word (Word16)
@@ -32,7 +31,7 @@ import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
@@ -46,9 +45,9 @@ data NtfServerConfig = NtfServerConfig
pushQSize :: Natural,
smpAgentCfg :: SMPClientAgentConfig,
apnsConfig :: APNSPushClientConfig,
subsBatchSize :: Int,
inactiveClientExpiration :: Maybe ExpirationConfig,
storeLogFile :: Maybe FilePath,
resubscribeDelay :: Int, -- microseconds
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
@@ -58,7 +57,7 @@ data NtfServerConfig = NtfServerConfig
logStatsStartTime :: Int64,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath,
transportConfig :: TransportServerConfig
logTLSErrors :: Bool
}
defaultInactiveClientExpiration :: ExpirationConfig
@@ -94,7 +93,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
data NtfSubscriber = NtfSubscriber
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
newSubQ :: TBQueue [NtfEntityRec 'Subscription],
newSubQ :: TBQueue (NtfEntityRec 'Subscription),
smpAgent :: SMPClientAgent
}
@@ -106,7 +105,7 @@ newNtfSubscriber qSize smpAgentCfg = do
pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
data SMPSubscriber = SMPSubscriber
{ newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)),
{ newSubQ :: TQueue (NtfEntityRec 'Subscription),
subThreadId :: TVar (Maybe (Weak ThreadId))
}
@@ -14,8 +14,7 @@ import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client (ProtocolClientConfig (..))
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
@@ -23,17 +22,13 @@ import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientCo
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
ntfServerVersion :: String
ntfServerVersion = "1.5.1"
defaultSMPBatchDelay :: Int
defaultSMPBatchDelay = 10000
ntfServerVersion = "1.4.0"
ntfServerCLI :: FilePath -> FilePath -> IO ()
ntfServerCLI cfgPath logPath =
@@ -85,9 +80,7 @@ ntfServerCLI cfgPath logPath =
<> ("host: " <> host <> "\n")
<> ("port: " <> defaultServerPort <> "\n")
<> "log_tls_errors: off\n\
\# delay between command batches sent to SMP relays (microseconds), 0 to disable\n"
<> ("smp_batch_delay: " <> show defaultSMPBatchDelay <> "\n")
<> "websockets: off\n"
\websockets: off\n"
runServer ini = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
@@ -103,21 +96,19 @@ ntfServerCLI cfgPath logPath =
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
logStats = settingIsOn "STORE_LOG" "log_stats" ini
c = combine cfgPath . ($ defaultX509Config)
smpBatchDelay = readIniDefault defaultSMPBatchDelay "TRANSPORT" "smp_batch_delay" ini
batchDelay = if smpBatchDelay <= 0 then Nothing else Just smpBatchDelay
serverConfig =
NtfServerConfig
{ transports = iniTransports ini,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 64,
subQSize = 512,
pushQSize = 1048,
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
clientQSize = 16,
subQSize = 64,
pushQSize = 128,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
subsBatchSize = 900,
inactiveClientExpiration = Nothing,
storeLogFile = enableStoreLog $> storeLogFilePath,
resubscribeDelay = 50000, -- 50ms
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
@@ -125,10 +116,7 @@ ntfServerCLI cfgPath logPath =
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
data CliCommand
@@ -20,7 +20,7 @@ import qualified Data.Set as S
import Data.Word (Word16)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer)
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (whenM, ($>>=))
@@ -68,9 +68,6 @@ data NtfSubData = NtfSubData
subStatus :: TVar NtfSubStatus
}
ntfSubServer :: NtfSubData -> SMPServer
ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
data NtfEntityRec (e :: NtfEntity) where
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
+3 -4
View File
@@ -146,7 +146,6 @@ module Simplex.Messaging.Protocol
where
import Control.Applicative (optional, (<|>))
import Control.Concurrent (threadDelay)
import Control.Monad.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
@@ -1245,8 +1244,8 @@ instance Encoding CommandError where
_ -> fail "bad command error type"
-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle c -> Maybe Int -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
tPut th delay_ trs
tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
tPut th trs
| batch th = tPutBatch [] $ L.map tEncode trs
| otherwise = forM (L.toList trs) $ tPutLog . tEncode
where
@@ -1256,7 +1255,7 @@ tPut th delay_ trs
r <- if n == 0 then largeMsg else replicate n <$> tPutLog (tEncodeBatch n s)
let rs' = rs <> r
case ts_ of
Just ts' -> mapM_ threadDelay delay_ >> tPutBatch rs' ts'
Just ts' -> tPutBatch rs' ts'
_ -> pure rs'
largeMsg = putStrLn "tPut error: large message" >> pure [Left TELargeMsg]
tPutLog s = do
+3 -4
View File
@@ -103,7 +103,7 @@ runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started
type M a = ReaderT Env IO a
smpServer :: TMVar Bool -> ServerConfig -> M ()
smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
s <- asks server
restoreServerMessages
restoreServerStats
@@ -117,7 +117,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams tCfg (runClient t)
runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
serverThread ::
forall s.
@@ -281,13 +281,12 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
send :: Transport c => THandle c -> Client -> IO ()
send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
void . liftIO . tPut h Nothing $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
atomically . writeTVar activeAt =<< liftIO getSystemTime
where
tOrder :: Transmission BrokerMsg -> Int
tOrder (_, _, cmd) = case cmd of
MSG {} -> 0
NMSG {} -> 0
_ -> 1
disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
+2 -3
View File
@@ -30,7 +30,7 @@ import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Version
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
@@ -69,8 +69,7 @@ data ServerConfig = ServerConfig
certificateFile :: FilePath,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange,
-- | TCP transport config
transportConfig :: TransportServerConfig
logTLSErrors :: Bool
}
defMsgExpirationDays :: Int64
+2 -6
View File
@@ -28,7 +28,6 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClien
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (safeDecodeUtf8)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
@@ -165,7 +164,7 @@ smpServerCLI cfgPath logPath =
serverConfig =
ServerConfig
{ transports = iniTransports ini,
tbqSize = 64,
tbqSize = 32,
serverTbqSize = 1024,
msgQueueQuota = 128,
queueIdBytes = 24,
@@ -199,10 +198,7 @@ smpServerCLI cfgPath logPath =
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
smpServerVRange = supportedSMPServerVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
data CliCommand
+12 -24
View File
@@ -29,7 +29,6 @@ module Simplex.Messaging.Transport
supportedSMPServerVRange,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
-- * Transport connection class
Transport (..),
@@ -105,11 +104,6 @@ simplexMQVersion = showVersion SMQ.version
-- * Transport connection class
data TransportConfig = TransportConfig
{ logTLSErrors :: Bool,
transportTimeout :: Maybe Int
}
class Transport c where
transport :: ATransport
transport = ATransport (TProxy @c)
@@ -118,13 +112,11 @@ class Transport c where
transportPeer :: c -> TransportPeer
transportConfig :: c -> TransportConfig
-- | Upgrade server TLS context to connection (used in the server)
getServerConnection :: TransportConfig -> T.Context -> IO c
getServerConnection :: T.Context -> IO c
-- | Upgrade client TLS context to connection (used in the client)
getClientConnection :: TransportConfig -> T.Context -> IO c
getClientConnection :: T.Context -> IO c
-- | tls-unique channel binding per RFC5929
tlsUnique :: c -> SessionId
@@ -158,25 +150,24 @@ data TLS = TLS
{ tlsContext :: T.Context,
tlsPeer :: TransportPeer,
tlsUniq :: ByteString,
tlsBuffer :: TBuffer,
tlsTransportConfig :: TransportConfig
tlsBuffer :: TBuffer
}
connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context
connectTLS host_ TransportConfig {logTLSErrors} params sock =
connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
connectTLS host_ logErrors params sock =
E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
logHandshakeErrors (T.handshake ctx) $> ctx
where
logHandshakeErrors = if logTLSErrors then (`catchAll` logThrow) else id
logHandshakeErrors = if logErrors then (`catchAll` logThrow) else id
logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
host = maybe "" (\h -> " (" <> h <> ")") host_
getTLS :: TransportPeer -> TransportConfig -> T.Context -> IO TLS
getTLS tlsPeer cfg cxt = withTlsUnique tlsPeer cxt newTLS
getTLS :: TransportPeer -> T.Context -> IO TLS
getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
where
newTLS tlsUniq = do
tlsBuffer <- atomically newTBuffer
pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsPeer, tlsUniq, tlsBuffer}
pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, tlsBuffer}
withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
withTlsUnique peer cxt f =
@@ -208,7 +199,6 @@ supportedParameters =
instance Transport TLS where
transportName _ = "TLS"
transportPeer = tlsPeer
transportConfig = tlsTransportConfig
getServerConnection = getTLS TServer
getClientConnection = getTLS TClient
tlsUnique = tlsUniq
@@ -217,12 +207,10 @@ instance Transport TLS where
-- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-- this function may return less than requested number of bytes
cGet :: TLS -> Int -> IO ByteString
cGet TLS {tlsContext, tlsBuffer, tlsTransportConfig = TransportConfig {transportTimeout = t_}} n =
getBuffered tlsBuffer n t_ (T.recvData tlsContext)
cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext)
cPut :: TLS -> ByteString -> IO ()
cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} s =
withTimedErr t_ . T.sendData tlsContext $ BL.fromStrict s
cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
getLn :: TLS -> IO ByteString
getLn TLS {tlsContext, tlsBuffer} = do
+7 -20
View File
@@ -8,8 +8,6 @@ import Control.Concurrent.STM
import qualified Control.Exception as E
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import System.Timeout (timeout)
import GHC.IO.Exception (ioException, IOException (..), IOErrorType (..))
data TBuffer = TBuffer
{ buffer :: TVar ByteString,
@@ -28,33 +26,22 @@ withBufferLock TBuffer {getLock} =
(atomically $ takeTMVar getLock)
(atomically $ putTMVar getLock ())
getBuffered :: TBuffer -> Int -> Maybe Int -> IO ByteString -> IO ByteString
getBuffered tb@TBuffer {buffer} n t_ getChunk = withBufferLock tb $ do
b <- readChunks True =<< readTVarIO buffer
getBuffered :: TBuffer -> Int -> IO ByteString -> IO ByteString
getBuffered tb@TBuffer {buffer} n getChunk = withBufferLock tb $ do
b <- readChunks =<< readTVarIO buffer
let (s, b') = B.splitAt n b
atomically $ writeTVar buffer $! b'
-- This would prevent the need to pad auth tag in HTTP2
-- threadDelay 150
pure s
where
readChunks :: Bool -> ByteString -> IO ByteString
readChunks firstChunk b
readChunks :: ByteString -> IO ByteString
readChunks b
| B.length b >= n = pure b
| otherwise =
get >>= \case
getChunk >>= \case
"" -> pure b
s -> readChunks False $ b <> s
where
get
| firstChunk = getChunk
| otherwise = withTimedErr t_ getChunk
withTimedErr :: Maybe Int -> IO a -> IO a
withTimedErr t_ a = case t_ of
Just t -> timeout t a >>= maybe err pure
Nothing -> a
where
err = ioException (IOError Nothing TimeExpired "" "get timeout" Nothing Nothing)
s -> readChunks $ b <> s
-- This function is only used in test and needs to be improved before it can be used in production,
-- it will never complete if TLS connection is closed before there is newline.
+2 -8
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -115,16 +114,12 @@ data TransportClientConfig = TransportClientConfig
defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig {logTLSErrors} =
TransportConfig {logTLSErrors, transportTimeout = Nothing}
-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive} proxyUsername host port keyHash client = do
runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} proxyUsername host port keyHash client = do
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
connectTCP = case socksProxy of
@@ -133,8 +128,7 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
c <- liftIO $ do
sock <- connectTCP port
mapM_ (setSocketKeepAlive sock) tcpKeepAlive
let tCfg = clientTransportConfig cfg
connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg
connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
client c `E.finally` liftIO (closeConnection c)
where
hostAddr = \case
+1 -1
View File
@@ -73,7 +73,7 @@ instance HTTP2BodyChunk HS.Request where
getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
getHTTP2Body r n = do
bodyBuffer <- atomically newTBuffer
let getPart n' = getBuffered bodyBuffer n' Nothing $ getBodyChunk r
let getPart n' = getBuffered bodyBuffer n' $ getBodyChunk r
bodyHead <- getPart n
let bodySize = fromMaybe 0 $ getBodySize r
-- TODO check bodySize once it is set
@@ -14,7 +14,7 @@ import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Transport (SessionId)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer)
import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO ()
@@ -27,7 +27,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
transportConfig :: TransportServerConfig
logTLSErrors :: Bool
}
deriving (Show)
@@ -45,12 +45,12 @@ data HTTP2Server = HTTP2Server
-- This server is for testing only, it processes all requests in a single queue.
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
started <- newEmptyTMVarIO
reqQ <- newTBQueueIO qSize
action <- async $
runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig $ \sessionId r sendResponse -> do
runHTTP2Server started http2Port bufferSize tlsServerParams logTLSErrors $ \sessionId r sendResponse -> do
reqBody <- getHTTP2Body r bodyHeadSize
atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
void . atomically $ takeTMVar started
@@ -59,8 +59,8 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server = uninterruptibleCancel . action
runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port bufferSize serverParams transportConfig http2Server =
runTransportServer started port serverParams transportConfig $ withHTTP2 bufferSize run
runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port bufferSize serverParams logTLSErrors http2Server =
runTransportServer started port serverParams logTLSErrors $ withHTTP2 bufferSize run
where
run cfg sessId = H.run cfg $ \req _aux sendResp -> http2Server sessId req (`sendResp` [])
+3 -23
View File
@@ -7,8 +7,6 @@
module Simplex.Messaging.Transport.Server
( runTransportServer,
runTCPServer,
TransportServerConfig (..),
defaultTransportServerConfig,
loadSupportedTLSServerParams,
loadTLSServerParams,
loadFingerprint,
@@ -40,33 +38,15 @@ import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
data TransportServerConfig = TransportServerConfig
{ logTLSErrors :: Bool,
transportTimeout :: Int
}
deriving (Eq, Show)
defaultTransportServerConfig :: TransportServerConfig
defaultTransportServerConfig = TransportServerConfig
{ logTLSErrors = True,
transportTimeout = 40000000
}
serverTransportConfig :: TransportServerConfig -> TransportConfig
serverTransportConfig TransportServerConfig {logTLSErrors} =
-- TransportConfig {logTLSErrors, transportTimeout = Just transportTimeout}
TransportConfig {logTLSErrors, transportTimeout = Nothing}
-- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
--
-- All accepted connections are passed to the passed function.
runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> m ()) -> m ()
runTransportServer started port serverParams cfg server = do
runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> (c -> m ()) -> m ()
runTransportServer started port serverParams logTLSErrors server = do
u <- askUnliftIO
let tCfg = serverTransportConfig cfg
liftIO . runTCPServer started port $ \conn ->
E.bracket
(connectTLS Nothing tCfg serverParams conn >>= getServerConnection tCfg)
(connectTLS Nothing logTLSErrors serverParams conn >>= getServerConnection)
closeConnection
(unliftIO u . server)
+6 -11
View File
@@ -17,7 +17,6 @@ import Simplex.Messaging.Transport
Transport (..),
TransportError (..),
TransportPeer (..),
TransportConfig (..),
closeTLS,
smpBlockSize,
withTlsUnique,
@@ -28,8 +27,7 @@ data WS = WS
{ wsPeer :: TransportPeer,
tlsUniq :: ByteString,
wsStream :: Stream,
wsConnection :: Connection,
wsTransportConfig :: TransportConfig
wsConnection :: Connection
}
websocketsOpts :: ConnectionOptions
@@ -47,13 +45,10 @@ instance Transport WS where
transportPeer :: WS -> TransportPeer
transportPeer = wsPeer
transportConfig :: WS -> TransportConfig
transportConfig = wsTransportConfig
getServerConnection :: TransportConfig -> T.Context -> IO WS
getServerConnection :: T.Context -> IO WS
getServerConnection = getWS TServer
getClientConnection :: TransportConfig -> T.Context -> IO WS
getClientConnection :: T.Context -> IO WS
getClientConnection = getWS TClient
tlsUnique :: WS -> ByteString
@@ -79,13 +74,13 @@ instance Transport WS where
then E.throwIO TEBadBlock
else pure $ B.init s
getWS :: TransportPeer -> TransportConfig -> T.Context -> IO WS
getWS wsPeer cfg cxt = withTlsUnique wsPeer cxt connectWS
getWS :: TransportPeer -> T.Context -> IO WS
getWS wsPeer cxt = withTlsUnique wsPeer cxt connectWS
where
connectWS tlsUniq = do
s <- makeTLSContextStream cxt
wsConnection <- connectPeer wsPeer s
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg}
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection}
connectPeer :: TransportPeer -> Stream -> IO Connection
connectPeer TServer = acceptClientRequest
connectPeer TClient = sendClientRequest
+2 -39
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -12,15 +13,11 @@ import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List (groupBy, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Time (NominalDiffTime)
import Data.Time (NominalDiffTime, nominalDiffTimeToSeconds)
import UnliftIO.Async
import qualified UnliftIO.Exception as UE
raceAny_ :: MonadUnliftIO m => [m a] -> m ()
raceAny_ = r []
@@ -101,44 +98,10 @@ catchAll_ :: IO a -> IO a -> IO a
catchAll_ a = catchAll a . const
{-# INLINE catchAll_ #-}
tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a)
tryAllErrors err action = tryError action `UE.catch` (pure . Left . err)
{-# INLINE tryAllErrors #-}
catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a
catchAllErrors err action handle = tryAllErrors err action >>= either handle pure
{-# INLINE catchAllErrors #-}
catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a
catchThrow action err = catchAllErrors err action throwError
{-# INLINE catchThrow #-}
allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a
allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r
{-# INLINE allFinally #-}
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just
{-# INLINE eitherToMaybe #-}
groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
groupOn = groupBy . eqOn
-- it is equivalent to groupBy ((==) `on` f),
-- but it redefines `on` to avoid duplicate computation for most values.
-- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
where
eqOn f = \x -> let fx = f x in \y -> fx == f y
groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
groupAllOn f = groupOn f . sortOn f
toChunks :: Int -> [a] -> [NonEmpty a]
toChunks _ [] = []
toChunks n xs =
let (ys, xs') = splitAt n xs
in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With onError
where
+6 -6
View File
@@ -70,8 +70,8 @@ connectionRequest =
ACR SCMInvitation $
CRInvitationUri connReqData testE2ERatchetParams
connectionRequestCurrentRange :: AConnectionRequestUri
connectionRequestCurrentRange =
connectionRequest12 :: AConnectionRequestUri
connectionRequest12 =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
@@ -113,8 +113,8 @@ connectionRequestTests =
`shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequestCurrentRange
`shouldBe` "https://simplex.chat/invitation#/?v=1-3&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
strEncode connectionRequest12
`shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
@@ -158,9 +158,9 @@ connectionRequestTests =
<> testDhKeyStrUri
<> "&e2e=extra_key%3Dnew%26v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&some_new_param=abc"
<> "&v=1-3"
<> "&v=1-2"
)
`shouldBe` Right connectionRequestCurrentRange
`shouldBe` Right connectionRequest12
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
File diff suppressed because it is too large Load Diff
+3 -54
View File
@@ -19,8 +19,8 @@ import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import Data.Text.Encoding (encodeUtf8)
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2)
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn, xit')
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol
@@ -31,7 +31,6 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Types (NtfToken (..))
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Util (tryE)
import System.Directory (doesFileExist, removeFile)
@@ -86,10 +85,6 @@ notificationTests t =
it "should resume subscriptions after SMP server is restarted" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationsSMPRestart t apns
describe "Notifications after SMP server restart" $
it "should resume batched subscriptions after SMP server is restarted" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
describe "should switch notifications to the new queue" $
testServerMatrix2 t $ \servers ->
withAPNSMockServer $ \apns ->
@@ -485,52 +480,6 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
conns <- runServers $ do
conns <- forM [1 .. n :: Int] . const $ makeConnection a b
_ <- registerTestToken a "abcd" NMInstant apnsQ
liftIO $ threadDelay 1500000
forM_ conns $ \(aliceId, bobId) -> do
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
get b ##> ("", aliceId, SENT msgId)
void $ messageNotification apnsQ
get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage a bobId msgId
pure conns
runRight_ @AgentErrorType $ do
("", "", DOWN _ bcs1) <- nGet a
("", "", DOWN _ bcs2) <- nGet a
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
("", "", DOWN _ acs1) <- nGet b
("", "", DOWN _ acs2) <- nGet b
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
runServers $ do
("", "", UP _ bcs1) <- nGet a
("", "", UP _ bcs2) <- nGet a
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
("", "", UP _ acs1) <- nGet b
("", "", UP _ acs2) <- nGet b
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
liftIO $ threadDelay 1500000
forM_ conns $ \(aliceId, bobId) -> do
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
get b ##> ("", aliceId, SENT msgId)
_ <- messageNotificationData a apnsQ
get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
where
runServers :: ExceptT AgentErrorType IO a -> IO a
runServers a = do
withSmpServerStoreLogOn t testPort $ \t1 -> do
res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
runRight a `finally` killThread t2
killThread t1
pure res
testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications servers APNSMockServer {apnsQ} = do
a <- getSMPAgentClient' agentCfg servers testDB
@@ -547,7 +496,7 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
ackMessage a bId msgId
testMessage "hello"
_ <- switchConnectionAsync a "" bId
switchConnectionAsync a "" bId
switchComplete a bId b aId
liftIO $ threadDelay 500000
testMessage "hello again"
+1 -5
View File
@@ -140,7 +140,7 @@ testForeignKeysEnabled =
`shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
cData1 :: ConnData
cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
testPrivateSignKey :: C.APrivateSignKey
testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -167,7 +167,6 @@ rcvQueue1 =
dbQueueId = 1,
primary = True,
dbReplaceQueueId = Nothing,
rcvSwchStatus = Nothing,
smpClientVersion = 1,
clientNtfCreds = Nothing,
deleteErrors = 0
@@ -188,7 +187,6 @@ sndQueue1 =
dbQueueId = 1,
primary = True,
dbReplaceQueueId = Nothing,
sndSwchStatus = Nothing,
smpClientVersion = 1
}
@@ -326,7 +324,6 @@ testUpgradeRcvConnToDuplex =
e2eDhSecret = testDhSecret,
status = New,
dbQueueId = 1,
sndSwchStatus = Nothing,
primary = True,
dbReplaceQueueId = Nothing,
smpClientVersion = 1
@@ -355,7 +352,6 @@ testUpgradeSndConnToDuplex =
sndId = "4567",
status = New,
dbQueueId = 1,
rcvSwchStatus = Nothing,
primary = True,
dbReplaceQueueId = Nothing,
smpClientVersion = 1,
+3 -3
View File
@@ -50,13 +50,13 @@ testSchemaMigrations = do
putStrLn $ "down migration " <> name m
let downMigr = fromJust $ toDownMigration m
schema <- getSchema testDB testSchema
Migrations.run st $ MTRUp [m]
withConnection st (`Migrations.run` MTRUp [m])
schema' <- getSchema testDB testSchema
schema' `shouldNotBe` schema
Migrations.run st $ MTRDown [downMigr]
withConnection st (`Migrations.run` MTRDown [downMigr])
schema'' <- getSchema testDB testSchema
schema'' `shouldBe` schema
Migrations.run st $ MTRUp [m]
withConnection st (`Migrations.run` MTRUp [m])
schema''' <- getSchema testDB testSchema
schema''' `shouldBe` schema'
-119
View File
@@ -1,119 +0,0 @@
{-# LANGUAGE ScopedTypeVariables #-}
module CoreTests.UtilTests where
import Control.Exception (Exception, SomeException, throwIO)
import Control.Monad.Except
import Data.IORef
import Simplex.Messaging.Util
import Simplex.Messaging.Client.Agent ()
import Test.Hspec
import qualified UnliftIO.Exception as UE
utilTests :: Spec
utilTests = do
describe "problems of lifted try, catch and finally (don't use them)" $ do
describe "lifted try" $ do
it "does not catch errors" $ do
runExceptT (UE.try throwTestError >>= either handleCatch pure) `shouldReturn` Left (TestError "error")
runExceptT (UE.try throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
it "with SomeException catches all errors but wraps ExceptT errors" $ do
runExceptT (UE.try throwTestError >>= either handleException pure) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
runExceptT (UE.try throwTestException >>= either handleException pure) `shouldReturn` Right "caught user error (error)"
describe "lifted catch" $ do
it "does not catch" $ do
runExceptT (throwTestError `UE.catch` handleCatch) `shouldReturn` Left (TestError "error")
runExceptT (throwTestException `UE.catch` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
it "with SomeException catches all errors but wraps ExceptT errors" $ do
runExceptT (throwTestError `UE.catch` handleException) `shouldReturn` Right "caught InternalException {unInternalException = TestError \"error\"}"
runExceptT (throwTestException `UE.catch` handleException) `shouldReturn` Right "caught user error (error)"
describe "lifted finally" $ do
it "with ExceptT error executes final action and stays in ExceptT monad" $ withFinal $ \final ->
runExceptT (throwTestError `UE.finally` final) `shouldReturn` Left (TestError "error")
it "with exception executes final action (not always - race condition?) and throws exception" $ withFinal $ \final ->
runExceptT (throwTestException `UE.finally` final) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
describe "problems of tryError and catchError (don't use them)" $ do
describe "tryError" $ do
it "catches ExceptT errors but not Exceptions" $ do
runExceptT (tryError throwTestError >>= either handleCatch pure) `shouldReturn` Right "caught TestError \"error\""
runExceptT (tryError throwTestException >>= either handleCatch pure) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
describe "catchError" $ do
it "catches ExceptT errors but not Exceptions" $ do
runExceptT (throwTestError `catchError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
runExceptT (throwTestException `catchError` handleCatch) `shouldThrow` (\(e :: IOError) -> show e == "user error (error)")
describe "tryAllErrors" $ do
it "should return ExceptT error as Left" $
runExceptT (tryAllErrors testErr throwTestError) `shouldReturn` Right (Left (TestError "error"))
it "should return SomeException as Left" $
runExceptT (tryAllErrors testErr throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
it "should return no errors as Right" $
runExceptT (tryAllErrors testErr noErrors) `shouldReturn` Right (Right "no errors")
describe "tryAllErrors specialized as tryTestError" $ do
let tryTestError = tryAllErrors testErr
it "should return ExceptT error as Left" $
runExceptT (tryTestError throwTestError) `shouldReturn` Right (Left (TestError "error"))
it "should return SomeException as Left" $
runExceptT (tryTestError throwTestException) `shouldReturn` Right (Left (TestException "user error (error)"))
it "should return no errors as Right" $
runExceptT (tryTestError noErrors) `shouldReturn` Right (Right "no errors")
describe "catchAllErrors" $ do
it "should catch ExceptT error" $
runExceptT (catchAllErrors testErr throwTestError handleCatch) `shouldReturn` Right "caught TestError \"error\""
it "should catch SomeException" $
runExceptT (catchAllErrors testErr throwTestException handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
it "should not throw if there are no errors" $
runExceptT (catchAllErrors testErr noErrors throwError) `shouldReturn` Right "no errors"
describe "catchAllErrors specialized as catchTestError" $ do
let catchTestError = catchAllErrors testErr
it "should catch ExceptT error" $
runExceptT (throwTestError `catchTestError` handleCatch) `shouldReturn` Right "caught TestError \"error\""
it "should catch SomeException" $
runExceptT (throwTestException `catchTestError` handleCatch) `shouldReturn` Right "caught TestException \"user error (error)\""
it "should not throw if there are no errors" $
runExceptT (noErrors `catchTestError` throwError) `shouldReturn` Right "no errors"
describe "catchThrow" $ do
it "should re-throw ExceptT error" $
runExceptT (throwTestError `catchThrow` testErr) `shouldReturn` Left (TestError "error")
it "should catch SomeException and throw as ExceptT error" $
runExceptT (throwTestException `catchThrow` testErr) `shouldReturn` Left (TestException "user error (error)")
it "should not throw if there are no exceptions" $
runExceptT (noErrors `catchThrow` testErr) `shouldReturn` Right "no errors"
describe "allFinally should run final action" $ do
it "then throw ExceptT error" $ withFinal $ \final ->
runExceptT (allFinally testErr throwTestError final) `shouldReturn` Left (TestError "error")
it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
runExceptT (allFinally testErr throwTestException final) `shouldReturn` Left (TestException "user error (error)")
it "and should not throw if there are no exceptions" $ withFinal $ \final ->
runExceptT (allFinally testErr noErrors final) `shouldReturn` Right "no errors"
describe "allFinally specialized as testFinally should run final action" $ do
let testFinally = allFinally testErr
it "then throw ExceptT error" $ withFinal $ \final ->
runExceptT (throwTestError `testFinally` final) `shouldReturn` Left (TestError "error")
it "then throw SomeException as ExceptT error" $ withFinal $ \final ->
runExceptT (throwTestException `testFinally` final) `shouldReturn` Left (TestException "user error (error)")
it "and should not throw if there are no exceptions" $ withFinal $ \final ->
runExceptT (noErrors `testFinally` final) `shouldReturn` Right "no errors"
where
throwTestError :: ExceptT TestError IO String
throwTestError = throwError $ TestError "error"
throwTestException :: ExceptT TestError IO String
throwTestException = liftIO $ throwIO $ userError "error"
noErrors :: ExceptT TestError IO String
noErrors = pure "no errors"
testErr :: SomeException -> TestError
testErr = TestException . show
handleCatch :: TestError -> ExceptT TestError IO String
handleCatch e = pure $ "caught " <> show e
handleException :: SomeException -> ExceptT TestError IO String
handleException e = pure $ "caught " <> show e
withFinal :: (ExceptT TestError IO String -> IO ()) -> IO ()
withFinal test = do
r <- newIORef False
let final = liftIO $ writeIORef r True >> pure "final"
test final
readIORef r `shouldReturn` True
data TestError = TestError String | TestException String
deriving (Eq, Show)
instance Exception TestError
+4 -5
View File
@@ -44,7 +44,6 @@ import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server
import Test.Hspec
import UnliftIO.Async
import UnliftIO.Concurrent
@@ -89,9 +88,9 @@ ntfServerCfg =
{ apnsPort = apnsTestPort,
caStoreFile = "tests/fixtures/ca.crt"
},
subsBatchSize = 900,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
storeLogFile = Nothing,
resubscribeDelay = 1000,
-- CA certificate private key is not needed for initialization
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
@@ -101,7 +100,7 @@ ntfServerCfg =
logStatsStartTime = 0,
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing,
transportConfig = defaultTransportServerConfig
logTLSErrors = True
}
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
@@ -135,7 +134,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
where
tPut' h (sig, corrId, queueId, smp) = do
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
[Right ()] <- tPut h Nothing [(sig, t')]
[Right ()] <- tPut h [(sig, t')]
pure ()
tGet' h = do
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
@@ -168,7 +167,7 @@ apnsMockServerConfig =
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
transportConfig = defaultTransportServerConfig
logTLSErrors = True
}
withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
+2 -3
View File
@@ -24,7 +24,6 @@ import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Version
import System.Environment (lookupEnv)
import System.Info (os)
@@ -100,7 +99,7 @@ cfg =
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
smpServerVRange = supportedSMPServerVRange,
transportConfig = defaultTransportServerConfig
logTLSErrors = True
}
withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
@@ -160,7 +159,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
where
tPut' h (sig, corrId, queueId, smp) = do
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
[Right ()] <- tPut h Nothing [(sig, t')]
[Right ()] <- tPut h [(sig, t')]
pure ()
tGet' h = do
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
+1 -1
View File
@@ -88,7 +88,7 @@ signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
tPut1 h t = do
[r] <- tPut h Nothing [t]
[r] <- tPut h [t]
pure r
tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd)
-2
View File
@@ -7,7 +7,6 @@ import CoreTests.CryptoTests
import CoreTests.EncodingTests
import CoreTests.ProtocolErrorTests
import CoreTests.RetryIntervalTests
import CoreTests.UtilTests
import CoreTests.VersionRangeTests
import FileDescriptionTests (fileDescriptionTests)
import NtfServerTests (ntfServerTests)
@@ -40,7 +39,6 @@ main = do
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Retry interval tests" retryIntervalTests
describe "Util tests" utilTests
describe "SMP server via TLS" $ serverTests (transport @TLS)
describe "SMP server via WebSockets" $ serverTests (transport @WS)
describe "Notifications server" $ ntfServerTests (transport @TLS)
+1 -2
View File
@@ -14,7 +14,6 @@ import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Transport.Server
import Test.Hspec
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
@@ -112,7 +111,7 @@ testXFTPServerConfig =
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
transportConfig = defaultTransportServerConfig
logTLSErrors = True
}
testXFTPClientConfig :: XFTPClientConfig