dandri/simplexmq
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-10-24 06:22:25 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into sh/low-order-dh

Browse Source 
# Conflicts:
#	src/Simplex/Messaging/Agent.hs
This commit is contained in:
shum committed 2026-10-16 15:33:40 +00:00
2 parents 54cf4fd2ea 4b8d31a476
commit a703bf03ee
87 files changed
+3497 -3971
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

.github/workflows/build.yml
+163 -19
View File
@@ -66,8 +66,19 @@ jobs:
build:
name: "ubuntu-${{ matrix.os }}-${{ matrix.arch }}, GHC: ${{ matrix.ghc }}"
needs: maybe-release
permissions:
contents: write
packages: write
env:
apps: "smp-server xftp-server ntf-server xftp"
opt: ${{ github.event_name == 'pull_request' && 'O0' || 'O2' }}
ghc_options: ${{ github.event_name == 'pull_request' && '--ghc-options=-O0' || '' }}
release: ${{ startsWith(github.ref, 'refs/tags/v') }}
postgres_dist: ${{ startsWith(github.ref, 'refs/tags/v') && 'dist-newstyle' || 'dist-postgres' }}
branch: ${{ github.base_ref || github.ref_name }}
cache_o0: ${{ github.event_name == 'push' && (github.ref == 'refs/heads/master' || github.ref == 'refs/heads/stable') }}
image_cache: ghcr.io/simplex-chat/simplexmq-build-cache:${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}
source_hashes: dist-newstyle/sources.sha256
runs-on: ${{ matrix.runner }}
services:
postgres:
@@ -146,6 +157,18 @@ jobs:
sudo apt update
sudo apt -y install postgresql-client-15
- name: Log in to GitHub Container Registry
if: matrix.should_run == true && env.release != 'true'
shell: bash
env:
GHCR_TOKEN: ${{ secrets.GITHUB_TOKEN }}
run: echo "$GHCR_TOKEN" | docker login ghcr.io -u "${{ github.actor }}" --password-stdin
- name: Compute image cache week
id: week
if: matrix.should_run == true && env.release != 'true'
run: echo "week=$(date -u +%G-W%V)" >> "$GITHUB_OUTPUT"
- name: Build and cache Docker image
if: matrix.should_run == true
uses: simplex-chat/docker-build-push-action@v6
@@ -157,20 +180,14 @@ jobs:
build-args: |
TAG=${{ matrix.os }}
GHC=${{ matrix.ghc }}
- name: Cache dependencies
if: matrix.should_run == true
uses: actions/cache@v4
with:
path: |
~/.cabal/store
dist-newstyle
key: ubuntu-${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
cache-from: ${{ env.release != 'true' && format('type=registry,ref={0}-{1}', env.image_cache, steps.week.outputs.week) || '' }}
cache-to: ${{ github.event_name == 'push' && github.ref == 'refs/heads/master' && format('type=registry,ref={0}-{1},mode=max,ignore-error=true', env.image_cache, steps.week.outputs.week) || '' }}
- name: Start container
if: matrix.should_run == true
shell: bash
run: |
mkdir -p ~/.cabal
docker run -t -d \
--device /dev/fuse \
--cap-add SYS_ADMIN \
@@ -181,21 +198,66 @@ jobs:
-v ${{ github.workspace }}:/project \
build/${{ matrix.os }}:latest
- name: Compute cache key prefixes
id: keys
if: matrix.should_run == true && env.release != 'true'
run: |
toolchain=$(docker exec builder dpkg-query -W -f '${db:Status-Status} ${binary:Package} ${Version}\n' 'binutils*' 'cpp*' 'gcc*' '*-dev' | grep '^installed ' | sha256sum | cut -c1-16)
target=${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}-$toolchain
echo "deps=deps-$target" >> "$GITHUB_OUTPUT"
echo "dist=dist-$target" >> "$GITHUB_OUTPUT"
- name: Restore dependencies from cache
id: restore-deps
if: matrix.should_run == true && env.release != 'true'
uses: actions/cache/restore@v4
with:
path: ~/.cabal/store
key: ${{ steps.keys.outputs.deps }}-${{ env.branch }}-${{ github.sha }}
restore-keys: |
${{ steps.keys.outputs.deps }}-${{ env.branch }}-
${{ steps.keys.outputs.deps }}-
- name: Warn if dependencies not in cache
if: matrix.should_run == true && env.release != 'true' && steps.restore-deps.outputs.cache-matched-key == ''
run: echo "::warning title=Cache miss::${{ steps.keys.outputs.deps }}-${{ env.branch }}"
- name: Restore build directories from cache
id: restore-build
if: matrix.should_run == true && env.release != 'true'
uses: actions/cache/restore@v4
with:
path: |
dist-newstyle
dist-postgres
key: ${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-${{ github.sha }}
restore-keys: |
${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-
${{ steps.keys.outputs.dist }}-${{ env.opt }}-
- name: Warn if build directories not in cache
if: matrix.should_run == true && env.release != 'true' && steps.restore-build.outputs.cache-matched-key == ''
run: echo "::warning title=Cache miss::${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}"
- name: Set old timestamps on unchanged sources (GHC 8.10.7)
if: matrix.ghc == '8.10.7' && steps.restore-build.outputs.cache-matched-key != '' && hashFiles(env.source_hashes) != ''
run: scripts/ci/source-timestamps.sh restore ${{ env.source_hashes }}
- name: Build smp-server, xftp-server (postgresql) and tests
if: matrix.should_run == true
shell: docker exec -t builder sh -eu {0}
run: |
chmod -fR 777 ~/.cabal ./dist-newstyle || :; git config --global --add safe.directory '*'
cabal clean
chmod -fR 777 ~/.cabal ./dist-newstyle ./dist-postgres || :; git config --global --add safe.directory '*'
scripts/ci/prune-old-builds.sh dist-newstyle dist-postgres
cabal update
cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
cabal build --builddir=${{ env.postgres_dist }} --jobs=$(nproc) --enable-tests -fserver_postgres ${{ env.ghc_options }}
mkdir -p /out
for i in smp-server xftp-server simplexmq-test; do
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
for i in smp-server xftp-server ntf-server simplexmq-test; do
bin=$(find /project/${{ env.postgres_dist }} -name "$i" -type f -executable)
chmod +x "$bin"
mv "$bin" /out/
cp "$bin" /out/
done
strip /out/smp-server /out/xftp-server
strip /out/smp-server /out/xftp-server /out/ntf-server
- name: Copy simplexmq-test from container
if: matrix.should_run == true
@@ -228,16 +290,17 @@ jobs:
cat hashes.output >> "$GITHUB_OUTPUT"
- name: Build everything else (standard)
id: build-standard
if: matrix.should_run == true
shell: docker exec -t builder sh -eu {0}
run: |
cabal build --jobs=$(nproc)
cabal build --jobs=$(nproc) ${{ env.ghc_options }}
mkdir -p /out
for i in ${{ env.apps }}; do
for i in smp-server xftp-server xftp; do
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
strip "$bin"
chmod +x "$bin"
mv "$bin" /out/
cp "$bin" /out/
done
- name: Copy binaries from container and prepare them
@@ -282,6 +345,41 @@ jobs:
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
- name: Record source hashes (GHC 8.10.7)
if: matrix.should_run == true && matrix.ghc == '8.10.7'
shell: docker exec -t builder sh -eu {0}
run: scripts/ci/source-timestamps.sh record ${{ env.source_hashes }}
- name: Compute dependency cache key
id: hash-deps
if: matrix.should_run == true && env.release != 'true'
shell: bash
run: echo "hash=$(ls ~/.cabal/store/ghc-*/ | sha256sum | cut -c1-16)" >> "$GITHUB_OUTPUT"
- name: Save dependencies to cache
if: matrix.should_run == true && env.release != 'true' && steps.restore-deps.outputs.cache-matched-key != format('{0}-{1}-{2}', steps.keys.outputs.deps, env.branch, steps.hash-deps.outputs.hash)
uses: actions/cache/save@v4
with:
path: ~/.cabal/store
key: ${{ steps.keys.outputs.deps }}-${{ env.branch }}-${{ steps.hash-deps.outputs.hash }}
- name: Save build directories to cache
if: matrix.should_run == true && env.release != 'true' && steps.restore-build.outputs.cache-hit != 'true'
uses: actions/cache/save@v4
with:
path: |
dist-newstyle
dist-postgres
key: ${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-${{ github.sha }}
- name: Increase PostgreSQL connection limit
if: matrix.should_run == true && matrix.arch == 'x86-64'
shell: bash
run: |
docker exec ${{ job.services.postgres.id }} psql -U postgres -c "ALTER SYSTEM SET max_connections = 500"
docker restart ${{ job.services.postgres.id }}
timeout 60 sh -c 'until docker exec ${{ job.services.postgres.id }} pg_isready -U postgres; do sleep 1; done'
- name: Test
if: matrix.should_run == true && matrix.arch == 'x86-64'
timeout-minutes: 120
@@ -306,6 +404,52 @@ jobs:
exit 1
fi
- name: Remove -O2 build directories
id: remove-o2
if: env.cache_o0 == 'true' && !cancelled() && steps.build-standard.outcome == 'success'
shell: docker exec -t builder sh -eu {0}
run: rm -rf dist-newstyle dist-postgres
- name: Restore -O0 build directories from cache
id: restore-build-o0
if: ${{ !cancelled() && steps.remove-o2.outcome == 'success' }}
uses: actions/cache/restore@v4
with:
path: |
dist-newstyle
dist-postgres
key: ${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-${{ github.sha }}
restore-keys: |
${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-
${{ steps.keys.outputs.dist }}-O0-
- name: Set old timestamps on unchanged sources for -O0 build (GHC 8.10.7)
if: ${{ !cancelled() && matrix.ghc == '8.10.7' && steps.restore-build-o0.outputs.cache-matched-key != '' && hashFiles(env.source_hashes) != '' }}
run: scripts/ci/source-timestamps.sh restore ${{ env.source_hashes }}
- name: Build at -O0 for pull request caches
id: build-o0
if: ${{ !cancelled() && steps.remove-o2.outcome == 'success' }}
shell: docker exec -t builder sh -eu {0}
run: |
scripts/ci/prune-old-builds.sh dist-newstyle dist-postgres
cabal build --builddir=dist-postgres --jobs=$(nproc) --enable-tests -fserver_postgres --ghc-options=-O0
cabal build --jobs=$(nproc) --ghc-options=-O0
- name: Record source hashes for -O0 build (GHC 8.10.7)
if: ${{ !cancelled() && matrix.ghc == '8.10.7' && steps.build-o0.outcome == 'success' }}
shell: docker exec -t builder sh -eu {0}
run: scripts/ci/source-timestamps.sh record ${{ env.source_hashes }}
- name: Save -O0 build directories to cache
if: ${{ !cancelled() && steps.build-o0.outcome == 'success' && steps.restore-build-o0.outputs.cache-hit != 'true' }}
uses: actions/cache/save@v4
with:
path: |
dist-newstyle
dist-postgres
key: ${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-${{ github.sha }}
# =============================
# Resolver test job
# =============================
cabal.project
+1 -1
View File
@@ -31,7 +31,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/simplex-chat/direct-sqlcipher.git
tag: f814ee68b16a9447fbb467ccc8f29bdd3546bfd9
tag: 2330df3dc8c4b660674d3c02d76bb86f66c2abee
source-repository-package
type: git
contributing/PROJECT.md
+8
View File
@@ -97,6 +97,14 @@ cabal test --test-option=--match="/SMP client agent/functional API/"
Tests require PostgreSQL running on `localhost:5432` when using `-fserver_postgres` or `-fclient_postgres`.
Tests run in parallel, one job per processor. With 4 jobs, the tests open up to 220 PostgreSQL connections with `-fserver_postgres` and up to 420 with both flags, while the default limit is 100. Raise the limit and restart PostgreSQL:
```bash
psql -U postgres -c "ALTER SYSTEM SET max_connections = 500"
```
With more than 4 processors, also limit the jobs: `--test-option=--jobs=4`.
Test files are in `tests/` with structure:
- `Test.hs`: Main runner
- `AgentTests/`: Agent protocol and connection tests
docs/smp-server-db-load.md
+1 -3
View File
@@ -144,9 +144,7 @@ space, so it is workload-dependent; `fillfactor = 80` reached 100% for this frac
larger share of queues at once would need a lower value. `fillfactor` applies to pages rewritten after
the change, so the ratio ramps up as the heap turns over, or immediately after `pg_repack`.
Dropping the index regresses the deprecated journal message store's expiration (`foldRecentQueueRecs`,
`Journal.hs:434`) to a sequential scan; this is accepted because that store is being retired. The
Postgres message store does not read `updated_at`.
The Postgres message store does not read `updated_at`, so no query depends on the dropped index.
Autovacuum reloptions applied by the migration:
plans/2026-10-07-parallel-tests.md
+80
View File
@@ -0,0 +1,80 @@
# Parallel test execution
Every test gets its own ports, directory and Postgres schemas, so hspec runs
the tree concurrently in one process with `parallel` and `--jobs`.
## Decisions
- `Util` defines the test environment:
```haskell
data TestEnv = TestEnv
{ testNo :: Int,
portBase :: Int
}
type HasTestEnv = (?testEnv :: TestEnv)
```
- `Util.it`, `fit` and `xit` take `HasTestEnv => a`. The test wrapper
creates the environment for each attempt, so a CI retry gets fresh ports,
directory and schemas.
- Environment creation:
- `testNo` from a counter, never reused in a run.
- `portBase` from a pool `[10000, 10010 .. 19990]`, returned after the test.
- directory `tests/tmp/<testNo>` with `xftp-sender-files` and
`xftp-recipient-files`, removed after the test.
- Fixture constants become `HasTestEnv =>` values:
- ports: offsets from `portBase`
| offset | fixture |
|--------|-----------------|
| 1 | `testPort` |
| 2 | `testPort2` |
| 3 | `ntfTestPort` |
| 4 | `ntfTestPort2` |
| 5 | `apnsTestPort` |
| 6 | `xftpTestPort` |
| 7 | `xftpTestPort2` |
- server addresses: built from the ports.
- files: in the test directory.
- Postgres schemas: `test<testNo>_<name>`.
- Functions that use fixtures gain `HasTestEnv` in their signatures.
- `withXFTPServerCfg` creates the server files directory.
- Removed hooks:
- `tests/tmp` creation and removal per test.
- per-test database recreation and schema drops.
- XFTP `testBracket` and server files directory hooks.
- `around (withMsgStore cfg)`: each test opens its store.
- `tests/tmp` is cleared before the run and removed after it.
- Postgres databases are created before the run and dropped after it.
- Schema dumps and the Ntf CLI test keep the production schema names and
recreate the database per test.
- Sequential, after all parallel tests:
- SMP proxy tests that change the number of capabilities.
- XFTP CLI tests: `withArgs` and stdout capture are process-wide.
- server CLI tests: the same, and fixed ports.
- tests with wall-clock assertions:
- retry intervals
- AUTH error timing
- agent user network info
- agent SMP queue info
- agent client notices
- schema dumps.
- The SQLite agent schema dump resets `tests/tmp` after each item.
- `createRandomFile_` in the XFTP agent tests writes random bytes directly.
- Test suite `-with-rtsopts=-N1` becomes `-with-rtsopts=-N`.
- `it "..." . f $ x` becomes `it "..." $ f $ x` where `f` or `x` uses the
environment.
## Mechanics
- `tests/Util.hs`: environment, wrapper, `it`, `fit`, `xit`,
`eventuallyRemove`, sender and recipient directories.
- `tests/Test.hs`: `parallel` tree, sequential tail, `tests/tmp` and database
brackets around `hspec`.
- `tests/SMPClient.hs`, `tests/SMPAgentClient.hs`, `tests/NtfClient.hs`,
`tests/XFTPClient.hs`, `tests/Fixtures.hs`: fixtures from the environment.
- Test modules: signatures, literal paths and ports, removed hooks.
- `simplexmq.cabal`: `-N`.
plans/2026-10-08-fast-rotation-old-queue-drain.md
+62
View File
@@ -0,0 +1,62 @@
# Fast rotation: draining the old receive queue
Recipient only. The sender is unchanged.
## Decisions
- New `RcvSwitchStatus` value:
| constructor | encoding |
|------------------|-----------------|
| `RSReceivedQEND` | `received_qend` |
- Stored in `rcv_queues.switch_status`.
- `canAbortRcvSwitch` returns `False` for it.
- `qEndMsg`, by the queue that delivered `QEND`:
- the queue named in `QEND`: the named queue is marked deleted, `ICDeleteRcvQueue` is enqueued.
- the new queue: the named queue is set to `RSReceivedQEND` and stays subscribed.
- `NSCCreate` and `SWITCH QDRcv SPCompleted`: sent when the named queue had no `RSReceivedQEND`.
- Deletion of an `RSReceivedQEND` queue:
- trigger: `OK` response to an `ACK` on that queue, without a `GET` lock on it.
- action: the queue is marked deleted, `ICDeleteRcvQueue` is enqueued.
- Bound, a `cleanupManager` step, for each connection with an `RSReceivedQEND` queue:
- condition: another receive queue of the connection has an active subscription.
- `delete_errors + 1 < deleteErrorCount`: `delete_errors` is incremented.
- otherwise: the queue is deleted as above; the first `DEL` error of `ICDeleteRcvQueue` removes it locally.
- `ackSMPMessage` result, `type QueueDrained = Bool`:
- `OK`: `True`.
- `MSG`: `False`; the message is written to `msgQ`.
- Apps: `received_qend` is added to `RcvSwitchStatus`.
- Migration `20261008_rcv_switch_status`, SQLite and Postgres:
- up: index `idx_rcv_queues_switch_status` on `rcv_queues(switch_status)`.
- down: `received_qend` is set to `NULL`, the index is dropped.
## Mechanics
- `Agent/Protocol.hs`: `RSReceivedQEND`.
- `Agent/Store.hs`: `canAbortRcvSwitch`.
- `Client.hs`: `QueueDrained`; `ackSMPMessage` returns it.
- `Agent/Client.hs`: `sendAck` returns `QueueDrained`.
- `Agent/Store/AgentStore.hs`: `getEndedRcvQueueConnIds`:
```sql
SELECT conn_id FROM rcv_queues WHERE switch_status = ? AND deleted = 0
```
- `Agent.hs`:
- `deleteRcvQueueAsync`: `setRcvQueueDeleted`, then `ICDeleteRcvQueue`.
- `qEndMsg`.
- `ackQueueMessage`.
- `cleanupManager`: `expireEndedRcvQueues`.
- Apps:
- `apps/ios/SimpleXChat/APITypes.swift`
- `apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt`
## Tests
- `QEND` on the new queue while a message waits on the old queue:
- the message is delivered;
- the old queue is deleted after the `ACK` that returns `OK`.
- The same with a recipient restart before the `ACK`.
- Old server stopped: the old queue is deleted by the bound.
- Downgrade: `received_qend` is cleared, other switch statuses are kept.
plans/2026-10-09-auth-error-delay.md
+52
View File
@@ -0,0 +1,52 @@
# Delayed AUTH error responses
## Decisions
- Responses that include `ERR AUTH` are sent at the next multiple of the delay after the start time.
- Delayed response sets:
| Source | Responses sent together | Start time |
|---|---|---|
| `receive`, failed verification | verification and parsing errors of one received block | block receipt |
| `client`, command processing | responses and messages of one batch | batch read from `rcvQ` |
| `RFWD`, forwarded command | the `RRES` of that command | start of forwarded command processing |
- A thread created by `forkClient` writes the responses to the send queue.
- Delay 0: the responses are written to the send queue directly.
- `authDelayExceeded`: incremented when processing took longer than the delay.
- Prometheus counter `simplex_smp_auth_delay_exceeded`.
- Not saved in the stats backup.
- Not in the daily stats log.
- Configuration:
| Item | Value |
|---|---|
| INI section | `TRANSPORT` |
| INI key | `auth_error_delay_ms` |
| default | 50 |
| `ServerConfig` field | `authErrorDelay`, microseconds |
| test servers | 20 ms |
- AUTH timing test: elapsed time of 5 requests, test servers' delay.
- Out of scope: NTF and XFTP servers.
## Mechanics
- `Server.hs`:
- `isAuthError`: response is `ERR AUTH`.
- `sendResponses`: responses with `ERR AUTH` to `sendAfterDelay`, others to the send queue.
- `sendAfterDelay`: writes responses to the send queue at the next multiple of the delay.
- `receive`: block receipt time from the `rcvActiveAt` reading.
- `client`: batch time.
- `processForwardedCommand`: start time.
- `Server/Env/STM.hs`: `authErrorDelay` field, `defaultAuthErrorDelayMs`.
- `Server/Stats.hs`: `authDelayExceeded` in `ServerStats` and `ServerStatsData`.
- `Server/Prometheus.hs`: `simplex_smp_auth_delay_exceeded`.
- `Server/Main.hs`: INI value.
- `Server/Main/Init.hs`: INI template line.
- `simplexmq.cabal`: `timeit` removed from the test suite.
- `tests/SMPClient.hs`: `authErrorDelay = 20000`.
- `tests/ServerTests.hs`:
- delayed AUTH for wrong key, absent queue, absent link and suspended queue; immediate `SOK`.
- AUTH timing test measures elapsed time.
- `tests/SMPProxyTests.hs`: delayed AUTH to forwarded `SEND` and `LGET`.
protocol/agent-protocol.md
+3 -2
View File
@@ -208,7 +208,7 @@ This syntax of decrypted SMP client message body is defined by `decryptedAgentMe
Decrypted SMP message client body can be one of 4 types:
- `agentConnInfo` - used by the initiating party when confirming reply queue - sent in `agentConfirmation` envelope.
- `agentConnInfoReply` - used by accepting party, includes reply queue(s) in the initial confirmation - sent in `agentConfirmation` envelope.
- `agentRatchetInfo` - used to pass additional information when renegotiating double ratchet encryption - sent in `agentRatchetKey` envelope.
- `agentRatchetInfo` - used to pass additional information when renegotiating double ratchet encryption - sent in `agentRatchetKey` envelope. A key sent in reply to another key includes the hash of that key; agents do not reply to such keys.
- `agentMessage` - all other agent messages.
`agentMessage` contains these parts:
@@ -233,7 +233,8 @@ connInfo = *OCTET
agentConnInfoReply = %s"D" smpQueues connInfo
smpQueues = length 1*newQueueInfo ; NonEmpty list of reply queues
agentRatchetInfo = %s"R" ratchetInfo
ratchetInfo = *OCTET
ratchetInfo = [answeredKeyHash *OCTET] ; bytes after answeredKeyHash are ignored
answeredKeyHash = %s"0" / (%s"1" shortString) ; "0" in a key that starts renegotiation, otherwise SHA-256 of the two raw public keys of the answered key
agentMessage = %s"M" agentMsgHeader aMessage
agentMsgHeader = agentMsgId prevMsgHash
scripts/ci/prune-old-builds.sh
Executable
+9
View File
@@ -0,0 +1,9 @@
#!/bin/sh
set -eu
version=$(awk '/^version:/ {print $2}' simplexmq.cabal)
for dir in "$@"; do
if [ -d "$dir/build" ]; then
find "$dir/build" -mindepth 3 -maxdepth 3 -type d -name 'simplexmq-*' ! -name "simplexmq-$version" -exec rm -rf {} +
fi
done
scripts/ci/source-timestamps.sh
Executable
+27
View File
@@ -0,0 +1,27 @@
#!/bin/sh
set -eu
command=$1
hashes=$2
sources() {
git ls-files -z '*.hs' '*.hsc'
}
case "$command" in
record)
sources | xargs -0 sha256sum > "$hashes"
;;
restore)
sources | xargs -0 touch
while read -r hash file; do
if [ -f "$file" ] && [ "$(sha256sum "$file" | cut -d' ' -f1)" = "$hash" ]; then
touch -d 2000-01-01 "$file"
fi
done < "$hashes"
;;
*)
echo "usage: $0 record|restore <hashes file>" >&2
exit 1
;;
esac
simplexmq.cabal
+7 -5
View File
@@ -1,7 +1,7 @@
cabal-version: 3.0
name: simplexmq
version: 7.1.0.10
version: 7.1.0.11
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -195,6 +195,8 @@ library
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260929_ratchet_indexes
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20261008_rcv_switch_status
else
exposed-modules:
Simplex.Messaging.Agent.Store.SQLite
@@ -250,6 +252,9 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260929_ratchet_indexes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261005_commands_autoincrement
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261008_rcv_switch_status
Simplex.Messaging.Agent.Store.SQLite.Util
if flag(client_postgres) || flag(server_postgres)
exposed-modules:
@@ -279,8 +284,6 @@ library
Simplex.Messaging.Server.Main.Init
Simplex.Messaging.Server.Web
Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.Journal
Simplex.Messaging.Server.MsgStore.Journal.SharedLock
Simplex.Messaging.Server.MsgStore.STM
Simplex.Messaging.Server.MsgStore.Types
Simplex.Messaging.Server.Names
@@ -597,7 +600,7 @@ test-suite simplexmq-test
default-extensions:
StrictData
-- add -fhpc to ghc-options to run tests with coverage
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts "-with-rtsopts=-A64M -N"
build-depends:
base
, aeson
@@ -635,7 +638,6 @@ test-suite simplexmq-test
, stm
, text
, time
, timeit ==2.0.*
, tls >=1.9.0 && <1.10
, transformers
, unliftio
src/Simplex/FileTransfer/Agent.hs
+10 -6
View File
@@ -279,6 +279,7 @@ retryOnError name loop done e = do
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do
liftIO $ throwWhenInactive c
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err)
@@ -318,9 +319,6 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
withStore' c (`updateRcvFileComplete` rcvFileId)
Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do
let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
liftIO $ waitUntilForeground c
withStore' c (`updateRcvFileComplete` rcvFileId)
-- proceed with redirect
yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `allFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
@@ -330,9 +328,12 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
| dstSize /= redirectSize -> throwE . FILE $ REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwE . FILE $ REDIRECT "digest mismatch"
| otherwise -> pure fd
liftIO $ waitUntilForeground c
-- register and download chunks from the actual file
withStore c $ \db -> updateRcvFileRedirect db redirectDbId next
withStore c $ \db -> updateRcvFileComplete db rcvFileId >> updateRcvFileRedirect db redirectDbId next
forM_ nextChunks (downloadChunk c)
flip catchAllErrors (\e -> logError $ "XFTP rcv worker error: " <> tshow e) $
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
where
getChunkPaths :: [RcvFileChunk] -> AM [FilePath]
getChunkPaths [] = pure []
@@ -512,6 +513,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
sndWorkerInternalError c sndFileId sndFileEntityId prefixPath err = do
liftIO $ throwWhenInactive c
lift . forM_ prefixPath $ removePath <=< toFSFilePath
withStore' c $ \db -> updateSndFileError db sndFileId (show err)
notify c sndFileEntityId $ SFERR err
@@ -568,9 +570,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
notify c sndFileEntityId $ SFPROG uploaded total
when complete $ do
(sndDescr, rcvDescrs) <- sndFileToDescrs sf
flip catchAllErrors (\e -> logError $ "XFTP snd worker error: " <> tshow e) $ do
lift . forM_ prefixPath $ removePath <=< toFSFilePath
withStore' c $ \db -> updateSndFileComplete db sndFileId
notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks)
lift . forM_ prefixPath $ removePath <=< toFSFilePath
withStore' c $ \db -> updateSndFileComplete db sndFileId
where
addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {sndChunkReplicaId, rcvIdsKeys}
@@ -732,6 +735,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
delWorkerInternalError c deletedSndChunkReplicaId e = do
liftIO $ throwWhenInactive c
withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
notify c "" $ SFERR e
src/Simplex/FileTransfer/Protocol.hs
+2 -2
View File
@@ -80,7 +80,7 @@ import Simplex.Messaging.Protocol
tParse,
)
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
xftpBlockSize :: Int
xftpBlockSize = 16384
@@ -383,7 +383,7 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey t@(corrId, _, _) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams t
xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (C.cbNonce $ bs corrId) tForAuth
xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (eitherToMaybe $ C.cbNonce $ bs corrId) tForAuth
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
xftpEncodeTransmission thParams t = xftpEncodeBatch1 (Nothing, encodeTransmission thParams t)
src/Simplex/Messaging/Agent.hs
+400 -284
View File
File diff suppressed because it is too large. Load diff
src/Simplex/Messaging/Agent/Client.hs
+8 -11
View File
@@ -34,7 +34,6 @@ module Simplex.Messaging.Agent.Client
withInvLock,
withLockMap,
withLocksMap,
getMapLock,
ipAddressProtected,
closeAgentClient,
closeProtocolServerClients,
@@ -312,7 +311,7 @@ import Simplex.Messaging.Session
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion)
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), newNtfCredsSMPVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials
import Simplex.Messaging.Util
@@ -1499,7 +1498,7 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
let sessServiceId = (\THClientService {serviceId = sId} -> sId) <$> (clientService =<< thAuth thParams')
when (isJust serviceId && serviceId /= sessServiceId) $ logError "incorrect service ID in NEW response"
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
shortLink <- mkShortLinkCreds thParams' qik
shortLink <- mkShortLinkCreds qik
let rq =
RcvQueue
{ userId,
@@ -1540,8 +1539,8 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
(Just ((ntfPublicKey, ntfPrivateKey), dhpk), Just (ServerNtfCreds notifierId dhk')) ->
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret = C.dh' dhk' dhpk}
_ -> Nothing
mkShortLinkCreds :: THandleParams SMPVersion 'TClient -> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
mkShortLinkCreds thParams' QIK {sndId, queueMode, linkId} = case (cqrd, queueMode) of
mkShortLinkCreds :: QueueIdsKeys -> AM (Maybe ShortLinkCreds)
mkShortLinkCreds QIK {sndId, queueMode, linkId} = case (cqrd, queueMode) of
(CQRMessaging ld, Just QMMessaging) ->
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
if sndId == sndId'
@@ -1555,11 +1554,9 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enabl
(_, Nothing) -> newErr "unexpected link ID"
_ -> newErr "unexpected queue mode"
where
v = thVersion thParams'
withLinkData :: Maybe d -> (SMP.LinkId -> d -> AM (Maybe ShortLinkCreds)) -> AM (Maybe ShortLinkCreds)
withLinkData ld_ mkLink = case (ld_, linkId) of
(Just ld, Just lnkId) -> mkLink lnkId ld
(Just _, Nothing) | v < shortLinksSMPVersion -> pure Nothing
(Nothing, Nothing) -> pure Nothing
_ -> newErr "unexpected or absent link ID"
newErr :: String -> AM (Maybe ShortLinkCreds)
@@ -1984,7 +1981,7 @@ decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
liftEither $ parse SMP.clientRcvMsgBodyP (AGENT $ A_MESSAGE "decrypt message") =<< decrypt body
where
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
decrypt = agentCbDecrypt (rcvDhSecret rq) msgId
secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM ()
secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
@@ -2082,9 +2079,9 @@ disableQueuesNtfs c = sendTSessionBatches "NDEL" (mkSMPTSession . snd) disableQu
queueCreds :: DisableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey)
queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvId, rcvPrivateKey)
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM QueueDrained
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp ->
withSMPClient c NRMBackground rq ("ACK:" <> logSecret' (SMP.unMsgId msgId)) $ \smp ->
ackSMPMessage smp rcvPrivateKey rcvId msgId
hasGetLock :: SomeRcvQueue q => AgentClient -> q -> IO Bool
@@ -2279,7 +2276,7 @@ agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
-- | NaCl crypto-box decrypt - both for messages received from the server
-- and per-queue E2E encrypted messages from the sender that were inside.
agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> Either AgentErrorType ByteString
agentCbDecrypt :: C.CbNonceI n => C.DhSecretX25519 -> n -> ByteString -> Either AgentErrorType ByteString
agentCbDecrypt dhSecret nonce msg =
first cryptoError $
C.cbDecrypt dhSecret nonce msg
src/Simplex/Messaging/Agent/Lock.hs
-1
View File
@@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Lock
withLock',
withGetLock,
withGetLocks,
getPutLock,
)
where
src/Simplex/Messaging/Agent/Protocol.hs
+20 -7
View File
@@ -79,6 +79,7 @@ module Simplex.Messaging.Agent.Protocol
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
RatchetInfo (..),
RequestSignature (..),
AgentMessageType (..),
APrivHeader (..),
@@ -245,7 +246,6 @@ import Simplex.Messaging.Crypto.Ratchet
RcvE2ERatchetParams,
RcvE2ERatchetParamsUri,
SndE2ERatchetParams,
RcvE2EPrivRatchetParams,
pattern PQSupportOff,
pattern PQSupportOn,
)
@@ -611,6 +611,7 @@ data RcvSwitchStatus
| RSSendingQADD
| RSSendingQUSE
| RSReceivedMessage
| RSReceivedQEND
deriving (Eq, Show)
instance StrEncoding RcvSwitchStatus where
@@ -619,12 +620,14 @@ instance StrEncoding RcvSwitchStatus where
RSSendingQADD -> "sending_qadd"
RSSendingQUSE -> "sending_quse"
RSReceivedMessage -> "received_message"
RSReceivedQEND -> "received_qend"
strP =
A.takeTill (== ' ') >>= \case
"switch_started" -> pure RSSwitchStarted
"sending_qadd" -> pure RSSendingQADD
"sending_quse" -> pure RSSendingQUSE
"received_message" -> pure RSReceivedMessage
"received_qend" -> pure RSReceivedQEND
_ -> fail "bad RcvSwitchStatus"
instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode
@@ -928,7 +931,7 @@ data AgentMessage
| -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It made removed REPLY message unnecessary.
AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
| AgentRatchetInfo ByteString
| AgentRatchetInfo RatchetInfo
| AgentMessage APrivHeader AMessage
| AgentServiceRequest (NonEmpty SMPQueueInfo) (Maybe RequestSignature) MsgBody
| AgentServiceResponse MsgBody
@@ -939,7 +942,7 @@ 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)
AgentRatchetInfo info -> smpEncode ('R', info)
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
AgentServiceRequest qs sig_ body -> smpEncode ('A', qs, sig_, Tail body)
AgentServiceResponse body -> smpEncode ('P', Tail body)
@@ -948,13 +951,23 @@ instance Encoding AgentMessage where
smpP >>= \case
'I' -> AgentConnInfo . unTail <$> smpP
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
'R' -> AgentRatchetInfo . unTail <$> smpP
'R' -> AgentRatchetInfo <$> smpP
'M' -> AgentMessage <$> smpP <*> smpP
'A' -> AgentServiceRequest <$> smpP <*> smpP <*> (unTail <$> smpP)
'P' -> AgentServiceResponse . unTail <$> smpP
'J' -> AgentRejection . unTail <$> smpP
_ -> fail "bad AgentMessage"
data RatchetInfo = RatchetInfo {answeredKeyHash :: Maybe ByteString}
deriving (Eq, Show)
instance Encoding RatchetInfo where
smpEncode RatchetInfo {answeredKeyHash} = smpEncode answeredKeyHash
smpP = do
answeredKeyHash <- smpP <|> pure Nothing
_ <- A.takeByteString
pure RatchetInfo {answeredKeyHash}
-- internal type for storing message type in the database
data AgentMessageType
= AM_CONN_INFO
@@ -1613,7 +1626,7 @@ newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
-- | Parameters for creating a connection with a prepared link.
data PreparedLinkParams = PreparedLinkParams
data PreparedLinkParams k = PreparedLinkParams
{ -- | Correlation ID / determines sender ID
plpNonce :: C.CbNonce,
-- | Queue E2EE DH key pair
@@ -1628,8 +1641,8 @@ data PreparedLinkParams = PreparedLinkParams
plpSrvWithAuth :: SMPServerWithAuth,
-- | Initial PQ keys
plpInitKeys :: InitialKeys,
-- | Contact address double ratchet keys
plpAddressKeys :: Maybe (RatchetKeyId, RcvE2EPrivRatchetParams 'C.X448)
-- | Contact address double ratchet keys or invitation X3DH keys
plpRatchetKeys :: k
}
instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode
src/Simplex/Messaging/Agent/Store.hs
+1
View File
@@ -219,6 +219,7 @@ canAbortRcvSwitch ConnData {connAgentVersion} = maybe False canAbort . rcvSwchSt
-- 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
RSReceivedQEND -> False
data ClientNtfCreds = ClientNtfCreds
{ -- | key pair to be used by the notification server to authorize transmissions
src/Simplex/Messaging/Agent/Store/AgentStore.hs
+52 -22
View File
@@ -76,6 +76,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
getExpiredServiceConns,
deleteExpiredServiceRequests,
getDeletedWaitingDeliveryConnIds,
getConnRatchetSync,
setConnRatchetSync,
addProcessedRatchetKeyHash,
checkRatchetKeyHashExists,
@@ -99,6 +100,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
setSndQueuePrimary,
deleteConnRcvQueue,
incRcvDeleteErrors,
getEndedRcvQueueConnIds,
deleteConnSndQueue,
getPrimaryRcvQueue,
getRcvQueue,
@@ -762,6 +764,10 @@ incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO ()
incRcvDeleteErrors db RcvQueue {connId, dbQueueId} =
DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
getEndedRcvQueueConnIds :: DB.Connection -> IO [ConnId]
getEndedRcvQueueConnIds db =
map fromOnly <$> DB.query db "SELECT conn_id FROM rcv_queues WHERE switch_status = ? AND deleted = 0" (Only RSReceivedQEND)
deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO ()
deleteConnRcvQueue db RcvQueue {connId, dbQueueId} =
DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
@@ -1254,7 +1260,7 @@ getLastMsg db connId msgId =
LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id
WHERE r.conn_id = ? AND r.broker_id = ?
|]
(connId, Binary msgId)
(connId, msgId)
toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, BoolInt) -> RcvMsg
toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, BI userAck)) =
@@ -1286,7 +1292,7 @@ checkRcvMsgHashExists db connId hash =
getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
getRcvMsgBrokerTs db connId msgId =
firstRow fromOnly (SEMsgNotFound "getRcvMsgBrokerTs") $
DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId)
DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId)
deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
deleteMsg db connId msgId =
@@ -1594,12 +1600,16 @@ getRatchet_ q db connId =
where
ratchet = maybe (Left SERatchetNotFound) Right . fromOnly
getSkippedMsgKeys :: DB.Connection -> ConnId -> IO SkippedMsgKeys
getSkippedMsgKeys db connId =
skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)
getSkippedMsgKeys :: DB.Connection -> ConnId -> Int -> IO SkippedMsgKeys
getSkippedMsgKeys db connId maxKeys = do
(keys, oldKeys) <- splitAt maxKeys <$> DB.query db "SELECT skipped_message_id, header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ? ORDER BY skipped_message_id DESC LIMIT ?" (connId, maxKeys + 1)
case oldKeys of
(skippedMsgId :: Int64, _, _, _) : _ -> DB.execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND skipped_message_id <= ?" (connId, skippedMsgId)
[] -> pure ()
pure $ skipped keys
where
skipped = foldl' addSkippedKey M.empty
addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
addSkippedKey smks (_, hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
where
addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk)
@@ -2793,6 +2803,11 @@ getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId]
getDeletedWaitingDeliveryConnIds db =
map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL"
getConnRatchetSync :: DB.Connection -> ConnId -> IO (Either StoreError RatchetSyncState)
getConnRatchetSync db connId =
firstRow fromOnly SEConnNotFound $
DB.query db "SELECT ratchet_sync_state FROM connections WHERE conn_id = ?" (Only connId)
setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
setConnRatchetSync db connId ratchetSyncState =
DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
@@ -2814,21 +2829,35 @@ checkRatchetKeyHashExists db connId hash =
(connId, Binary hash)
deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> Int -> IO ()
deleteRatchetKeyHashesExpired db ttl limit = do
deleteRatchetKeyHashesExpired db ttl maxConnHashes = do
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
#if defined(dbPostgres)
DB.execute
db
[sql|
DELETE FROM processed_ratchet_key_hashes
WHERE processed_ratchet_key_hash_id IN (
SELECT processed_ratchet_key_hash_id
FROM processed_ratchet_key_hashes
WHERE created_at < ?
ORDER BY created_at ASC
LIMIT ?
)
|]
(cutoffTs, limit)
("DELETE FROM processed_ratchet_key_hashes h USING (" <> maxExcessIdsQuery <> ") e WHERE h.conn_id = e.conn_id AND h.processed_ratchet_key_hash_id <= e.max_excess_id AND h.created_at < ?")
(maxConnHashes, maxConnHashes, cutoffTs)
#else
maxExcessIds <- DB.query db maxExcessIdsQuery (maxConnHashes, maxConnHashes)
DB.executeMany
db
"DELETE FROM processed_ratchet_key_hashes WHERE conn_id = ? AND processed_ratchet_key_hash_id <= ? AND created_at < ?"
(map (\(connId :: ConnId, maxExcessId :: Int64) -> (connId, maxExcessId, cutoffTs)) maxExcessIds)
#endif
where
maxExcessIdsQuery :: Query
maxExcessIdsQuery =
[sql|
SELECT conn_id, (
SELECT processed_ratchet_key_hash_id
FROM processed_ratchet_key_hashes
WHERE conn_id = c.conn_id
ORDER BY processed_ratchet_key_hash_id DESC
LIMIT 1 OFFSET ?
) AS max_excess_id
FROM processed_ratchet_key_hashes c
GROUP BY conn_id
HAVING COUNT(*) > ?
|]
-- | returns all connection queues, the first queue is the primary one
getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
@@ -3011,7 +3040,7 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna
VALUES
(?,?,?,?,?,?,?,?,?,?)
|]
(connId, dbQueueId, internalRcvId, fst recipient, sndMsgId, Binary (fst broker), snd broker, Binary internalHash, Binary externalPrevSndHash, integrity)
(connId, dbQueueId, internalRcvId, fst recipient, sndMsgId, fst broker, snd broker, Binary internalHash, Binary externalPrevSndHash, integrity)
DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary encryptedMsgHash)
updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO ()
@@ -3159,7 +3188,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId)
createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays
nonce <- atomically $ C.randomCbNonce gVar
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId (dummyDst nonce) prefixPath dstPath dstFile Nothing Nothing approvedRelays
(_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays
liftIO $
forM_ redirectChunks $ \fc@FileChunk {replicas} -> do
@@ -3167,7 +3197,7 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire
forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
pure dstEntityId
where
dummyDst =
dummyDst nonce =
FileDescription
{ party = SFRecipient,
size,
@@ -3175,7 +3205,7 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire
redirect = Nothing,
-- updated later with updateRcvFileRedirect
key = C.unsafeSbKey $ B.replicate 32 '#',
nonce = C.cbNonce "",
nonce,
chunkSize = FileSize 0,
chunks = []
}
src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs
+5 -1
View File
@@ -16,6 +16,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260929_ratchet_indexes
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20261008_rcv_switch_status
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Text, Maybe Text)]
@@ -31,7 +33,9 @@ schemaMigrations =
("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes),
("20260929_ratchet_indexes", m20260929_ratchet_indexes, Just down_m20260929_ratchet_indexes),
("20261008_rcv_switch_status", m20261008_rcv_switch_status, Just down_m20261008_rcv_switch_status)
]
-- | The list of migrations in ascending order by date
src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260929_ratchet_indexes.hs
+34
View File
@@ -0,0 +1,34 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260929_ratchet_indexes where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260929_ratchet_indexes :: Text
m20260929_ratchet_indexes =
[r|
DROP INDEX idx_skipped_messages_conn_id;
CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id, skipped_message_id);
DELETE FROM processed_ratchet_key_hashes AS h
WHERE EXISTS (
SELECT 1 FROM processed_ratchet_key_hashes d
WHERE d.conn_id = h.conn_id AND d.hash = h.hash AND d.processed_ratchet_key_hash_id < h.processed_ratchet_key_hash_id
);
DROP INDEX idx_processed_ratchet_key_hashes_hash;
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(conn_id, processed_ratchet_key_hash_id);
|]
down_m20260929_ratchet_indexes :: Text
down_m20260929_ratchet_indexes =
[r|
DROP INDEX idx_processed_ratchet_key_hashes_conn_id;
DROP INDEX idx_processed_ratchet_key_hashes_hash;
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
DROP INDEX idx_skipped_messages_conn_id;
CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
|]
src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20261008_rcv_switch_status.hs
+20
View File
@@ -0,0 +1,20 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20261008_rcv_switch_status where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20261008_rcv_switch_status :: Text
m20261008_rcv_switch_status =
[r|
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
|]
down_m20261008_rcv_switch_status :: Text
down_m20261008_rcv_switch_status =
[r|
UPDATE rcv_queues SET switch_status = NULL WHERE switch_status = 'received_qend';
DROP INDEX idx_rcv_queues_switch_status;
|]
src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql
+10 -7
View File
@@ -1,5 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -1169,11 +1167,15 @@ CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON smp_agent_test_protocol_schema.
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, processed_ratchet_key_hash_id);
CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (created_at);
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, hash);
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON smp_agent_test_protocol_schema.processed_ratchet_key_hashes USING btree (conn_id, hash);
@@ -1229,6 +1231,10 @@ CREATE UNIQUE INDEX idx_rcv_queues_ntf ON smp_agent_test_protocol_schema.rcv_que
CREATE INDEX idx_rcv_queues_switch_status ON smp_agent_test_protocol_schema.rcv_queues USING btree (switch_status);
CREATE INDEX idx_rcv_queues_to_subscribe ON smp_agent_test_protocol_schema.rcv_queues USING btree (to_subscribe);
@@ -1241,7 +1247,7 @@ CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON smp_agent_test_protoco
CREATE INDEX idx_skipped_messages_conn_id ON smp_agent_test_protocol_schema.skipped_messages USING btree (conn_id);
CREATE INDEX idx_skipped_messages_conn_id ON smp_agent_test_protocol_schema.skipped_messages USING btree (conn_id, skipped_message_id);
@@ -1523,6 +1529,3 @@ ALTER TABLE ONLY smp_agent_test_protocol_schema.snd_queues
ALTER TABLE ONLY smp_agent_test_protocol_schema.snd_queues
ADD CONSTRAINT snd_queues_host_port_fkey FOREIGN KEY (host, port) REFERENCES smp_agent_test_protocol_schema.servers(host, port) ON UPDATE CASCADE ON DELETE RESTRICT;
src/Simplex/Messaging/Agent/Store/SQLite/Common.hs
+2 -1
View File
@@ -100,7 +100,8 @@ withTransaction st = withTransactionPriority st False
{-# INLINE withTransaction #-}
withTransactionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a
withTransactionPriority st priority action = withConnectionPriority st priority $ dbBusyLoop . transaction
withTransactionPriority st@DBStore {dbClosed} priority action = withConnectionPriority st priority $ \db ->
ifM (readTVarIO dbClosed) (fail "withTransaction: database closed") (dbBusyLoop $ transaction db)
where
transaction db@DB.Connection {conn} = SQL.withImmediateTransaction conn $ action db
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs
+7 -1
View File
@@ -52,6 +52,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260929_ratchet_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261005_commands_autoincrement
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261008_rcv_switch_status
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -103,7 +106,10 @@ schemaMigrations =
("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes),
("m20260929_ratchet_indexes", m20260929_ratchet_indexes, Just down_m20260929_ratchet_indexes),
("m20261005_commands_autoincrement", m20261005_commands_autoincrement, Just down_m20261005_commands_autoincrement),
("m20261008_rcv_switch_status", m20261008_rcv_switch_status, Just down_m20261008_rcv_switch_status)
]
-- | The list of migrations in ascending order by date
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260929_ratchet_indexes.hs
+29
View File
@@ -0,0 +1,29 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260929_ratchet_indexes where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
-- idx_skipped_messages_conn_id is not changed: SQLite index entries include rowid (skipped_message_id)
m20260929_ratchet_indexes :: Query
m20260929_ratchet_indexes =
[sql|
DELETE FROM processed_ratchet_key_hashes AS h
WHERE EXISTS (
SELECT 1 FROM processed_ratchet_key_hashes d
WHERE d.conn_id = h.conn_id AND d.hash = h.hash AND d.processed_ratchet_key_hash_id < h.processed_ratchet_key_hash_id
);
DROP INDEX idx_processed_ratchet_key_hashes_hash;
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(conn_id, processed_ratchet_key_hash_id);
|]
down_m20260929_ratchet_indexes :: Query
down_m20260929_ratchet_indexes =
[sql|
DROP INDEX idx_processed_ratchet_key_hashes_conn_id;
DROP INDEX idx_processed_ratchet_key_hashes_hash;
CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(conn_id, hash);
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20261005_commands_autoincrement.hs
+33
View File
@@ -0,0 +1,33 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261005_commands_autoincrement where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20261005_commands_autoincrement :: Query
m20261005_commands_autoincrement =
[sql|
INSERT INTO sqlite_sequence (name, seq)
SELECT 'commands', MAX(ROWID) FROM commands;
PRAGMA writable_schema=1;
UPDATE sqlite_master SET sql = replace(sql, 'command_id INTEGER PRIMARY KEY,', 'command_id INTEGER PRIMARY KEY AUTOINCREMENT,')
WHERE name = 'commands' AND type = 'table';
PRAGMA writable_schema=RESET;
|]
down_m20261005_commands_autoincrement :: Query
down_m20261005_commands_autoincrement =
[sql|
DELETE FROM sqlite_sequence WHERE name = 'commands';
PRAGMA writable_schema=1;
UPDATE sqlite_master SET sql = replace(sql, 'command_id INTEGER PRIMARY KEY AUTOINCREMENT,', 'command_id INTEGER PRIMARY KEY,')
WHERE name = 'commands' AND type = 'table';
PRAGMA writable_schema=RESET;
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20261008_rcv_switch_status.hs
+19
View File
@@ -0,0 +1,19 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20261008_rcv_switch_status where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20261008_rcv_switch_status :: Query
m20261008_rcv_switch_status =
[sql|
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
|]
down_m20261008_rcv_switch_status :: Query
down_m20261008_rcv_switch_status =
[sql|
UPDATE rcv_queues SET switch_status = NULL WHERE switch_status = 'received_qend';
DROP INDEX idx_rcv_queues_switch_status;
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+11 -6
View File
@@ -247,7 +247,7 @@ CREATE TABLE ntf_subscriptions(
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID, STRICT;
CREATE TABLE commands(
command_id INTEGER PRIMARY KEY,
command_id INTEGER PRIMARY KEY AUTOINCREMENT,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
host TEXT,
port TEXT,
@@ -261,6 +261,7 @@ CREATE TABLE commands(
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE
) STRICT;
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE snd_message_deliveries(
snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
@@ -269,7 +270,6 @@ CREATE TABLE snd_message_deliveries(
failed INTEGER DEFAULT 0,
FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
) STRICT;
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE users(
user_id INTEGER PRIMARY KEY AUTOINCREMENT
,
@@ -573,10 +573,6 @@ 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
);
CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(
conn_id,
rcpt_internal_id
@@ -641,6 +637,15 @@ CREATE INDEX idx_connections_deleted ON connections(deleted);
CREATE INDEX idx_connections_service_request_expires_at ON connections(
service_request_expires_at
);
CREATE UNIQUE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
conn_id,
hash
);
CREATE INDEX idx_processed_ratchet_key_hashes_conn_id ON processed_ratchet_key_hashes(
conn_id,
processed_ratchet_key_hash_id
);
CREATE INDEX idx_rcv_queues_switch_status ON rcv_queues(switch_status);
CREATE TRIGGER tr_rcv_queue_insert
AFTER INSERT ON rcv_queues
FOR EACH ROW
src/Simplex/Messaging/Client.hs
+14 -11
View File
@@ -67,6 +67,7 @@ module Simplex.Messaging.Client
enableSMPQueuesNtfs,
disableSMPQueuesNtfs,
sendSMPMessage,
QueueDrained,
ackSMPMessage,
suspendSMPQueue,
deleteSMPQueue,
@@ -1087,15 +1088,17 @@ resolvedNameOrNotFound d NameResponse {registration} = case registration of
NRRegistered {nameRecord} -> T.toLower (nrName nameRecord) == fullDomainName d
_ -> True
type QueueDrained = Bool
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-- This command is always sent in background request mode
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO QueueDrained
ackSMPMessage c rpKey rId msgId =
sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
OK -> pure True
cmd@MSG {} -> liftIO (writeSMPMessage c rId cmd) $> False
r -> throwE $ unexpectedResponse r
-- | Irreversibly suspend SMP queue.
@@ -1228,7 +1231,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
-- encode
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
-- serviceAuth is False here – proxied commands are not used with service certificates
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey nonce tForAuth
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey (Just nonce) tForAuth
b <- case batchTransmissions serverThParams [Right (auth, tToSend)] of
[] -> throwE $ PCETransportError TELargeMsg
TBError e _ : _ -> throwE $ PCETransportError e
@@ -1262,7 +1265,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
-- receives RRES :: Maybe C.CbNonce -> EncFwdResponse -> BrokerMsg
-- proxy should send PRES to the client with EncResponse
-- Always uses background timeout mode
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO (Maybe C.CbNonce, EncResponse)
forwardSMPTransmission :: SMPClient -> C.CorrCbNonce -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO (Maybe C.CbNonce, EncResponse)
forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
-- prepare params
sessSecret <- case thAuth thParams of
@@ -1400,7 +1403,7 @@ mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err
mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (entityId, pKey_, command) = do
nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command)
auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ nonce tForAuth
auth = authTransmission (thAuth thParams) (useServiceAuth command) pKey_ (Just nonce) tForAuth
r <- mkRequest (CorrId corrId)
pure ((,tToSend) <$> auth, r)
where
@@ -1419,14 +1422,14 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC
atomically $ TM.insert corrId r sentCommands
pure r
authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations)
authTransmission thAuth serviceAuth pKey_ nonce t = traverse authenticate pKey_
authTransmission :: Maybe (THandleAuth 'TClient) -> Bool -> Maybe C.APrivateAuthKey -> Maybe C.CbNonce -> ByteString -> Either TransportError (Maybe TAuthorizations)
authTransmission thAuth serviceAuth pKey_ nonce_ t = traverse authenticate pKey_
where
authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations
authenticate (C.APrivateAuthKey a pk) = (,serviceSig) <$> case a of
C.SX25519 -> case thAuth of
Just THAuthClient {peerServerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t'
Nothing -> Left TENoServerAuth
C.SX25519 -> case (thAuth, nonce_) of
(Just THAuthClient {peerServerPubKey = k}, Just nonce) -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t'
_ -> Left TENoServerAuth
C.SEd25519 -> sign pk
C.SEd448 -> sign pk
-- When command is signed by both entity key and service key,
src/Simplex/Messaging/Crypto.hs
+51 -17
View File
@@ -140,8 +140,10 @@ module Simplex.Messaging.Crypto
gcmIV,
-- * NaCl crypto_box
CbNonce (unCbNonce),
CbNonceI (..),
CbNonce,
pattern CbNonce,
CorrCbNonce,
cbEncrypt,
cbEncryptNoPad,
cbEncryptMaxLenBS,
@@ -152,8 +154,12 @@ module Simplex.Messaging.Crypto
sbEncryptNoPad,
sbDecryptNoPad,
cbNonce,
unsafeCbNonce,
corrCbNonce,
randomCbNonce,
reverseNonce,
xorNonce,
toCbNonce,
-- * NaCl crypto_secretbox
SbKey (unSbKey),
@@ -232,6 +238,7 @@ import Data.ASN1.Types
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first)
import Data.Bits (xor)
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as BA
import Data.ByteString.Base64 (decode)
@@ -254,7 +261,7 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (.
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Util (packZipWith, (<$?>))
-- | Cryptographic algorithms.
data Algorithm = Ed25519 | Ed448 | X25519 | X448
@@ -1324,8 +1331,8 @@ sbEncryptNoPad (SbKey key) (CbNonce nonce) = cryptoBox key nonce
{-# INLINE sbEncryptNoPad #-}
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
cbEncryptMaxLenBS :: (KnownNat i, CbNonceI n) => DhSecret X25519 -> n -> MaxLenBS i -> ByteString
cbEncryptMaxLenBS (DhSecretX25519 secret) nonce = cryptoBox secret (unCbNonce nonce) . unMaxLenBS . padMaxLenBS
{-# INLINE cbEncryptMaxLenBS #-}
cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
@@ -1335,8 +1342,8 @@ cryptoBox secret nonce s = BA.convert tag <> c
tag = Poly1305.auth rs c
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
cbDecrypt :: CbNonceI n => DhSecret X25519 -> n -> ByteString -> Either CryptoError ByteString
cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret . toCbNonce
{-# INLINE cbDecrypt #-}
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
@@ -1383,9 +1390,16 @@ cbAuthenticate k pk nonce msg = CbAuthenticator $ cbEncryptNoPad (dh' k pk) nonc
cbVerify :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> CbAuthenticator -> ByteString -> Bool
cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) nonce s == Right (sha512Hash authorized)
newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
class CbNonceI n where
unCbNonce :: n -> ByteString
newtype CbNonce = CryptoBoxNonce ByteString
deriving (Eq, Show)
deriving newtype (FromField)
instance CbNonceI CbNonce where
unCbNonce (CryptoBoxNonce s) = s
instance FromField CbNonce where fromField = blobFieldDecoder cbNonce
instance ToField CbNonce where toField (CryptoBoxNonce s) = toField $ Binary s
@@ -1396,7 +1410,7 @@ pattern CbNonce s <- CryptoBoxNonce s
instance StrEncoding CbNonce where
strEncode (CbNonce s) = strEncode s
strP = cbNonce <$> strP
strP = cbNonce <$?> strP
instance ToJSON CbNonce where
toJSON = strToJSON
@@ -1405,13 +1419,16 @@ instance ToJSON CbNonce where
instance FromJSON CbNonce where
parseJSON = strParseJSON "CbNonce"
cbNonce :: ByteString -> CbNonce
cbNonce :: ByteString -> Either String CbNonce
cbNonce s
| len == 24 = CryptoBoxNonce s
| len > 24 = CryptoBoxNonce . fst $ B.splitAt 24 s
| otherwise = CryptoBoxNonce $ s <> B.replicate (24 - len) (toEnum 0)
where
len = B.length s
| B.length s == 24 = Right $ CryptoBoxNonce s
| otherwise = Left "CbNonce: invalid length"
unsafeCbNonce :: ByteString -> CbNonce
unsafeCbNonce s = either error id $ cbNonce s
corrCbNonce :: ByteString -> Either String CorrCbNonce
corrCbNonce s = CorrCbNonce . unCbNonce <$> cbNonce s
randomCbNonce :: TVar ChaChaDRG -> STM CbNonce
randomCbNonce = fmap CryptoBoxNonce . randomBytes 24
@@ -1419,13 +1436,30 @@ randomCbNonce = fmap CryptoBoxNonce . randomBytes 24
randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n
reverseNonce :: CbNonce -> CbNonce
reverseNonce (CryptoBoxNonce s) = CryptoBoxNonce (B.reverse s)
reverseNonce :: CbNonceI n => n -> CbNonce
reverseNonce = CryptoBoxNonce . B.reverse . unCbNonce
xorNonce :: CbNonceI n => ByteString -> n -> CbNonce
xorNonce s nonce = CryptoBoxNonce $ packZipWith xor s n <> B.drop (B.length s) n
where
n = unCbNonce nonce
toCbNonce :: CbNonceI n => n -> CbNonce
toCbNonce = CryptoBoxNonce . unCbNonce
instance Encoding CbNonce where
smpEncode = unCbNonce
smpP = CryptoBoxNonce <$> A.take 24
newtype CorrCbNonce = CorrCbNonce ByteString
instance CbNonceI CorrCbNonce where
unCbNonce (CorrCbNonce s) = s
instance Encoding CorrCbNonce where
smpEncode = smpEncode . unCbNonce
smpP = corrCbNonce <$?> smpP
newtype SbKey = SecretBoxKey {unSbKey :: ByteString}
deriving (Eq, Show)
deriving newtype (FromField)
src/Simplex/Messaging/Crypto/Ratchet.hs
+4
View File
@@ -72,6 +72,7 @@ module Simplex.Messaging.Crypto.Ratchet
rcEncryptHeader,
rcEncryptMsg,
rcDecrypt,
maxSkippedMsgKeys,
-- used in tests
MsgHeader (..),
RatchetInitParams (..),
@@ -967,6 +968,9 @@ type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff
maxSkip :: Word32
maxSkip = 512
maxSkippedMsgKeys :: Int
maxSkippedMsgKeys = 2000
rcDecrypt ::
forall a.
(AlgorithmI a, DhAlgorithm a) =>
src/Simplex/Messaging/Crypto/ShortLink.hs
+5 -3
View File
@@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.ShortLink
encodeSignUserData,
newOwnerAuth,
encryptLinkData,
encryptFixedData,
encryptUserData,
decryptLinkData,
)
@@ -84,9 +85,10 @@ newOwnerAuth g ownerId signingKey = do
pure (ownerPrivKey, OwnerAuth {ownerId, ownerKey, authOwnerSig})
encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> ExceptT AgentErrorType IO QueueLinkData
encryptLinkData g k = bimapM (encrypt fixedDataPaddedLength) (encrypt userDataPaddedLength)
where
encrypt len = encryptData g k len
encryptLinkData g k = bimapM (encryptFixedData g k) (encryptUserData g k)
encryptFixedData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
encryptFixedData g k s = encryptData g k fixedDataPaddedLength s
encryptUserData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
encryptUserData g k s = encryptData g k userDataPaddedLength s
src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql
-5
View File
@@ -1,5 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -309,6 +307,3 @@ ALTER TABLE ONLY ntf_server.subscriptions
ALTER TABLE ONLY ntf_server.subscriptions
ADD CONSTRAINT subscriptions_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE;
src/Simplex/Messaging/Protocol.hs
+66 -38
View File
@@ -145,7 +145,10 @@ module Simplex.Messaging.Protocol
RcvNtfDhSecret,
Message (..),
RcvMessage (..),
MsgId,
MsgId (unMsgId),
mkMsgId,
unsafeMsgId,
randomMsgId,
MsgBody,
IdsHash (..),
ServiceSub (..),
@@ -233,8 +236,10 @@ module Simplex.Messaging.Protocol
where
import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (STM, TVar)
import Control.Exception (Exception, SomeException, displayException, fromException)
import Control.Monad.Except
import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as J
@@ -269,7 +274,7 @@ import qualified GHC.TypeLits as TE
import qualified GHC.TypeLits as Type
import Network.Socket (ServiceName)
import qualified Network.TLS as TLS
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -281,7 +286,7 @@ import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
import Simplex.Messaging.Util (bshow, eitherToMaybe, packZipWith, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
@@ -703,24 +708,24 @@ instance Encoding NewNtfCreds where
newtype EncTransmission = EncTransmission ByteString
deriving (Show)
encTransmissionNonce :: VersionSMP -> C.CbNonce -> C.CbNonce
encTransmissionNonce v nonce@(C.CbNonce s)
| v >= fwdNoncesSMPVersion = C.cbNonce $ packZipWith xor (smpEncode v) s <> BS.drop 2 s
| otherwise = nonce
encTransmissionNonce :: C.CbNonceI n => VersionSMP -> n -> C.CbNonce
encTransmissionNonce v nonce
| v >= fwdNoncesSMPVersion = C.xorNonce (smpEncode v) nonce
| otherwise = C.toCbNonce nonce
data FwdTransmission = FwdTransmission
{ fwdCorrId :: CorrId,
{ fwdCorrId :: C.CorrCbNonce,
fwdVersion :: VersionSMP,
fwdKey :: C.PublicKeyX25519,
fwdTransmission :: EncTransmission
}
instance Encoding FwdTransmission where
smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} =
smpEncode (corrId, fwdVersion, fwdKey, Tail t)
smpEncode FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} =
smpEncode (fwdCorrId, fwdVersion, fwdKey, Tail t)
smpP = do
(corrId, fwdVersion, fwdKey, Tail t) <- smpP
pure FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t}
(fwdCorrId, fwdVersion, fwdKey, Tail t) <- smpP
pure FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t}
newtype EncFwdTransmission = EncFwdTransmission ByteString
deriving (Show)
@@ -766,16 +771,16 @@ newtype EncFwdResponse = EncFwdResponse ByteString
deriving (Eq, Show)
data FwdResponse = FwdResponse
{ fwdCorrId :: CorrId,
{ fwdCorrId :: C.CorrCbNonce,
fwdResponse :: EncResponse
}
instance Encoding FwdResponse where
smpEncode FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} =
smpEncode (corrId, Tail t)
smpEncode FwdResponse {fwdCorrId, fwdResponse = EncResponse t} =
smpEncode (fwdCorrId, Tail t)
smpP = do
(corrId, Tail t) <- smpP
pure FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t}
(fwdCorrId, Tail t) <- smpP
pure FwdResponse {fwdCorrId, fwdResponse = EncResponse t}
newtype EncResponse = EncResponse ByteString
deriving (Eq, Show)
@@ -798,7 +803,7 @@ toMsgInfo = \case
Message {msgId, msgTs} -> msgInfo msgId msgTs MTMessage
MessageQuota {msgId, msgTs} -> msgInfo msgId msgTs MTQuota
where
msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode msgId, msgTs = systemToUTCTime msgTs, msgType}
msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode $ unMsgId msgId, msgTs = systemToUTCTime msgTs, msgType}
messageId :: Message -> MsgId
messageId = \case
@@ -1499,7 +1504,34 @@ type RcvNtfPublicDhKey = C.PublicKeyX25519
type RcvNtfDhSecret = C.DhSecretX25519
-- | SMP message server ID.
type MsgId = ByteString
newtype MsgId = MsgId {unMsgId :: ByteString}
deriving (Eq, Show)
instance C.CbNonceI MsgId where
unCbNonce (MsgId s) = B.take 24 s
instance Encoding MsgId where
smpEncode (MsgId s) = smpEncode s
smpP = mkMsgId <$?> smpP
instance StrEncoding MsgId where
strEncode (MsgId s) = strEncode s
strP = mkMsgId <$?> strP
instance FromField MsgId where fromField = blobFieldDecoder mkMsgId
instance ToField MsgId where toField (MsgId s) = toField $ Binary s
mkMsgId :: ByteString -> Either String MsgId
mkMsgId s
| B.length s >= 24 = Right $ MsgId s
| otherwise = Left "MsgId: invalid length"
unsafeMsgId :: ByteString -> MsgId
unsafeMsgId s = either error id $ mkMsgId s
randomMsgId :: Int -> TVar ChaChaDRG -> STM MsgId
randomMsgId n = fmap MsgId . C.randomBytes (max 24 n)
-- | SMP message body.
type MsgBody = ByteString
@@ -1824,8 +1856,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
encodeProtocol v = \case
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
| v >= newNtfCredsSMPVersion -> new <> e (subMode, queueReqData, ntfCreds)
| v >= shortLinksSMPVersion -> new <> e (subMode, queueReqData)
| otherwise -> new <> e (subMode, senderCanSecure (queueReqMode <$> queueReqData))
| otherwise -> new <> e (subMode, queueReqData)
where
new = e (NEW_, ' ', rKey, dhKey, auth_)
SUB -> e SUB_
@@ -1912,20 +1943,18 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
CT SCreator NEW_ -> Cmd SCreator <$> newCmd
where
newCmd
| v >= newNtfCredsSMPVersion = new smpP smpP
| v >= shortLinksSMPVersion = new smpP nothing
| otherwise = new (qReq <$> smpP) nothing
| v >= newNtfCredsSMPVersion = new smpP
| otherwise = new nothing
where
nothing = pure Nothing
new p2 p3 = NEW <$> do
new p3 = NEW <$> do
rcvAuthKey <- _smpP
rcvDhKey <- smpP
auth_ <- smpP
subMode <- smpP
queueReqData <- p2
queueReqData <- smpP
ntfCreds <- p3
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
CT SRecipient tag ->
Cmd SRecipient <$> case tag of
SUB_ -> pure SUB
@@ -1976,8 +2005,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
| v >= newNtfCredsSMPVersion -> ids <> e (queueMode, linkId, serviceId, serverNtfCreds)
| v >= serviceCertsSMPVersion -> ids <> e (queueMode, linkId, serviceId)
| v >= shortLinksSMPVersion -> ids <> e (queueMode, linkId)
| otherwise -> ids <> e (senderCanSecure queueMode)
| otherwise -> ids <> e (queueMode, linkId)
where
ids = e (IDS_, ' ', rcvId, sndId, srvDh)
LNK sId d -> e (LNK_, ' ', sId, d)
@@ -2028,19 +2056,17 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
bodyP = EncRcvMsgBody . unTail <$> smpP
ALLS_ -> pure ALLS
IDS_
| v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
| v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
| otherwise -> ids (qm <$> smpP) nothing nothing nothing
| v >= newNtfCredsSMPVersion -> ids smpP smpP
| v >= serviceCertsSMPVersion -> ids smpP nothing
| otherwise -> ids nothing nothing
where
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
nothing = pure Nothing
ids p1 p2 p3 p4 = do
ids p3 p4 = do
rcvId <- _smpP
sndId <- smpP
rcvPublicDhKey <- smpP
queueMode <- p1
linkId <- p2
queueMode <- smpP
linkId <- smpP
serviceId <- p3
serverNtfCreds <- p4
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
@@ -2423,7 +2449,9 @@ tDecodeServer THandleParams {sessionId, thVersion = v, implySessId} = \case
where
cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials tAuth entityId
t :: a -> (CorrId, EntityId, a)
t = (corrId,entityId,)
-- IDs are slices of the ~16 KB received block and are kept as subscription keys,
-- so without a copy one live key retains the whole block
t = (CorrId $ B.copy $ bs corrId,EntityId $ B.copy $ unEntityId entityId,)
Left _ -> tError corrId PEBlock
| otherwise -> tError corrId PESession
Left _ -> tError "" PEBlock
src/Simplex/Messaging/Server.hs
+130 -101
View File
@@ -33,9 +33,6 @@ module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
controlPortAuth,
importMessages,
exportMessages,
printMessageStats,
disconnectTransport,
verifyCmdAuthorization,
dummyVerifyCmd,
@@ -98,8 +95,8 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
import qualified Network.TLS as TLS
import Numeric.Natural (Natural)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClient (thParams), ProtocolClientConfig (..), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, netTimeoutInt, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentConfig (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -108,7 +105,6 @@ import Simplex.Messaging.Server.Control
import Simplex.Messaging.Server.Env.STM as Env
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
import Simplex.Messaging.Server.Names (NamesEnv, closeNamesEnv, resolveName)
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
@@ -116,6 +112,7 @@ import Simplex.Messaging.Server.NtfStore
import Simplex.Messaging.Server.Prometheus
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.QueueStore.STM (withLoadedQueues)
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog (foldLogLines)
@@ -145,7 +142,7 @@ import GHC.Conc.Sync (threadLabel)
#endif
#if defined(dbServerPostgres)
import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats)
import Simplex.Messaging.Server.MsgStore.Postgres (getDbMessageStats)
#endif
-- | Runs an SMP server using passed configuration.
@@ -1145,14 +1142,16 @@ cancelSub s = case subThread s of
type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s)
receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s ()
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms c@Client {rcvQ, rcvActiveAt} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
sa <- asks serverActive
stats <- asks serverStats
authDelay <- asks $ authErrorDelay . config
liftIO $ forever $ do
ts <- tGetServer h
unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
receivedAt <- getSystemTime
atomically $ writeTVar rcvActiveAt $! receivedAt
let (es, ts') = partitionEithers $ L.toList ts
errs = map (second ERR) es
errs' <- case ts' of
@@ -1168,7 +1167,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds
pure $ errs ++ errs'
[] -> pure errs
mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs'
mapM_ (sendResponses c stats authDelay receivedAt . (,[])) $ L.nonEmpty errs'
where
sameParty :: SParty p -> SignedTransmission Cmd -> Bool
sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p'
@@ -1191,6 +1190,43 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
GET -> incStat $ msgGetAuth stats
_ -> pure ()
isAuthError :: Transmission BrokerMsg -> Bool
isAuthError (_, _, r) = case r of
ERR AUTH -> True
_ -> False
sendResponses :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
sendResponses c@Client {sndQ} stats authDelay since rs@(ts, _)
| any isAuthError ts = sendAfterDelay c stats authDelay since rs
| otherwise = atomically $ writeTBQueue sndQ rs
sendAfterDelay :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
sendAfterDelay c@Client {sndQ, clientTHParams = THandleParams {sessionId}} stats delay since rs
| delay > 0 = do
elapsed <- subtract (microseconds since) . microseconds <$> getSystemTime
when (elapsed >= delay) $ incStat $ authDelayExceeded stats
forkClient c (B.unpack $ "client $" <> encode sessionId <> " auth") $ threadDelay' (delay - elapsed `mod` delay) >> write
| otherwise = write
where
write = atomically $ writeTBQueue sndQ rs
updateSlotWaitStats :: ServerStats -> SystemTime -> Bool -> IO ()
updateSlotWaitStats ServerStats {cmdSlotWaits, cmdSlotWaitMs, cmdSlotWaitMaxMs, cmdSlotWaitTimeouts} since taken = do
waitMs <- fromIntegral . (`div` 1000) . subtract (microseconds since) . microseconds <$> getSystemTime
incStat cmdSlotWaits
atomicModifyIORef'_ cmdSlotWaitMs (+ waitMs)
atomicModifyIORef'_ cmdSlotWaitMaxMs (max waitMs)
unless taken $ incStat cmdSlotWaitTimeouts
rslvTooManyRequests :: BrokerMsg
rslvTooManyRequests = ERR $ NAME $ RESOLVER "too many requests"
forwardedCmdWait :: ServerConfig s -> Int
forwardedCmdWait = (`netTimeoutInt` NRMBackground) . tcpTimeout . networkConfig . smpCfg . smpAgentCfg
microseconds :: SystemTime -> Int64
microseconds (MkSystemTime s ns) = s * 1000000 + fromIntegral (ns `div` 1000)
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
@@ -1319,11 +1355,6 @@ isContactQueue QueueRec {queueMode, senderKey} = case queueMode of
Just QMContact -> True
Nothing -> isNothing senderKey -- for backward compatibility with pre-SKEY contact addresses
isSecuredMsgQueue :: QueueRec -> Bool
isSecuredMsgQueue QueueRec {queueMode, senderKey} = case queueMode of
Just QMContact -> False
_ -> isJust senderKey
-- Random correlation ID is used as a nonce in case crypto_box authenticator is used to authorize transmission
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> C.APublicAuthKey -> Bool
verifyCmdAuthorization thAuth tAuth authorized corrId key = maybe False (verify key) tAuth
@@ -1339,7 +1370,7 @@ verifyCmdAuthorization thAuth tAuth authorized corrId key = maybe False (verify
verifyCmdAuth :: Maybe (THandleAuth 'TServer) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> CorrId -> Bool
verifyCmdAuth thAuth k authenticator authorized (CorrId corrId) = case thAuth of
Just THAuthServer {serverPrivKey = pk} -> C.cbVerify k pk (C.cbNonce corrId) authenticator authorized
Just THAuthServer {serverPrivKey = pk} -> either (const False) (\nonce -> C.cbVerify k pk nonce authenticator authorized) $ C.cbNonce corrId
Nothing -> False
dummyVerifyCmd :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
@@ -1379,15 +1410,18 @@ client
ms
clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
stats <- asks serverStats
authDelay <- asks $ authErrorDelay . config
let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
process batchSubs t acc@(rs, msgs) =
(maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_)))
<$> processCommand clntServiceId batchSubs t
forever $ do
batch <- atomically (readTBQueue rcvQ)
processedAt <- liftIO getSystemTime
batchSubs <- prepareBatchSubs clntServiceId batch
foldrM (process batchSubs) ([], []) batch
>>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_)
>>= \(rs_, msgs) -> mapM_ (liftIO . sendResponses clnt stats authDelay processedAt . (,msgs)) (L.nonEmpty rs_)
where
prepareBatchSubs ::
Maybe ServiceId ->
@@ -1458,32 +1492,57 @@ client
ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats
let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn
liftIO (lookupSMPServerClient a sessId) >>= \case
Just (own, smp) -> do
Just (own, smp) | Right fwdCorrId <- C.corrCbNonce (bs corrId) -> do
inc own pRequests
forkProxiedCmd $ do
liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `E.catches` clientHandlers) >>= \case
liftIO (runExceptT (forwardSMPTransmission smp fwdCorrId fwdV pubKey encBlock) `E.catches` clientHandlers) >>= \case
Right (nonce_, r) -> PRES nonce_ r <$ inc own pSuccesses
Left e -> ERR (smpProxyError e) <$ case e of
PCEProtocolError {} -> inc own pSuccesses
_ -> inc own pErrorsOther
Just _ -> pure $ Just $ ERR $ CMD SYNTAX
Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
where
forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg)
forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId)
-- Run a slow command on a thread
forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> M s BrokerMsg -> M s (Maybe a)
forkCmd concurrency corrId entId cmdAction = do
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " cmd") $
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, entId, t)], [])
forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId) (ERR $ smpProxyError PCEResponseTimeout)
-- Run a slow command on a thread, responding with timeoutErr if it was not started before the client timeout
forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> BrokerMsg -> M s BrokerMsg -> M s (Maybe a)
forkCmd concurrency corrId entId timeoutErr cmdAction =
-- commands MUST be processed under a reasonable timeout or the client would halt
forkCmd_ concurrency maxClientCmdWait (sendResp timeoutErr) $ cmdAction >>= sendResp
where
sendResp t = atomically $ writeTBQueue sndQ ([(corrId, entId, t)], [])
-- Run a slow command on a thread that sends its response
forkCmd_ :: (ServerConfig s -> Int) -> (ServerConfig s -> Int) -> M s () -> M s () -> M s (Maybe a)
forkCmd_ concurrency waitTimeout onTimeout cmd = do
let label = B.unpack $ "client $" <> encode sessionId <> " cmd"
-- Exceptions are masked so the slot is never lost between taking it and starting the thread.
-- The thread frees the slot when the command finishes; the caller frees it only if forking failed.
mask $ \restore ->
ifM
wait
(forkClient clnt label (restore cmd `finally` signal) `onException` signal)
(restore onTimeout)
pure Nothing
where
-- Takes a free slot at once if there is one. Otherwise waits for a slot until the client
-- timeout, after which the client no longer expects the response.
-- Other commands of this client are not processed while it waits.
wait = do
limit <- asks (concurrency . config)
atomically $ do
used <- readTVar procThreads
when (used >= limit) retry
writeTVar procThreads $! used + 1
ifM (atomically $ takeSlot limit) (pure True) $ do
clientTimeout <- asks $ waitTimeout . config
waitStarted <- liftIO getSystemTime
expired <- liftIO $ registerDelay clientTimeout
taken <- atomically $ ifM (takeSlot limit) (pure True) (ifM (readTVar expired) (pure False) retry)
stats <- asks serverStats
liftIO $ updateSlotWaitStats stats waitStarted taken
pure taken
takeSlot limit = do
used <- readTVar procThreads
let free = used < limit
when free $ writeTVar procThreads $! used + 1
pure free
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
rslvNamesEnv :: M s (Maybe NamesEnv)
rslvNamesEnv = do
@@ -1493,7 +1552,7 @@ client
Nothing -> incStat (rslvDisabled st) $> Nothing
Just nenv -> pure (Just nenv)
-- Runs on a forked thread so RSLV does not block other commands;
-- concurrency is limited by serverResolverConcurrency in forkCmd.
-- concurrency is limited in forkCmd by serverClientConcurrency for direct and serverResolverConcurrency for forwarded RSLV.
resolveNameMsg :: VersionSMP -> NamesEnv -> NameQuery -> M s BrokerMsg
resolveNameMsg v nenv q = do
st <- asks (rslvStats . serverStats)
@@ -1523,7 +1582,7 @@ client
Cmd SProxyService (RFWD encBlock) -> (response . (corrId, NoEntity,) =<<) <$> processForwardedCommand encBlock
Cmd SResolver (RSLV d) -> rslvNamesEnv >>= \case
Nothing -> pure $ response (corrId, NoEntity, ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg (thVersion thParams') nenv d)
Just nenv -> forkCmd serverClientConcurrency corrId NoEntity rslvTooManyRequests (resolveNameMsg (thVersion thParams') nenv d)
Cmd SSenderLink command -> case command of
LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
@@ -1955,7 +2014,7 @@ client
getDelivered :: Sub -> STM (Maybe (ServerSub, SystemSeconds))
getDelivered Sub {delivered, subThread} = do
readTVar delivered $>>= \(msgId', ts) ->
if msgId == msgId' || B.null msgId
if msgId == msgId'
then writeTVar delivered Nothing $> Just (subThread, ts)
else pure Nothing
updateStats :: ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
@@ -2001,7 +2060,7 @@ client
when (isJust (queueData qr) && isSecuredMsgQueue qr) $ void $ liftIO $
deleteQueueLinkData (queueStore ms) q
ServerConfig {messageExpiration, expireMessagesOnSend, msgIdBytes} <- asks config
msgId <- randomId' msgIdBytes
msgId <- atomically . randomMsgId msgIdBytes =<< asks random
msg_ <- liftIO $ runExceptT $ do
when expireMessagesOnSend $ mapM_ (expireMessages stats) messageExpiration
msg <- liftIO $ mkMessage msgId body
@@ -2114,7 +2173,7 @@ client
liftIO $ storeNtf ns nId ntf
incStat . ntfCount =<< asks serverStats
mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M s MsgNtf
mkMessageNotification :: MsgId -> SystemTime -> RcvNtfDhSecret -> M s MsgNtf
mkMessageNotification msgId msgTs rcvNtfDhSecret = do
ntfNonce <- atomically . C.randomCbNonce =<< asks random
let msgMeta = NMsgMeta {msgId, msgTs}
@@ -2123,14 +2182,15 @@ client
processForwardedCommand :: EncFwdTransmission -> M s (Maybe BrokerMsg)
processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do
startedAt <- liftIO getSystemTime
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
let proxyNonce = C.cbNonce $ bs corrId
proxyNonce <- liftEitherWith (const CRYPTO) $ C.cbNonce $ bs corrId
s' <- liftEitherWith (const CRYPTO) $ C.cbDecryptNoPad sessSecret proxyNonce s
FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission et} <- liftEitherWith (const $ CMD SYNTAX) $ smpDecode s'
unless (fwdVersion `isCompatible` thServerVRange thParams') $ throwE $ transportErr TEVersion
let clientSecret = C.dh' fwdKey serverPrivKey
clientNonce = C.cbNonce $ bs fwdCorrId
clientNonce = fwdCorrId
b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret (encTransmissionNonce fwdVersion clientNonce) et
let clntTHParams = smpTHParamsSetVersion fwdVersion thParams'
-- only allowing single forwarded transactions
@@ -2158,15 +2218,22 @@ client
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SResolver (RSLV d) -> lift $ rslvNamesEnv >>= \case
Nothing -> pure $ Just (corrId', entId', ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity $ do
msg <- resolveNameMsg (thVersion clntTHParams) nenv d
either ERR id <$> runExceptT (encodeResp (corrId', entId', msg))
Just nenv -> do
let sendResolved msg = do
rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg))
atomically $ writeTBQueue sndQ ([(corrId, NoEntity, rres)], [])
forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResolved rslvTooManyRequests) $
resolveNameMsg (thVersion clntTHParams) nenv d >>= sendResolved
-- INTERNAL because processCommand never returns Nothing for sender commands;
-- `fst` drops the empty message only returned for SUB.
_ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'')
stats <- asks serverStats
incStat $ pMsgFwdsRecv stats
traverse encodeResp r_
traverse encodeResp r_ >>= \case
Just rres | any isAuthError r_ -> do
authDelay <- asks $ authErrorDelay . config
Nothing <$ liftIO (sendAfterDelay clnt stats authDelay startedAt ([(corrId, NoEntity, rres)], []))
rres_ -> pure rres_
where
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s)
rejectOrVerify clntThAuth = \case
@@ -2192,7 +2259,7 @@ client
MessageQuota {} -> RcvMsgQuota msgTs'
where
encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
encrypt body = RcvMessage msgId' . EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body
encrypt body = RcvMessage msgId' . EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) msgId' body
msgId' = messageId msg
msgTs' = messageTs msg
@@ -2241,7 +2308,7 @@ client
SubPending -> QSubPending
SubThread _ -> QSubThread
ProhibitSub -> pure QProhibitSub
qDelivered <- decodeLatin1 . encode . fst <$$> readTVarIO delivered
qDelivered <- decodeLatin1 . encode . unMsgId . fst <$$> readTVarIO delivered
pure QSub {qSubThread, qDelivered}
ok :: Transmission BrokerMsg
@@ -2277,40 +2344,27 @@ randomId = fmap EntityId . randomId'
saveServerMessages :: Bool -> MsgStore s -> IO ()
saveServerMessages drainMsgs ms = case ms of
StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> exportMessages False ms f drainMsgs
StoreMemory ms'@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> exportMessages ms' f drainMsgs
Nothing -> logNote "undelivered messages are not saved"
StoreJournal _ -> logNote "closed journal message storage"
#if defined(dbServerPostgres)
StoreDatabase _ -> logNote "closed postgres message storage"
#endif
exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO ()
exportMessages tty st f drainMsgs = do
exportMessages :: STMMsgStore -> FilePath -> Bool -> IO ()
exportMessages ms f drainMsgs = do
logNote $ "saving messages to file " <> T.pack f
run $ case st of
StoreMemory ms -> exportMessages_ ms $ getMsgs ms
StoreJournal ms -> exportMessages_ ms $ getJournalMsgs ms
#if defined(dbServerPostgres)
StoreDatabase ms -> exportDbMessages tty ms
#endif
run $ fmap (\(Sum n) -> n) . withLoadedQueues (queueStore ms) . saveQueueMsgs
where
exportMessages_ ms get = fmap (\(Sum n) -> n) . unsafeWithAllMsgQueues tty ms . saveQueueMsgs get
run :: (Handle -> IO Int) -> IO ()
run a = liftIO $ withFile f WriteMode $ tryAny . a >=> \case
Right n -> logNote $ "messages saved: " <> tshow n
Left e -> do
logError $ "error exporting messages: " <> tshow e
exitFailure
getJournalMsgs ms q =
readTVarIO (msgQueue' q) >>= \case
Just _ -> getMsgs ms q
Nothing -> getJournalQueueMessages ms q
getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
getMsgs ms q = unsafeRunStore q "saveQueueMsgs" $ getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int)
saveQueueMsgs get h q = do
msgs <- get q
saveQueueMsgs :: Handle -> STMQueue -> IO (Sum Int)
saveQueueMsgs h q = do
msgs <- atomically $ getQueueMessages_ drainMsgs =<< getMsgQueue q
unless (null msgs) $ BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
pure $ Sum $ length msgs
encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n')
@@ -2322,37 +2376,16 @@ processServerMessages StartOptions {skipWarnings} = do
asks msgStore_ >>= liftIO . processMessages old_ expire
where
processMessages :: Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats)
#if defined(dbServerPostgres)
processMessages old_ expire = \case
#else
processMessages old_ _ = \case
#endif
StoreMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing)
Just f -> ifM (doesFileExist f) (Just <$> importMessages ms f old_ skipWarnings) (pure Nothing)
Nothing -> pure Nothing
StoreJournal ms -> processJournalMessages old_ expire ms
#if defined(dbServerPostgres)
StoreDatabase ms -> processDbMessages old_ expire ms
#endif
processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
processJournalMessages old_ expire ms
| expire = Just <$> case old_ of
Just old -> do
logNote "expiring journal store messages..."
run $ processExpireQueue old
Nothing -> do
logNote "validating journal store messages..."
run processValidateQueue
| otherwise = logWarn "skipping message expiration" $> Nothing
where
run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
mq <- getMsgQueue ms q False
expiredMsgsCount <- deleteExpireMsgs_ old q mq
storedMsgsCount <- getQueueSize_ mq
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
processValidateQueue :: JournalQueue s -> IO MessageStats
processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do
storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False
pure newMessageStats {storedMsgsCount, storedQueues = 1}
#if defined(dbServerPostgres)
processDbMessages old_ expire ms
| expire = Just <$> case old_ of
Just old -> do
@@ -2364,18 +2397,17 @@ processServerMessages StartOptions {skipWarnings} = do
| otherwise = logWarn "skipping message expiration" $> Nothing
#endif
importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
importMessages tty ms f old_ skipWarnings = do
importMessages :: STMMsgStore -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
importMessages ms f old_ skipWarnings = do
logNote $ "restoring messages from file " <> T.pack f
(_, (storedMsgsCount, expiredMsgsCount, overQuota)) <-
foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty))
foldLogLines False f restoreMsg (Nothing, (0, 0, M.empty))
renameFile f $ f <> ".bak"
mapM_ setOverQuota_ overQuota
logQueueStates ms
EntityCounts {queueCount} <- liftIO $ getEntityCounts @(StoreQueue s) $ queueStore ms
EntityCounts {queueCount} <- liftIO $ getEntityCounts @STMQueue $ queueStore ms
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount}
where
restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s)))
restoreMsg :: (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue)) -> Bool -> ByteString -> IO (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue))
restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of
Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure
Left e
@@ -2383,7 +2415,6 @@ importMessages tty ms f old_ skipWarnings = do
| otherwise -> exitErr $ parsingErr e
where
exitErr e = do
when tty $ putStrLn ""
logError $ "error restoring messages: " <> e
liftIO exitFailure
parsingErr :: String -> Text
@@ -2396,7 +2427,6 @@ importMessages tty ms f old_ skipWarnings = do
case qOrErr of
Right q -> addToQueue_ q rId msg
Left AUTH -> liftIO $ do
when tty $ putStrLn ""
warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist"
pure (Nothing, counts)
Left e -> throwE e
@@ -2407,7 +2437,6 @@ importMessages tty ms f old_ skipWarnings = do
writeMsg ms q False msg >>= \case
Just _ -> pure (stored + 1, expired, overQuota)
Nothing -> liftIO $ do
when tty $ putStrLn ""
logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg)
pure counts
| otherwise -> pure (stored, expired + 1, overQuota)
@@ -2418,8 +2447,8 @@ importMessages tty ms f old_ skipWarnings = do
where
-- if the first message in queue head is "quota", remove it.
mergeQuotaMsgs =
withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case
(mq, MessageQuota {}) -> tryDeleteMsg_ q mq False
withPeekMsgQueue q $ maybe (pure ()) $ \case
(mq, MessageQuota {}) -> tryDeleteMsg_ mq
_ -> pure ()
warnOrExit e
| skipWarnings = logWarn e'
src/Simplex/Messaging/Server/Env/STM.hs
+20 -75
View File
@@ -42,7 +42,6 @@ module Simplex.Messaging.Server.Env.STM
VerifiedTransmission,
ResponseAndMessage,
newEnv,
mkJournalStoreConfig,
msgStore,
fromMsgStore,
newClient,
@@ -68,10 +67,8 @@ module Simplex.Messaging.Server.Env.STM
defaultInactiveClientExpiration,
defaultProxyClientConcurrency,
defaultNameResolverConcurrency,
defaultMaxJournalMsgCount,
defaultMaxJournalStateLines,
defaultIdleQueueInterval,
journalMsgStoreDepth,
defaultMaxClientCmdWait,
defaultAuthErrorDelayMs,
readWriteQueueStore,
noPostgresExitStr,
noPostgresExit,
@@ -96,7 +93,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime, nominalDay)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.System (SystemTime)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
@@ -113,7 +110,6 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint)
@@ -146,8 +142,6 @@ data ServerConfig s = ServerConfig
smpHandshakeTimeout :: Int,
tbqSize :: Natural,
msgQueueQuota :: Int,
maxJournalMsgCount :: Int,
maxJournalStateLines :: Int,
queueIdBytes :: Int,
msgIdBytes :: Int,
serverStoreCfg :: ServerStoreCfg s,
@@ -164,8 +158,6 @@ data ServerConfig s = ServerConfig
messageExpiration :: Maybe ExpirationConfig,
expireMessagesOnStart :: Bool,
expireMessagesOnSend :: Bool,
-- | interval of inactivity after which journal queue is closed
idleQueueInterval :: Int64,
-- | notification expiration interval (seconds)
notificationExpiration :: ExpirationConfig,
-- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -187,6 +179,7 @@ data ServerConfig s = ServerConfig
ntfDeliveryInterval :: Int,
-- | interval between sending pending END events to unsubscribed clients, seconds
pendingENDInterval :: Int,
authErrorDelay :: Int64,
smpCredentials :: ServerCredentials,
httpCredentials :: Maybe ServerCredentials,
-- | SMP client-server protocol version range
@@ -199,11 +192,12 @@ data ServerConfig s = ServerConfig
smpAgentCfg :: SMPClientAgentConfig,
allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth`
serverClientConcurrency :: Int,
-- | max concurrent name resolutions per connection, enforced in forkCmd.
-- | max concurrent forwarded name resolutions per proxy connection, enforced in forkCmd.
-- Much higher than serverClientConcurrency: forwarded RSLVs from many clients
-- aggregate over a single proxy->relay connection (only servers send proxied
-- requests), so bounding them by the per-client limit would throttle unduly.
serverResolverConcurrency :: Int,
maxClientCmdWait :: Int,
-- | public-namespace resolver config; Nothing disables the names role
namesConfig :: Maybe NamesConfig,
-- | server public information
@@ -229,9 +223,6 @@ defaultMessageExpiration =
checkInterval = 7200 -- seconds, 2 hours
}
defaultIdleQueueInterval :: Int64
defaultIdleQueueInterval = 14400 -- seconds, 4 hours
defNtfExpirationHours :: Int64
defNtfExpirationHours = 24
@@ -250,26 +241,20 @@ defaultInactiveClientExpiration =
}
defaultProxyClientConcurrency :: Int
defaultProxyClientConcurrency = 32
defaultProxyClientConcurrency = 500
defaultNameResolverConcurrency :: Int
defaultNameResolverConcurrency = 1000
defaultNameResolverConcurrency = 5000
journalMsgStoreDepth :: Int
journalMsgStoreDepth = 5
defaultMaxClientCmdWait :: Int
defaultMaxClientCmdWait = 60000000 -- microseconds
defaultMaxJournalStateLines :: Int
defaultMaxJournalStateLines = 16
defaultMaxJournalMsgCount :: Int
defaultMaxJournalMsgCount = 256
defaultAuthErrorDelayMs :: Int64
defaultAuthErrorDelayMs = 50
defaultMsgQueueQuota :: Int
defaultMsgQueueQuota = 128
defaultStateTailSize :: Int
defaultStateTailSize = 512
data Env s = Env
{ config :: ServerConfig s,
serverActive :: TVar Bool,
@@ -295,7 +280,6 @@ msgStore = fromMsgStore . msgStore_
fromMsgStore :: MsgStore s -> s
fromMsgStore = \case
StoreMemory s -> s
StoreJournal s -> s
#if defined(dbServerPostgres)
StoreDatabase s -> s
#endif
@@ -303,12 +287,10 @@ fromMsgStore = \case
type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
SupportedStore 'QSMemory 'MSMemory = ()
SupportedStore 'QSMemory 'MSJournal = ()
SupportedStore 'QSMemory 'MSPostgres =
(Int ~ Bool, TypeError ('TE.Text "Storing messages in Postgres DB with queues in memory is not supported"))
SupportedStore 'QSPostgres 'MSMemory =
(Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with queues in Postgres DB is not supported"))
SupportedStore 'QSPostgres 'MSJournal = ()
#if defined(dbServerPostgres)
SupportedStore 'QSPostgres 'MSPostgres = ()
#else
@@ -322,8 +304,6 @@ data AStoreType =
data ServerStoreCfg s where
SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore
SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory)
SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres)
#if defined(dbServerPostgres)
SSCDatabase :: PostgresStoreCfg -> ServerStoreCfg PostgresMsgStore
#endif
@@ -331,8 +311,6 @@ data ServerStoreCfg s where
dbStoreCfg :: ServerStoreCfg s -> Maybe PostgresStoreCfg
dbStoreCfg = \case
SSCMemory _ -> Nothing
SSCMemoryJournal {} -> Nothing
SSCDatabaseJournal {storeCfg} -> Just storeCfg
#if defined(dbServerPostgres)
SSCDatabase cfg -> Just cfg
#endif
@@ -340,8 +318,6 @@ dbStoreCfg = \case
storeLogFile' :: ServerStoreCfg s -> Maybe FilePath
storeLogFile' = \case
SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
SSCMemoryJournal {storeLogFile} -> Just storeLogFile
SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbStoreLogPath}} -> dbStoreLogPath
#if defined(dbServerPostgres)
SSCDatabase (PostgresStoreCfg {dbStoreLogPath}) -> dbStoreLogPath
#endif
@@ -350,14 +326,12 @@ data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe F
type family MsgStoreType (qs :: QSType) (ms :: MSType) where
MsgStoreType 'QSMemory 'MSMemory = STMMsgStore
MsgStoreType qs 'MSJournal = JournalMsgStore qs
#if defined(dbServerPostgres)
MsgStoreType 'QSPostgres 'MSPostgres = PostgresMsgStore
#endif
data MsgStore s where
StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
#if defined(dbServerPostgres)
StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore
#endif
@@ -571,39 +545,24 @@ newProhibitedSub = do
return Sub {subThread = ProhibitSub, delivered}
newEnv :: ServerConfig s -> IO (Env s)
newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} = do
newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, msgQueueQuota, namesConfig, msgIdBytes} = do
when (msgIdBytes < 24) $ do
logError "Error: msgIdBytes must be at least 24"
exitFailure
serverActive <- newTVarIO True
server <- newServer
msgStore_ <- case serverStoreCfg of
SSCMemory storePaths_ -> do
let storePath = storeMsgsFile =<< storePaths_
ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota}
forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms
forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms
pure $ StoreMemory ms
SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
logWarn $
"Journal message store is deprecated and will be removed soon.\n"
<> "Please migrate to in-memory storage using `journal export` command.\n"
<> "After that you can migrate to PostgreSQL using `database import` command."
let qsCfg = MQStoreCfg
cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
ms <- newMsgStore cfg
loadStoreLog (mkQueue ms True) storeLogFile $ stmQueueStore ms
pure $ StoreJournal ms
#if defined(dbServerPostgres)
SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
let StartOptions {compactLog, confirmMigrations} = startOptions config
qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
StoreJournal <$> newMsgStore cfg
SSCDatabase storeCfg -> do
let StartOptions {compactLog, confirmMigrations} = startOptions config
cfg = PostgresMsgStoreCfg storeCfg {confirmMigrations} msgQueueQuota
when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
StoreDatabase <$> newMsgStore cfg
#else
SSCDatabaseJournal {} -> noPostgresExit
#endif
ntfStore <- NtfStore <$> TM.emptyIO
random <- C.newRandom
@@ -655,8 +614,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
Just f -> do
logNote $ "compacting queues in file " <> T.pack f
st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota}
-- we don't need to have locks in the map
sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st)
sl <- readWriteQueueStore False (mkQueue st) f (queueStore st)
setStoreLog (queueStore st) sl
closeMsgStore st
Nothing -> do
@@ -703,7 +661,9 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
Nothing -> SPMMemoryOnly
Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
_ -> SPMQueues
#if defined(dbServerPostgres)
_ -> SPMMessages
#endif
noPostgresExit :: IO a
noPostgresExit = putStrLn noPostgresExitStr >> exitFailure
@@ -713,21 +673,6 @@ noPostgresExitStr =
"Error: server binary is compiled without support for PostgreSQL database.\n"
<> "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
JournalStoreConfig
{ storePath,
quota = msgQueueQuota,
pathParts = journalMsgStoreDepth,
queueStoreCfg,
maxMsgCount = maxJournalMsgCount,
maxStateLines = maxJournalStateLines,
stateTailSize = defaultStateTailSize,
idleInterval = idleQueueInterval,
expireBackupsAfter = 14 * nominalDay,
keepMinBackups = 2
}
newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
newSMPProxyAgent smpAgentCfg random = do
smpAgent <- newSMPClientAgent SSender smpAgentCfg Nothing random
src/Simplex/Messaging/Server/Main.hs
+51 -144
View File
@@ -28,8 +28,6 @@ module Simplex.Messaging.Server.Main
importMessagesToDatabase,
exportDatabaseToStoreLog,
#endif
newJournalMsgStore,
storeMsgsJournalDir',
getServerSourceCode,
simplexmqSource,
serverPublicInfo,
@@ -61,7 +59,6 @@ import qualified Data.Text.IO as T
import Options.Applicative
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), ConnectionMode (..), connReqUriP')
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
@@ -69,23 +66,20 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main.Init
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.MsgStore.Types (SQSType (..), SMSType (..))
import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (combine)
@@ -98,15 +92,16 @@ import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Semigroup (Sum (..))
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Server.MsgStore.Postgres
import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
import Simplex.Messaging.Server.MsgStore.STM (STMStoreConfig (..))
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore)
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.QueueStore.Postgres (PostgresQueueStore, batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
import Simplex.Messaging.Util (unlessM)
import Simplex.Messaging.Util (ifM)
import System.Directory (renameFile)
import System.IO (IOMode (..), withFile)
#endif
@@ -136,79 +131,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
deleteDirIfExists cfgPath
deleteDirIfExists logPath
putStrLn "Deleted configuration and log files"
Journal cmd -> withIniFile $ \ini -> do
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
msgsFileExists <- doesFileExist storeMsgsFilePath
storeLogFile <- getRequiredStoreLogFile ini
case cmd of
SCImport
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsDirExists -> do
putStrLn $ storeMsgsJournalDir <> " directory already exists."
exitFailure
| not msgsFileExists -> do
putStrLn $ storeMsgsFilePath <> " file does not exist."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
"Messages not imported"
ms <- newJournalMsgStore logPath MQStoreCfg
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
putStrLn "Import completed"
printMessageStats "Messages" msgStats
putStrLn $ case readStoreType ini of
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
Right (ASType SQSPostgres SMSPostgres) -> "store_messages set to `database`, update it to `journal` in INI file"
Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
Left e -> e <> ", configure storage correctly"
SCExport
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsFileExists -> do
putStrLn $ storeMsgsFilePath <> " file already exists."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
"Journal not exported"
case readStoreType ini of
Right (ASType SQSMemory msType) -> do
ms <- newJournalMsgStore logPath MQStoreCfg
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
exportMessages True (StoreJournal ms) storeMsgsFilePath False
putStrLn "Export completed"
putStrLn $ case msType of
SMSMemory -> "store_messages set to `memory`, start the server."
SMSJournal -> "store_messages set to `journal`, update it to `memory` in INI file"
#if defined(dbServerPostgres)
Right (ASType SQSPostgres SMSJournal) -> do
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
unlessM (checkSchemaExists connstr schema) $ do
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
exitFailure
ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
exportMessages True (StoreJournal ms) storeMsgsFilePath False
putStrLn "Export completed"
putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
Right (ASType SQSPostgres SMSPostgres) -> do
putStrLn $ "Messages can be exported with `dabatase export --table messages`."
exitFailure
#else
Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
#endif
Left e -> putStrLn $ e <> ", configure storage correctly"
SCDelete
| not msgsDirExists -> do
putStrLn $ storeMsgsJournalDir <> " directory does not exists."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
"Messages NOT deleted"
deleteDirIfExists storeMsgsJournalDir
putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
#if defined(dbServerPostgres)
Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
schemaExists <- checkSchemaExists connstr schema
@@ -221,7 +143,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
"Store logs not imported"
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
(sCnt, qCnt) <- importStoreLogToDatabase storeLogFile dbOpts
putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn "Importing messages..."
mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
@@ -248,11 +170,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
"Queue records not imported"
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
(sCnt, qCnt) <- importStoreLogToDatabase storeLogFile dbOpts
putStrLn $ "Import completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn $ case readStoreType ini of
Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
Right (ASType SQSMemory SMSJournal) -> setToDbStr
Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, update it to `database` and import messages (`smp-server database import --table messages`)"
Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
Left e -> e <> ", configure storage correctly"
where
@@ -280,7 +201,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
"Database store not exported"
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
(sCnt, qCnt) <- exportDatabaseToStoreLog dbOpts storeLogFilePath
putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn "Exporting messages..."
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
@@ -306,7 +227,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
"Queue records not exported"
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
(sCnt, qCnt) <- exportDatabaseToStoreLog dbOpts storeLogFilePath
putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn $ case readStoreType ini of
Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
@@ -346,6 +267,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError a
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
#if defined(dbServerPostgres)
getRequiredStoreLogFile ini = do
case enableStoreLog' ini $> storeLogFilePath of
Just storeLogFile -> do
@@ -354,6 +276,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
(pure storeLogFile)
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
#endif
iniFile = combine cfgPath "smp-server.ini"
serverVersion = "SMP server v" <> simplexmqVersionCommit
executableName = "smp-server"
@@ -364,10 +287,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
readStoreType :: Ini -> Either String AStoreType
readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
("memory", "journal") -> Left journalRemovedStr
("memory", "database") -> Left "Database and memory storage are not compatible."
("database", "memory") -> Left "Database and memory storage are not compatible."
("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
("database", "journal") -> Left journalRemovedStr
#if defined(dbServerPostgres)
("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
#else
@@ -377,10 +300,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
where
iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
#if defined(dbServerPostgres)
iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
#endif
defaultStaticPath = combine logPath "www"
enableStoreLog' = settingIsOn "STORE_LOG" "enable"
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
initializeServer opts
| scripted opts = initialize opts
| otherwise = do
@@ -517,16 +442,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
iniStoreType = either error id $! readStoreType ini
iniStoreCfg :: SupportedStore qs ms => SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
iniStoreCfg SQSMemory SMSMemory = SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
iniStoreCfg SQSMemory SMSJournal = SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
iniStoreCfg SQSPostgres SMSJournal =
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
in SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}
#if defined(dbServerPostgres)
iniStoreCfg SQSPostgres SMSPostgres =
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
in SSCDatabase storeCfg
#else
iniStoreCfg SQSPostgres _ = error noPostgresExitStr
#endif
serverConfig :: ServerStoreCfg s -> ServerConfig s
serverConfig serverStoreCfg =
@@ -535,8 +457,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
smpHandshakeTimeout = 120000000,
tbqSize = 128,
msgQueueQuota = defaultMsgQueueQuota,
maxJournalMsgCount = defaultMaxJournalMsgCount,
maxJournalStateLines = defaultMaxJournalStateLines,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
smpCredentials =
@@ -561,7 +481,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
},
expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
expireMessagesOnSend = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_send" ini,
idleQueueInterval = defaultIdleQueueInterval,
notificationExpiration =
defaultNtfExpiration
{ ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
@@ -580,6 +499,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
pendingENDInterval = 15000000, -- 15 seconds
ntfDeliveryInterval = 1500000, -- 1.5 second
authErrorDelay = 1000 * readIniDefault defaultAuthErrorDelayMs "TRANSPORT" "auth_error_delay_ms" ini,
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig =
mkTransportServerConfig
@@ -610,6 +530,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
allowSMPProxy = True,
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
serverResolverConcurrency = readIniDefault defaultNameResolverConcurrency "NAMES" "resolver_concurrency" ini,
maxClientCmdWait = defaultMaxClientCmdWait,
namesConfig = readNamesConfig ini,
information = serverPublicInfo ini,
startOptions
@@ -637,7 +558,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
checkMsgStoreMode ini mode = do
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
msgsFileExists <- doesFileExist storeMsgsFilePath
storeLogExists <- doesFileExist storeLogFilePath
case mode of
#if defined(dbServerPostgres)
ASType SQSPostgres SMSPostgres
@@ -645,35 +565,22 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
putStrLn "Configure memory storage."
exitFailure
| otherwise -> checkDbStorage ini storeLogExists
#endif
ASType qs SMSJournal
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsFileExists -> do
putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
exitFailure
| not msgsDirExists ->
putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
| otherwise -> case qs of
SQSMemory ->
unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
#if defined(dbServerPostgres)
SQSPostgres -> checkDbStorage ini storeLogExists
| otherwise -> checkDbStorage ini =<< doesFileExist storeLogFilePath
#else
SQSPostgres -> noPostgresExit
ASType SQSPostgres _ -> noPostgresExit
#endif
ASType SQSMemory SMSMemory
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsDirExists -> do
putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
putStrLn journalRemovedStr
exitFailure
| otherwise -> pure ()
exitConfigureMsgStorage :: IO ()
exitConfigureMsgStorage = do
putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
putStrLn "Configure memory storage."
putStrLn journalRemovedStr
exitFailure
#if defined(dbServerPostgres)
@@ -705,18 +612,19 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
putStrLn "Configure queue storage."
exitFailure
importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
importStoreLogToDatabase logPath storeLogFile dbOpts = do
ms <- newJournalMsgStore logPath MQStoreCfg
let st = stmQueueStore ms
sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
importStoreLogToDatabase :: FilePath -> DBOpts -> IO (Int64, Int64)
importStoreLogToDatabase storeLogFile dbOpts = do
ms <- newMsgStore STMStoreConfig {storePath = Nothing, quota = defaultMsgQueueQuota}
let st = queueStore ms
sl <- readWriteQueueStore True (mkQueue ms) storeLogFile st
closeStoreLog sl
queues <- readTVarIO $ loadedQueues st
qs <- readTVarIO $ queues st
services' <- M.elems <$> readTVarIO (services st)
let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
sCnt <- batchInsertServices services' $ postgresQueueStore ps
qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg
sCnt <- batchInsertServices services' ps
qCnt <- batchInsertQueues True qs ps
closeQueueStore @PostgresQueue ps
renameFile storeLogFile $ storeLogFile <> ".bak"
pure (sCnt, qCnt)
@@ -735,21 +643,23 @@ importMessagesToDatabase msgsLogFile dbOpts = do
renameFile msgsLogFile $ msgsLogFile <> ".bak"
pure mCnt'
exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
exportDatabaseToStoreLog :: DBOpts -> FilePath -> IO (Int, Int)
exportDatabaseToStoreLog dbOpts storeLogFilePath = do
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg
sl <- openWriteStoreLog False storeLogFilePath
Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
Sum sCnt <- foldServiceRecs ps $ \sr -> logNewService sl sr $> Sum (1 :: Int)
Sum qCnt <- foldQueueRecs True True ps $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
closeStoreLog sl
closeQueueStore @PostgresQueue ps
pure (sCnt, qCnt)
#endif
newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore logPath qsCfg =
let cfg = mkJournalStoreConfig qsCfg (storeMsgsJournalDir' logPath) defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
in newMsgStore cfg
journalRemovedStr :: String
journalRemovedStr =
"Journal message storage is removed.\n"
<> "Export messages with `smp-server journal export` using smp-server v7.1.0.11 or earlier,\n"
<> "then set store_messages to `memory`, or to `database` and run `smp-server database import --table messages`."
storeMsgsJournalDir' :: FilePath -> FilePath
storeMsgsJournalDir' logPath = combine logPath "messages"
@@ -873,7 +783,6 @@ data CliCommand
| OnlineCert CertOptions
| Start StartOptions
| Delete
| Journal StoreCmd
| Database StoreCmd DatabaseTable DBOpts
data StoreCmd = SCImport | SCExport | SCDelete
@@ -899,7 +808,6 @@ cliCommandP cfgPath logPath iniFile =
<> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
<> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
<> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
<> command "database" (info (Database <$> databaseCmdP <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
)
where
@@ -1046,7 +954,6 @@ cliCommandP cfgPath logPath iniFile =
disableWeb,
scripted
}
journalCmdP = storeCmdP "message log file" "journal storage"
databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
storeCmdP src dest =
hsubparser
src/Simplex/Messaging/Server/Main/Init.hs
+7 -5
View File
@@ -83,7 +83,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
<> ("enable = " <> onOff enableStoreLog <> "\n\n")
<> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\
\# `memory` - in-memory persistence, with optional append-only log (`enable = on`).\n\
\# `database`- PostgreSQL databass (requires `store_messages = journal`).\n\
\# `database`- PostgreSQL databass (requires `store_messages = database`).\n\
\store_queues = memory\n\n\
\# Database connection settings for PostgreSQL database (`store_queues = database`).\n"
<> iniDbOpts dbOptions defaultDBOpts
@@ -91,7 +91,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# db_store_log = off\n\n\
\# Time to retain deleted queues in the database, days.\n"
<> ("# db_deleted_ttl = " <> tshow defaultDeletedTTL <> "\n\n")
<> "# Message storage mode: `memory` or `journal`.\n\
<> "# Message storage mode: `memory` or `database` (requires `store_queues = database`).\n\
\store_messages = memory\n\n\
\# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
\# when the server restarts, they are preserved in the .bak file until the next restart.\n"
@@ -130,7 +130,9 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
<> ("host = " <> T.pack host <> "\n")
<> ("port = " <> defaultServerPorts <> "\n")
<> "log_tls_errors = off\n\n\
\# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
\# Minimum time to respond with AUTH error, milliseconds.\n"
<> ("# auth_error_delay_ms = " <> tshow defaultAuthErrorDelayMs <> "\n\n")
<> "# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
\# This option is deprecated and should be used for testing only.\n\
\# , port 443 should be specified in port above\n\
\websockets = off\n"
@@ -152,7 +154,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
\# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
\# socks_mode = onion\n\n\
\# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
\# Limit number of threads a client can spawn to process proxy commands and name resolutions in parallel.\n"
<> ("# client_concurrency = " <> tshow defaultProxyClientConcurrency)
<> "\n\n\
\[NAMES]\n\
@@ -167,7 +169,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# resolver_auth: basic <username>:<password>\n\
\# resolver_timeout_ms: 3000\n\
\# resolver_max_response_bytes: 16000\n\
\# Max concurrent name resolutions per connection (forwarded RSLVs from many\n\
\# Max concurrent forwarded name resolutions per proxy connection (forwarded RSLVs from many\n\
\# clients share one proxy connection, so this is much higher than PROXY client_concurrency).\n"
<> ("# resolver_concurrency = " <> tshow defaultNameResolverConcurrency)
<> "\n\n\
src/Simplex/Messaging/Server/MsgStore/Journal.hs
-1085
View File
File diff suppressed because it is too large. Load diff
src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs
-44
View File
@@ -1,44 +0,0 @@
module Simplex.Messaging.Server.MsgStore.Journal.SharedLock
( withLockWaitShared,
withLockMapWaitShared,
withSharedWaitLock,
)
where
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Data.Text (Text)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Client (getMapLock)
import Simplex.Messaging.Protocol (RecipientId)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (($>>), ($>>=))
-- wait until shared lock with passed ID is released and take lock
withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> Text -> IO a -> IO a
withLockWaitShared rId lock shared name =
E.bracket_
(atomically $ waitShared rId shared >> putTMVar lock name)
(void $ atomically $ takeTMVar lock)
-- wait until shared lock with passed ID is released and take lock from Map for this ID
withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> Text -> IO a -> IO a
withLockMapWaitShared rId locks shared name a =
E.bracket
(atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name)
(atomically . takeTMVar)
(const a)
waitShared :: RecipientId -> TMVar RecipientId -> STM ()
waitShared rId shared = tryReadTMVar shared >>= mapM_ (\rId' -> when (rId == rId') retry)
-- wait until lock with passed ID in Map is released and take shared lock for this ID
withSharedWaitLock :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> IO a -> IO a
withSharedWaitLock rId locks shared =
E.bracket_
(atomically $ waitLock >> putTMVar shared rId)
(atomically $ takeTMVar shared)
where
waitLock = TM.lookup rId locks $>>= tryReadTMVar $>> retry
src/Simplex/Messaging/Server/MsgStore/Postgres.hs
+24 -77
View File
@@ -29,7 +29,6 @@ where
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Except
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
@@ -39,7 +38,6 @@ import Data.IORef
import Data.Int (Int64)
import Data.List (intersperse)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Time.Clock.System (SystemTime (..))
import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), (:.) (..))
import qualified Database.PostgreSQL.Simple as DB
@@ -56,7 +54,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (foldLogLines)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow', (<$$>))
import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
import System.IO (Handle, hFlush, stdout)
data PostgresMsgStore = PostgresMsgStore
@@ -81,32 +79,20 @@ instance StoreQueueClass PostgresQueue where
{-# INLINE recipientId #-}
queueRec = queueRec'
{-# INLINE queueRec #-}
withQueueLock PostgresQueue {} _ = id -- TODO [messages] maybe it's just transaction?
{-# INLINE withQueueLock #-}
newtype DBTransaction = DBTransaction {dbConn :: DB.Connection}
type DBStoreIO a = ReaderT DBTransaction IO a
instance MsgStoreClass PostgresMsgStore where
type StoreMonad PostgresMsgStore = ReaderT DBTransaction IO
type MsgQueue PostgresMsgStore = ()
type QueueStore PostgresMsgStore = PostgresQueueStore'
type StoreQueue PostgresMsgStore = PostgresQueue
type MsgStoreConfig PostgresMsgStore = PostgresMsgStoreCfg
newMsgStore :: PostgresMsgStoreCfg -> IO PostgresMsgStore
newMsgStore config = do
queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config, False)
queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config)
pure PostgresMsgStore {config, queueStore_}
closeMsgStore :: PostgresMsgStore -> IO ()
closeMsgStore = closeQueueStore @PostgresQueue . queueStore_
withActiveMsgQueues _ _ = error "withActiveMsgQueues not used"
unsafeWithAllMsgQueues _ _ _ = error "unsafeWithAllMsgQueues not used"
expireOldMessages :: Bool -> PostgresMsgStore -> Int64 -> Int64 -> IO MessageStats
expireOldMessages _tty ms now ttl =
maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db ->
@@ -150,35 +136,16 @@ instance MsgStoreClass PostgresMsgStore where
msg_ = toMaybeMessage mRow
in f a rId $ Right ((qr,) <$> msg_)
logQueueStates _ = error "logQueueStates not used"
logQueueState _ = error "logQueueState not used"
queueStore = queueStore_
{-# INLINE queueStore #-}
loadedQueueCounts :: PostgresMsgStore -> IO LoadedQueueCounts
loadedQueueCounts ms = do
loadedQueueCount <- M.size <$> readTVarIO queues
loadedNotifierCount <- M.size <$> readTVarIO notifiers
notifierLockCount <- M.size <$> readTVarIO notifierLocks
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount}
where
PostgresQueueStore {queues, notifiers, notifierLocks} = queueStore_ ms
loadedQueueCounts _ = pure LoadedQueueCounts {loadedQueueCount = 0, loadedNotifierCount = 0}
mkQueue :: PostgresMsgStore -> Bool -> RecipientId -> QueueRec -> IO PostgresQueue
mkQueue _ _keepLock rId qr = PostgresQueue rId <$> newTVarIO (Just qr)
mkQueue :: PostgresMsgStore -> RecipientId -> QueueRec -> IO PostgresQueue
mkQueue _ rId qr = PostgresQueue rId <$> newTVarIO (Just qr)
{-# INLINE mkQueue #-}
getMsgQueue _ _ _ = pure ()
{-# INLINE getMsgQueue #-}
getPeekMsgQueue :: PostgresMsgStore -> PostgresQueue -> DBStoreIO (Maybe ((), Message))
getPeekMsgQueue _ q = ((),) <$$> tryPeekMsg_ q ()
withIdleMsgQueue :: Int64 -> PostgresMsgStore -> PostgresQueue -> (() -> DBStoreIO a) -> DBStoreIO (Maybe a, Int)
withIdleMsgQueue _ _ _ _ = error "withIdleMsgQueue not used"
deleteQueue :: PostgresMsgStore -> PostgresQueue -> IO (Either ErrorType QueueRec)
deleteQueue ms q = deleteStoreQueue (queueStore_ ms) q
{-# INLINE deleteQueue #-}
@@ -189,8 +156,6 @@ instance MsgStoreClass PostgresMsgStore where
qr <- ExceptT $ deleteStoreQueue (queueStore_ ms) q
pure (qr, size)
getQueueMessages_ _ _ _ = error "getQueueMessages_ not used"
writeMsg :: PostgresMsgStore -> PostgresQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg ms q _ msg =
uninterruptibleMask_ $
@@ -202,50 +167,32 @@ instance MsgStoreClass PostgresMsgStore where
DB.query
db
"SELECT quota_written, was_empty FROM write_message(?,?,?,?,?,?,?)"
(recipientId' q, Binary (messageId msg), systemSeconds (messageTs msg), msgQuota, ntf, Binary body, quota)
(recipientId' q, messageId msg, systemSeconds (messageTs msg), msgQuota, ntf, Binary body, quota)
where
toResult = \case
((msgQuota, wasEmpty) : _) -> if msgQuota then Nothing else Just (msg, wasEmpty)
[] -> Nothing
PostgresMsgStore {config = PostgresMsgStoreCfg {quota}} = ms
setOverQuota_ :: PostgresQueue -> IO () -- can ONLY be used while restoring messages, not while server running
setOverQuota_ _ = error "TODO setOverQuota_" -- TODO [messages]
getQueueSize_ :: () -> DBStoreIO Int
getQueueSize_ _ = error "getQueueSize_ not used"
getQueueSize :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO Int
getQueueSize ms q =
withDB' "getQueueSize" (queueStore_ ms) $ \db ->
maybeFirstRow' 0 fromOnly $
DB.query db "SELECT msg_queue_size FROM msg_queues WHERE recipient_id = ? AND deleted_at IS NULL" (Only (recipientId' q))
tryPeekMsg_ :: PostgresQueue -> () -> DBStoreIO (Maybe Message)
tryPeekMsg_ q _ = do
db <- asks dbConn
liftIO $ maybeFirstRow toMessage $
DB.query
db
[sql|
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
FROM messages
WHERE recipient_id = ?
ORDER BY message_id ASC LIMIT 1
|]
(Only (recipientId' q))
tryDeleteMsg_ :: PostgresQueue -> () -> Bool -> DBStoreIO ()
tryDeleteMsg_ _q _ _ = error "tryDeleteMsg_ not used" -- do
isolateQueue :: PostgresMsgStore -> PostgresQueue -> Text -> DBStoreIO a -> ExceptT ErrorType IO a
isolateQueue ms _q op a = uninterruptibleMask_ $ withDB' op (queueStore_ ms) $ runReaderT a . DBTransaction
unsafeRunStore _ _ _ = error "unsafeRunStore not used"
tryPeekMsg :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg ms q = isolateQueue ms q "tryPeekMsg" $ tryPeekMsg_ q ()
{-# INLINE tryPeekMsg #-}
tryPeekMsg ms q =
uninterruptibleMask_ $ withDB' "tryPeekMsg" (queueStore_ ms) $ \db ->
maybeFirstRow toMessage $
DB.query
db
[sql|
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
FROM messages
WHERE recipient_id = ?
ORDER BY message_id ASC LIMIT 1
|]
(Only (recipientId' q))
tryPeekMsgs :: PostgresMsgStore -> [PostgresQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message)
tryPeekMsgs _ms [] = pure M.empty
@@ -271,14 +218,14 @@ instance MsgStoreClass PostgresMsgStore where
uninterruptibleMask_ $
withDB' "tryDelMsg" (queueStore_ ms) $ \db ->
maybeFirstRow toMessage $
DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_msg(?, ?)" (recipientId' q, Binary msgId)
DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_msg(?, ?)" (recipientId' q, msgId)
tryDelPeekMsg :: PostgresMsgStore -> PostgresQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg ms q msgId =
uninterruptibleMask_ $
withDB' "tryDelPeekMsg" (queueStore_ ms) $ \db ->
toResult . map toMessage
<$> DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_peek_msg(?, ?)" (recipientId' q, Binary msgId)
<$> DB.query db "SELECT r_msg_id, r_msg_ts, r_msg_quota, r_msg_ntf_flag, r_msg_body FROM try_del_peek_msg(?, ?)" (recipientId' q, msgId)
where
toResult = \case
[] -> (Nothing, Nothing)
@@ -297,13 +244,13 @@ uninterruptibleMask_ :: ExceptT ErrorType IO a -> ExceptT ErrorType IO a
uninterruptibleMask_ = ExceptT . E.uninterruptibleMask_ . runExceptT
{-# INLINE uninterruptibleMask_ #-}
toMaybeMessage :: (Maybe (Binary MsgId), Maybe Int64, Maybe Bool, Maybe Bool, Maybe (Binary MsgBody)) -> Maybe Message
toMaybeMessage :: (Maybe MsgId, Maybe Int64, Maybe Bool, Maybe Bool, Maybe (Binary MsgBody)) -> Maybe Message
toMaybeMessage = \case
(Just msgId, Just ts, Just msgQuota, Just ntf, Just body) -> Just $ toMessage (msgId, ts, msgQuota, ntf, body)
_ -> Nothing
toMessage :: (Binary MsgId, Int64, Bool, Bool, Binary MsgBody) -> Message
toMessage (Binary msgId, ts, msgQuota, ntf, Binary body)
toMessage :: (MsgId, Int64, Bool, Bool, Binary MsgBody) -> Message
toMessage (msgId, ts, msgQuota, ntf, Binary body)
| msgQuota = MessageQuota {msgId, msgTs}
| otherwise = Message {msgId, msgTs, msgFlags = MsgFlags ntf, msgBody = C.unsafeMaxLenBS body} -- TODO [messages] unsafeMaxLenBS?
where
@@ -429,7 +376,7 @@ messageRecToText rId msg =
tabFields = BB.char7 ',' `intersperse` fields
fields =
[ renderField (toField rId),
renderField (toField $ Binary (messageId msg)),
renderField (toField $ messageId msg),
renderField (toField $ systemSeconds (messageTs msg)),
renderField (toField msgQuota),
renderField (toField ntf),
src/Simplex/Messaging/Server/MsgStore/STM.hs
+96 -66
View File
@@ -15,6 +15,11 @@ module Simplex.Messaging.Server.MsgStore.STM
( STMMsgStore (..),
STMStoreConfig (..),
STMQueue,
getMsgQueue,
withPeekMsgQueue,
getQueueMessages_,
setOverQuota_,
tryDeleteMsg_,
)
where
@@ -24,7 +29,8 @@ import Control.Monad.Trans.Except
import Data.Functor (($>))
import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Maybe (catMaybes)
import Data.Time.Clock.System (SystemTime (systemSeconds))
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
@@ -61,12 +67,8 @@ instance StoreQueueClass STMQueue where
{-# INLINE recipientId #-}
queueRec = queueRec'
{-# INLINE queueRec #-}
withQueueLock _ _ = id
{-# INLINE withQueueLock #-}
instance MsgStoreClass STMMsgStore where
type StoreMonad STMMsgStore = STM
type MsgQueue STMMsgStore = STMMsgQueue
type QueueStore STMMsgStore = STMQueueStore STMQueue
type StoreQueue STMMsgStore = STMQueue
type MsgStoreConfig STMMsgStore = STMStoreConfig
@@ -78,24 +80,16 @@ instance MsgStoreClass STMMsgStore where
closeMsgStore = closeQueueStore @STMQueue . queueStore_
{-# INLINE closeMsgStore #-}
withActiveMsgQueues = withLoadedQueues . queueStore_
{-# INLINE withActiveMsgQueues #-}
unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
{-# INLINE unsafeWithAllMsgQueues #-}
expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
expireOldMessages _tty ms now ttl =
withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs ms now (now - ttl)
withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs (now - ttl)
foldRcvServiceMessages :: STMMsgStore -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a)
foldRcvServiceMessages ms serviceId f = fmap Right . foldRcvServiceQueues (queueStore_ ms) serviceId f'
where
f' a (q, qr) = runExceptT (tryPeekMsg ms q) >>= f a (recipientId q) . ((qr,) <$$>)
logQueueStates _ = pure ()
{-# INLINE logQueueStates #-}
logQueueState _ = pure ()
{-# INLINE logQueueState #-}
queueStore = queueStore_
{-# INLINE queueStore #-}
@@ -103,34 +97,11 @@ instance MsgStoreClass STMMsgStore where
loadedQueueCounts STMMsgStore {queueStore_ = st} = do
loadedQueueCount <- M.size <$> readTVarIO (queues st)
loadedNotifierCount <- M.size <$> readTVarIO (notifiers st)
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount = 0}
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount}
mkQueue _ _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
{-# INLINE mkQueue #-}
getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue
getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure
where
newQ = do
msgTQueue <- newTQueue
canWrite <- newTVar True
size <- newTVar 0
let q = STMMsgQueue {msgTQueue, canWrite, size}
writeTVar msgQueue' (Just q)
pure q
getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
getPeekMsgQueue _ q@STMQueue {msgQueue'} = readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
-- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case
Just q -> do
r <- action q
sz <- getQueueSize_ q
pure (Just r, sz)
Nothing -> pure (Nothing, 0)
deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
deleteQueue ms q = fst <$$> deleteQueue_ ms q
@@ -140,17 +111,9 @@ instance MsgStoreClass STMMsgStore where
where
getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message]
getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
where
snapshotTQueue q = do
msgs <- flushTQueue q
mapM_ (writeTQueue q) msgs
pure msgs
writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg ms q' _logState msg = liftIO $ atomically $ do
STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True
STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue q'
canWrt <- readTVar canWrite
empty <- isEmptyTQueue q
if canWrt || empty
@@ -166,29 +129,96 @@ instance MsgStoreClass STMMsgStore where
STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms
msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
setOverQuota_ :: STMQueue -> IO ()
setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
tryPeekMsg :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg _ q = snd <$$> withPeekMsgQueue q pure
{-# INLINE tryPeekMsg #-}
getQueueSize_ :: STMMsgQueue -> STM Int
getQueueSize_ STMMsgQueue {size} = readTVar size
tryPeekMsgs :: STMMsgStore -> [STMQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message)
tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs
tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
tryPeekMsg_ _ = tryPeekTQueue . msgTQueue
{-# INLINE tryPeekMsg_ #-}
tryDelMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message)
tryDelMsg _ q msgId' =
withPeekMsgQueue q $
maybe (pure Nothing) $ \(mq, msg) ->
if messageId msg == msgId'
then tryDeleteMsg_ mq $> Just msg
else pure Nothing
tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState =
tryReadTQueue q >>= \case
Just _ -> modifyTVar' size (subtract 1)
_ -> pure ()
tryDelPeekMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg _ q msgId' =
withPeekMsgQueue q $
maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
if messageId msg == msgId'
then (Just msg,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq)
else pure (Nothing, Just msg)
isolateQueue :: STMMsgStore -> STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
isolateQueue _ _ _ = liftIO . atomically
{-# INLINE isolateQueue #-}
deleteExpiredMsgs :: STMMsgStore -> STMQueue -> Int64 -> ExceptT ErrorType IO Int
deleteExpiredMsgs _ q old = liftIO $ atomically $ getMsgQueue q >>= deleteExpireMsgs_ old
unsafeRunStore :: STMQueue -> Text -> STM a -> IO a
unsafeRunStore _ _ = atomically
{-# INLINE unsafeRunStore #-}
getQueueSize :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO Int
getQueueSize _ q = withPeekMsgQueue q $ maybe (pure 0) (getQueueSize_ . fst)
{-# INLINE getQueueSize #-}
-- can ONLY be used while restoring messages, not while server running
setOverQuota_ :: STMQueue -> IO ()
setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
getQueueSize_ :: STMMsgQueue -> STM Int
getQueueSize_ STMMsgQueue {size} = readTVar size
tryPeekMsg_ :: STMMsgQueue -> STM (Maybe Message)
tryPeekMsg_ = tryPeekTQueue . msgTQueue
{-# INLINE tryPeekMsg_ #-}
tryDeleteMsg_ :: STMMsgQueue -> STM ()
tryDeleteMsg_ STMMsgQueue {msgTQueue = q, size} =
tryReadTQueue q >>= \case
Just _ -> modifyTVar' size (subtract 1)
_ -> pure ()
getMsgQueue :: STMQueue -> STM STMMsgQueue
getMsgQueue STMQueue {msgQueue'} = readTVar msgQueue' >>= maybe newQ pure
where
newQ = do
msgTQueue <- newTQueue
canWrite <- newTVar True
size <- newTVar 0
let q = STMMsgQueue {msgTQueue, canWrite, size}
writeTVar msgQueue' (Just q)
pure q
-- The action is called with Nothing when it is known that the queue is empty
withPeekMsgQueue :: STMQueue -> (Maybe (STMMsgQueue, Message) -> STM a) -> ExceptT ErrorType IO a
withPeekMsgQueue STMQueue {msgQueue'} a =
liftIO $ atomically $ (readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ mq) >>= a
getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message]
getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
where
snapshotTQueue q = do
msgs <- flushTQueue q
mapM_ (writeTQueue q) msgs
pure msgs
-- does not create queue if it does not exist
expireQueueMsgs :: Int64 -> STMQueue -> STM MessageStats
expireQueueMsgs old STMQueue {msgQueue'} =
readTVar msgQueue' >>= \case
Just mq -> do
expiredMsgsCount <- deleteExpireMsgs_ old mq
storedMsgsCount <- getQueueSize_ mq
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
Nothing -> pure newMessageStats {storedQueues = 1}
deleteExpireMsgs_ :: Int64 -> STMMsgQueue -> STM Int
deleteExpireMsgs_ old mq = loop 0
where
loop dc =
tryPeekMsg_ mq >>= \case
Just Message {msgTs}
| systemSeconds msgTs < old ->
tryDeleteMsg_ mq >> loop (dc + 1)
_ -> pure dc
deleteQueue_ :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Maybe STMMsgQueue))
deleteQueue_ ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM remove
src/Simplex/Messaging/Server/MsgStore/Types.hs
+6 -96
View File
@@ -4,17 +4,12 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant multi-way if" #-}
module Simplex.Messaging.Server.MsgStore.Types
( MsgStoreClass (..),
MSType (..),
@@ -30,107 +25,50 @@ module Simplex.Messaging.Server.MsgStore.Types
getQueues,
getQueueRecs,
readQueueRec,
withPeekMsgQueue,
expireQueueMsgs,
deleteExpireMsgs_,
) where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans.Except
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Time.Clock.System (SystemTime (systemSeconds))
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Util ((<$$>), ($>>=))
import Simplex.Messaging.Util (($>>=))
class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where
type StoreMonad s = (m :: Type -> Type) | m -> s
class QueueStoreClass (StoreQueue s) (QueueStore s) => MsgStoreClass s where
type MsgStoreConfig s = c | c -> s
type MsgQueue s = q | q -> s
type StoreQueue s = q | q -> s
type QueueStore s = qs | qs -> s
newMsgStore :: MsgStoreConfig s -> IO s
closeMsgStore :: s -> IO ()
withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
-- This function can only be used in server CLI commands or before server is started.
-- tty, store
unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
-- tty, store, now, ttl
expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
foldRcvServiceMessages :: s -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a)
logQueueStates :: s -> IO ()
logQueueState :: StoreQueue s -> StoreMonad s ()
queueStore :: s -> QueueStore s
loadedQueueCounts :: s -> IO LoadedQueueCounts
-- message store methods
mkQueue :: s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s)
getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
-- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s)
deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message]
writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
getQueueSize_ :: MsgQueue s -> StoreMonad s Int
tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
isolateQueue :: s -> StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a
unsafeRunStore :: StoreQueue s -> Text -> StoreMonad s a -> IO a
-- default implementations are overridden for PostgreSQL storage of messages
tryPeekMsg :: s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
{-# INLINE tryPeekMsg #-}
tryPeekMsgs :: s -> [StoreQueue s] -> ExceptT ErrorType IO (Map RecipientId Message)
tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs
tryDelMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
tryDelMsg st q msgId' =
withPeekMsgQueue st q "tryDelMsg" $
maybe (pure Nothing) $ \(mq, msg) ->
if
| messageId msg == msgId' ->
tryDeleteMsg_ q mq True $> Just msg
| otherwise -> pure Nothing
-- atomic delete (== read) last and peek next message if available
tryDelPeekMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg st q msgId' =
withPeekMsgQueue st q "tryDelPeekMsg" $
maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
if
| messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
| otherwise -> pure (Nothing, Just msg)
deleteExpiredMsgs :: s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
deleteExpiredMsgs st q old =
isolateQueue st q "deleteExpiredMsgs" $
getMsgQueue st q False >>= deleteExpireMsgs_ old q
getQueueSize :: s -> StoreQueue s -> ExceptT ErrorType IO Int
getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
{-# INLINE getQueueSize #-}
data MSType = MSMemory | MSJournal | MSPostgres
data MSType = MSMemory | MSPostgres
data QSType = QSMemory | QSPostgres
data SMSType :: MSType -> Type where
SMSMemory :: SMSType 'MSMemory
SMSJournal :: SMSType 'MSJournal
SMSPostgres :: SMSType 'MSPostgres
data SQSType :: QSType -> Type where
@@ -154,17 +92,14 @@ instance Semigroup MessageStats where
data LoadedQueueCounts = LoadedQueueCounts
{ loadedQueueCount :: Int,
loadedNotifierCount :: Int,
openJournalCount :: Int,
queueLockCount :: Int,
notifierLockCount :: Int
loadedNotifierCount :: Int
}
newMessageStats :: MessageStats
newMessageStats = MessageStats 0 0 0
addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
addQueue st = addQueue_ (queueStore st) (mkQueue st True)
addQueue st = addQueue_ (queueStore st) (mkQueue st)
{-# INLINE addQueue #-}
getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
@@ -184,28 +119,3 @@ getQueueRecs st party qIds = getQueues st party qIds >>= mapM (fmap join . mapM
readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec))
readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)
{-# INLINE readQueueRec #-}
-- The action is called with Nothing when it is known that the queue is empty
withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
withPeekMsgQueue st q op a = isolateQueue st q op $ getPeekMsgQueue st q >>= a
{-# INLINE withPeekMsgQueue #-}
-- not used with PostgreSQL message store
expireQueueMsgs :: MsgStoreClass s => s -> Int64 -> Int64 -> StoreQueue s -> StoreMonad s MessageStats
expireQueueMsgs st now old q = do
(expired_, stored) <- withIdleMsgQueue now st q $ deleteExpireMsgs_ old q
pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1}
-- not used with PostgreSQL message store
deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
deleteExpireMsgs_ old q mq = do
n <- loop 0
logQueueState q
pure n
where
loop dc =
tryPeekMsg_ q mq >>= \case
Just Message {msgTs}
| systemSeconds msgTs < old ->
tryDeleteMsg_ q mq False >> loop (dc + 1)
_ -> pure dc
src/Simplex/Messaging/Server/Names/HttpResolver.hs
+5 -1
View File
@@ -141,4 +141,8 @@ httpGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes}
else do
bs <- brReadSome (responseBody res) (maxResponseBytes + 1)
pure $ if BL.length bs > fromIntegral maxResponseBytes then Left BodyTooLarge else Right bs
pure (either (Left . HttpFailure) id result)
pure (either (Left . httpError) id result)
where
httpError = \case
HC.HttpExceptionRequest _ HC.ResponseTimeout -> ResolverTimeout
e -> HttpFailure e
src/Simplex/Messaging/Server/Prometheus.hs
+25 -15
View File
@@ -126,6 +126,11 @@ prometheusMetrics sm rtm ts =
_ntfServices,
_rcvServicesSubMsg,
_rcvServicesSubDuplicate,
_authDelayExceeded,
_cmdSlotWaits,
_cmdSlotWaitMs,
_cmdSlotWaitMaxMs,
_cmdSlotWaitTimeouts,
_qCount,
_msgCount,
_ntfCount,
@@ -192,6 +197,23 @@ prometheusMetrics sm rtm ts =
\# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\
\# TYPE simplex_smp_queues_notify_monthly gauge\n\
\simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\
\\n\
\# HELP simplex_smp_auth_delay_exceeded Responses with AUTH errors sent without delay, as processing took longer than the delay.\n\
\# TYPE simplex_smp_auth_delay_exceeded counter\n\
\simplex_smp_auth_delay_exceeded " <> mshow _authDelayExceeded <> "\n# authDelayExceeded\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_ms Time commands waited for a free slot of the connection concurrency limit, in ms.\n\
\# TYPE simplex_smp_cmd_slot_wait_ms summary\n\
\simplex_smp_cmd_slot_wait_ms_sum " <> mshow _cmdSlotWaitMs <> "\n# cmdSlotWaitMs\n\
\simplex_smp_cmd_slot_wait_ms_count " <> mshow _cmdSlotWaits <> "\n# cmdSlotWaits\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_ms_max The longest wait for a free command slot, in ms.\n\
\# TYPE simplex_smp_cmd_slot_wait_ms_max gauge\n\
\simplex_smp_cmd_slot_wait_ms_max " <> mshow _cmdSlotWaitMaxMs <> "\n# cmdSlotWaitMaxMs\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_timeouts Commands not processed because the client timed out while they waited for a free slot.\n\
\# TYPE simplex_smp_cmd_slot_wait_timeouts counter\n\
\simplex_smp_cmd_slot_wait_timeouts " <> mshow _cmdSlotWaitTimeouts <> "\n# cmdSlotWaitTimeouts\n\
\\n"
subscriptions =
"# Subscriptions\n\
@@ -564,25 +586,13 @@ prometheusMetrics sm rtm ts =
\# TYPE simplex_smp_subscription_ntf_service_subs_total gauge\n\
\simplex_smp_subscription_ntf_service_subs_total " <> mshow (subServiceSubsCount ntfSubs) <> "\n# ntf.subServiceSubsCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory/journal storage)\n\
\# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_queue_count gauge\n\
\simplex_smp_loaded_queues_queue_count " <> mshow (loadedQueueCount loadedCounts) <> "\n# loadedCounts.loadedQueueCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory/journal storage)\n\
\# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_ntf_count gauge\n\
\simplex_smp_loaded_queues_ntf_count " <> mshow (loadedNotifierCount loadedCounts) <> "\n# loadedCounts.loadedNotifierCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_open_journal_count Total opened queue journals (0 for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_open_journal_count gauge\n\
\simplex_smp_loaded_queues_open_journal_count " <> mshow (openJournalCount loadedCounts) <> "\n# loadedCounts.openJournalCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_queue_lock_count Total queue locks (0 for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_queue_lock_count gauge\n\
\simplex_smp_loaded_queues_queue_lock_count " <> mshow (queueLockCount loadedCounts) <> "\n# loadedCounts.queueLockCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_ntf_lock_count Total notifier locks (0 for memory/journal storage)\n\
\# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\
\simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n"
\simplex_smp_loaded_queues_ntf_count " <> mshow (loadedNotifierCount loadedCounts) <> "\n# loadedCounts.loadedNotifierCount\n"
showTimeBuckets :: Text -> IM.IntMap Int -> Text
showTimeBuckets metric = T.concat . snd . mapAccumL accumBucket (0, 0) . IM.assocs
src/Simplex/Messaging/Server/QueueStore.hs
+7
View File
@@ -13,12 +13,14 @@ module Simplex.Messaging.Server.QueueStore
ServiceRec (..),
CertFingerprint,
ServerEntityStatus (..),
isSecuredMsgQueue,
) where
import Control.Applicative (optional, (<|>))
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (isJust)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Simplex.Messaging.Encoding
@@ -48,6 +50,11 @@ data QueueRec = QueueRec
}
deriving (Show)
isSecuredMsgQueue :: QueueRec -> Bool
isSecuredMsgQueue QueueRec {queueMode, senderKey} = case queueMode of
Just QMContact -> False
_ -> isJust senderKey
data NtfCreds = NtfCreds
{ notifierId :: NotifierId,
notifierKey :: NtfPublicAuthKey,
src/Simplex/Messaging/Server/QueueStore/Postgres.hs
+54 -190
View File
@@ -24,9 +24,7 @@ module Simplex.Messaging.Server.QueueStore.Postgres
batchInsertServices,
batchInsertQueues,
foldServiceRecs,
foldRcvServiceQueueRecs,
foldQueueRecs,
foldRecentQueueRecs,
handleDuplicate,
rowToQueueRec,
withLog_,
@@ -43,13 +41,12 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Bitraversable (bimapM)
import Data.Either (fromRight, lefts)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (foldl', intersperse, partition)
@@ -91,7 +88,7 @@ import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPServiceRole (..))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=))
import System.Exit (exitFailure)
import System.IO (IOMode (..), hFlush, stdout)
import UnliftIO.STM
@@ -103,35 +100,19 @@ import Simplex.Messaging.Encoding.String
data PostgresQueueStore q = PostgresQueueStore
{ dbStore :: DBStore,
dbStoreLog :: Maybe (StoreLog 'WriteMode),
-- this map caches all created and opened queues
queues :: TMap RecipientId q,
-- this map only cashes the queues that were attempted to send messages to,
senders :: TMap SenderId RecipientId,
links :: TMap LinkId RecipientId,
-- this map only cashes the queues that were attempted to be subscribed to,
notifiers :: TMap NotifierId RecipientId,
notifierLocks :: TMap NotifierId Lock,
serviceLocks :: TMap CertFingerprint Lock,
deletedTTL :: Int64,
useCache :: Bool
deletedTTL :: Int64
}
type UseQueueCache = Bool
instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache)
type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
newQueueStore :: (PostgresStoreCfg, UseQueueCache) -> IO (PostgresQueueStore q)
newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do
newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q)
newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
queues <- TM.emptyIO
senders <- TM.emptyIO
links <- TM.emptyIO
notifiers <- TM.emptyIO
notifierLocks <- TM.emptyIO
serviceLocks <- TM.emptyIO
pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache}
pure PostgresQueueStore {dbStore, dbStoreLog, serviceLocks, deletedTTL}
where
err e = do
logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -142,9 +123,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
closeDBStore dbStore
mapM_ closeStoreLog dbStoreLog
loadedQueues = queues
{-# INLINE loadedQueues #-}
compactQueues :: PostgresQueueStore q -> IO Int64
compactQueues st@PostgresQueueStore {deletedTTL} = do
old <- subtract deletedTTL . systemSeconds <$> liftIO getSystemTime
@@ -170,131 +148,44 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
(SRMessaging, SRNotifier)
pure EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount}
-- this implementation assumes that the lock is already taken by addQueue
-- and relies on unique constraints in the database to prevent duplicate IDs.
-- this implementation relies on unique constraints in the database to prevent duplicate IDs.
addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
addQueue_ st mkQ rId qr = do
sq <- mkQ rId qr
withQueueLock sq "addQueue_" $ E.uninterruptibleMask_ $ runExceptT $ do
E.uninterruptibleMask_ $ runExceptT $ do
void $ withDB "addQueue_" st $ \db ->
E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr))
>>= bimapM handleDuplicate pure
when useCache $ do
atomically $ TM.insert rId sq queues
atomically $ TM.insert (senderId qr) rId senders
forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
pure sq
where
PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
-- Not doing duplicate checks in maps as the probability of duplicates is very low.
-- It needs to be reconsidered when IDs are supplied by the users.
-- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
-- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st mkQ party qId
| useCache = case party of
SRecipient -> getRcvQueue qId
SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
-- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
| otherwise = case party of
SRecipient -> loadQueueNoCache " WHERE recipient_id = ?"
SSender -> loadQueueNoCache " WHERE sender_id = ?"
SSenderLink -> loadQueueNoCache " WHERE link_id = ?"
SNotifier -> loadQueueNoCache " WHERE notifier_id = ?"
getQueue_ :: QueueParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st mkQ party qId = case party of
SRecipient -> loadQueue " WHERE recipient_id = ?"
SSender -> loadQueue " WHERE sender_id = ?"
SSenderLink -> loadQueue " WHERE link_id = ?"
SNotifier -> loadQueue " WHERE notifier_id = ?"
where
PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
loadRcvQueue = do
(rId, qRec) <- loadQueue " WHERE recipient_id = ?"
liftIO $ cacheQueue rId qRec $ \_ -> pure () -- recipient map already checked, not caching sender ref
loadSndQueue = loadSndQueue_ " WHERE sender_id = ?"
loadLinkQueue = loadSndQueue_ " WHERE link_id = ?"
loadNtfQueue = do
(rId, qRec) <- loadQueue " WHERE notifier_id = ?"
liftIO $
TM.lookupIO rId queues -- checking recipient map first, not creating lock in map, not caching queue
>>= maybe (mkQ False rId qRec) pure
loadSndQueue_ condition = do
(rId, qRec) <- loadQueue condition
liftIO $
TM.lookupIO rId queues -- checking recipient map first
>>= maybe (cacheQueue rId qRec cacheSender) (atomically (cacheSender rId) $>)
loadQueueNoCache cond = mask $ loadQueue cond >>= liftIO . uncurry (mkQ True)
loadQueue cond = mask $ loadQueueRec cond >>= liftIO . uncurry mkQ
mask = E.uninterruptibleMask_ . runExceptT
cacheSender rId = TM.insert qId rId senders
loadQueue condition =
loadQueueRec condition =
withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
cacheQueue rId qRec insertRef = do
sq <- mkQ True rId qRec -- loaded queue
-- This lock prevents the scenario when the queue is added to cache,
-- while another thread is proccessing the same queue in withAllMsgQueues
-- without adding it to cache, possibly trying to open the same files twice.
-- Alse see comment in idleDeleteExpiredMsgs.
withQueueLock sq "getQueue_" $ atomically $
-- checking the cache again for concurrent reads,
-- use previously loaded queue if exists.
TM.lookup rId queues >>= \case
Just sq' -> pure sq'
Nothing -> do
insertRef rId
TM.insert rId sq queues
pure sq
getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ st mkQ party qIds
| null qIds = pure []
| useCache = case party of
SRecipient -> do
qs <- readTVarIO queues
let qs' = map (\qId -> get qs qId qId) qIds
E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
SNotifier -> do
ns <- readTVarIO notifiers
qs <- readTVarIO queues
let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
(nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
| otherwise = E.uninterruptibleMask_ $ case party of
SRecipient -> loadQueuesNoCache " WHERE recipient_id IN ?" $ \(rId, qRec) ->
Just . (rId,) <$> mkQ False rId qRec
SNotifier -> loadQueuesNoCache " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ False rId qRec
SRecipient -> loadQueues " WHERE recipient_id IN ?" $ \(rId, qRec) ->
Just . (rId,) <$> mkQ rId qRec
SNotifier -> loadQueues " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ rId qRec
where
PostgresQueueStore {queues, notifiers, useCache} = st
get :: M.Map QueueId a -> QueueId -> QueueId -> Either QueueId a
get m qId = maybe (Left qId) Right . (`M.lookup` m)
loadQueues :: [Either QueueId q] -> Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q]
loadQueues qs' cond mkCacheQueue = do
let qIds' = lefts qs'
if null qIds'
then pure $ map (first (const INTERNAL)) qs'
else do
qs_ <- dbLoadQueues qIds' cond mkCacheQueue
pure $ map (result qs_) qs'
where
result :: Either ErrorType (M.Map QueueId q) -> Either QueueId q -> Either ErrorType q
result _ (Right q) = Right q
result qs_ (Left qId) = maybe (Left AUTH) Right . M.lookup qId =<< qs_
dbLoadQueues qIds' cond mkQueue' =
runExceptT $ fmap M.fromList $
withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
>>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec)
cacheRcvQueue (rId, qRec) = do
sq <- mkQ True rId qRec
sq' <- withQueueLock sq "getQueue_" $ atomically $
-- checking the cache again for concurrent reads, use previously loaded queue if exists.
TM.lookup rId queues >>= \case
Just sq' -> pure sq'
Nothing -> sq <$ TM.insert rId sq queues
pure $ Just (rId, sq')
loadQueuesNoCache cond mkQueue' = do
loadQueues cond mkQueue' = do
qs_ <- dbLoadQueues qIds cond mkQueue'
pure $ map (result qs_) qIds
where
@@ -312,11 +203,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
addQueueLinkData st sq lnkId d =
withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
withQueueRec sq $ \q -> case queueData q of
Nothing ->
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId))
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId, QMContact))
Just (lnkId', _) | lnkId' == lnkId ->
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data = ?)") (d :. (lnkId, rId, fst d))
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data = ?)") (d :. (lnkId, rId, QMContact, fst d))
_ -> throwE AUTH
where
rId = recipientId sq
@@ -324,11 +215,12 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
assertUpdated $ withDB' "addQueueLinkData" st update
atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just (lnkId, d)}
withLog "addQueueLinkData" st $ \s -> logCreateLink s rId lnkId d
qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL"
-- the sender key condition is checked in SQL because without cache each command reads its own copy of the queue record
qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL AND (sender_key IS NULL OR queue_mode = ?)"
deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
deleteQueueLinkData st sq =
withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of
withQueueRec sq $ \q -> case queueData q of
Just _ -> do
assertUpdated $ withDB' "deleteQueueLinkData" st $ \db ->
DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId)
@@ -340,7 +232,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
secureQueue st sq sKey =
withQueueRec sq "secureQueue" $ \q -> do
withQueueRec sq $ \q -> do
verify q
assertUpdated $ withDB' "secureQueue" st $ \db ->
DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL AND (sender_key IS NULL OR sender_key = ?)" (sKey, rId, sKey)
@@ -354,7 +246,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
updateKeys :: PostgresQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ())
updateKeys st sq rKeys =
withQueueRec sq "updateKeys" $ \q -> do
withQueueRec sq $ \q -> do
assertUpdated $ withDB' "updateKeys" st $ \db ->
DB.execute db "UPDATE msg_queues SET recipient_keys = ? WHERE recipient_id = ? AND deleted_at IS NULL" (rKeys, rId)
atomically $ writeTVar (queueRec sq) $ Just q {recipientKeys = rKeys}
@@ -364,24 +256,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
withQueueRec sq "addQueueNotifier" $ \q ->
checkCachedNotifier $ do
assertUpdated $ withDB "addQueueNotifier" st $ \db ->
E.try (update db) >>= bimapM handleDuplicate pure
nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
let !q' = q {notifier = Just ntfCreds}
atomically $ writeTVar (queueRec sq) $ Just q'
when useCache $ do
atomically $ TM.insert nId rId notifiers
withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
pure nc_
withQueueRec sq $ \q -> do
assertUpdated $ withDB "addQueueNotifier" st $ \db ->
E.try (update db) >>= bimapM handleDuplicate pure
let !q' = q {notifier = Just ntfCreds}
atomically $ writeTVar (queueRec sq) $ Just q'
withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
pure $ notifier q
where
checkCachedNotifier add
| useCache =
ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT add
| otherwise = add
PostgresQueueStore {notifiers, useCache} = st
rId = recipientId sq
update db =
DB.execute
@@ -395,18 +277,13 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
deleteQueueNotifier st sq =
withQueueRec sq "deleteQueueNotifier" $ \q ->
ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
withNotifierLock nId $ runExceptT $ do
assertUpdated $ withDB' "deleteQueueNotifier" st update
when (useCache st) $ atomically $ TM.delete nId $ notifiers st
atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
pure nc
withQueueRec sq $ \q ->
forM (notifier q) $ \nc -> do
assertUpdated $ withDB' "deleteQueueNotifier" st update
atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
pure nc
where
withNotifierLock nId
| useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier"
| otherwise = id
rId = recipientId sq
update db =
DB.execute
@@ -435,7 +312,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
updateQueueTime :: PostgresQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
updateQueueTime st sq t =
withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
withQueueRec sq $ \q@QueueRec {updatedAt} ->
if updatedAt == Just t
then pure q
else do
@@ -448,7 +325,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
where
rId = recipientId sq
-- this method is called from JournalMsgStore deleteQueue that already locks the queue
deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType QueueRec)
deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do
q <- ExceptT $ readQueueRecIO qr
@@ -456,11 +332,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
assertUpdated $ withDB' "deleteStoreQueue" st $ \db ->
DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
atomically $ writeTVar qr Nothing
when (useCache st) $ do
atomically $ TM.delete (senderId q) $ senders st
forM_ (notifier q) $ \NtfCreds {notifierId} -> do
atomically $ TM.delete notifierId $ notifiers st
atomically $ TM.delete notifierId $ notifierLocks st
withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
pure q
where
@@ -483,7 +354,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
pure serviceId
setQueueService :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
setQueueService st sq party serviceId = withQueueRec sq "setQueueService" $ \q -> case party of
setQueueService st sq party serviceId = withQueueRec sq $ \q -> case party of
SRecipientService
| rcvServiceId q == serviceId -> pure ()
| otherwise -> do
@@ -608,11 +479,6 @@ foldServiceRecs st f =
DB.fold_ db "SELECT service_id, service_role, service_cert, service_cert_hash, created_at FROM services" mempty $
\ !acc -> fmap (acc <>) . f . rowToServiceRec
foldRcvServiceQueueRecs :: PostgresQueueStore q -> ServiceId -> (a -> (RecipientId, QueueRec) -> IO a) -> a -> IO (Either ErrorType a)
foldRcvServiceQueueRecs st serviceId f acc =
runExceptT $ withDB' "foldRcvServiceQueueRecs" st $ \db ->
DB.fold db (queueRecQuery <> " WHERE rcv_service_id = ? AND deleted_at IS NULL") (Only serviceId) acc $ \a -> f a . rowToQueueRec
foldQueueRecs :: Monoid a => Bool -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
foldQueueRecs withData = foldQueueRecs_ foldRecs
where
@@ -621,12 +487,6 @@ foldQueueRecs withData = foldQueueRecs_ foldRecs
| otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec
cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC"
foldRecentQueueRecs :: Monoid a => Int64 -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
foldRecentQueueRecs old = foldQueueRecs_ foldRecs
where
foldRecs db acc f' = DB.fold db (queueRecQuery <> cond) (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
cond = " WHERE deleted_at IS NULL AND updated_at > ? ORDER BY recipient_id ASC"
foldQueueRecs_ ::
Monoid a =>
(DB.Connection -> (Int, a) -> ((Int, a) -> (RecipientId, QueueRec) -> IO (Int, a)) -> IO (Int, a)) ->
@@ -750,15 +610,15 @@ rowToServiceRec (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedA
setStatusDB :: StoreQueueClass q => Text -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
setStatusDB op st sq status writeLog =
withQueueRec sq op $ \q -> do
withQueueRec sq $ \q -> do
assertUpdated $ withDB' op st $ \db ->
DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ? AND deleted_at IS NULL" (status, recipientId sq)
atomically $ writeTVar (queueRec sq) $ Just q {status}
writeLog
withQueueRec :: StoreQueueClass q => q -> Text -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
withQueueRec sq op action =
withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
withQueueRec :: StoreQueueClass q => q -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
withQueueRec sq action =
E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO ()
assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH))
@@ -824,6 +684,10 @@ instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s
deriving newtype instance FromField EncDataBytes
instance ToField MsgId where toField = toField . Binary . unMsgId
instance FromField MsgId where fromField = blobFieldDecoder mkMsgId
deriving newtype instance ToField (RoundedSystemTime t)
deriving newtype instance FromField (RoundedSystemTime t)
src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql
-7
View File
@@ -1,6 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -552,7 +549,3 @@ ALTER TABLE ONLY smp_server.msg_queues
ALTER TABLE ONLY smp_server.msg_queues
ADD CONSTRAINT msg_queues_rcv_service_id_fkey FOREIGN KEY (rcv_service_id) REFERENCES smp_server.services(service_id) ON UPDATE RESTRICT ON DELETE SET NULL;
src/Simplex/Messaging/Server/QueueStore/STM.hs
+12 -5
View File
@@ -18,6 +18,7 @@ module Simplex.Messaging.Server.QueueStore.STM
( STMQueueStore (..),
STMService (..),
foldRcvServiceQueues,
withLoadedQueues,
setStoreLog,
withLog',
readQueueRecIO,
@@ -91,8 +92,6 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
atomically $ TM.clear senders
atomically $ TM.clear notifiers
loadedQueues = queues
{-# INLINE loadedQueues #-}
compactQueues _ = pure 0
{-# INLINE compactQueues #-}
@@ -134,7 +133,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
getQueue_ :: QueueParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ :: QueueParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st _ party qId =
maybe (Left AUTH) Right <$> case party of
SRecipient -> TM.lookupIO qId queues
@@ -144,7 +143,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
where
STMQueueStore {queues, senders, notifiers, links} = st
getQueues_ :: BatchParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ :: BatchParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ st _ party qIds = case party of
SRecipient -> do
qs <- readTVarIO queues
@@ -173,6 +172,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
rId = recipientId sq
qr = queueRec sq
add q = case queueData q of
_ | isSecuredMsgQueue q -> pure $ Left AUTH
Nothing -> addLink
Just (lnkId', d') | lnkId' == lnkId && fst d' == fst d -> addLink
_ -> pure $ Left AUTH
@@ -277,9 +277,11 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
where
rId = recipientId sq
qr = queueRec sq
delete q@QueueRec {senderId, rcvServiceId} = do
delete q@QueueRec {senderId, queueData, rcvServiceId} = do
writeTVar qr Nothing
TM.delete rId $ queues st
TM.delete senderId $ senders st
forM_ queueData $ \(lnkId, _) -> TM.delete lnkId $ links st
mapM_ (removeServiceQueue st serviceRcvQueues rId) rcvServiceId
mapM_ (removeNotifier st) $ notifier q
pure q
@@ -378,6 +380,11 @@ foldRcvServiceQueues st serviceId f acc =
where
get rId = TM.lookupIO rId (queues st) $>>= \q -> (q,) <$$> readTVarIO (queueRec q)
withLoadedQueues :: Monoid a => STMQueueStore q -> (q -> IO a) -> IO a
withLoadedQueues st f = readTVarIO (queues st) >>= foldM run mempty
where
run !acc = fmap (acc <>) . f
withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
src/Simplex/Messaging/Server/QueueStore/Types.hs
+2 -14
View File
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
@@ -9,35 +8,29 @@ module Simplex.Messaging.Server.QueueStore.Types
( StoreQueueClass (..),
QueueStoreClass (..),
EntityCounts (..),
withLoadedQueues,
) where
import Control.Concurrent.STM
import Control.Monad
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Text (Text)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
class StoreQueueClass q where
recipientId :: q -> RecipientId
queueRec :: q -> TVar (Maybe QueueRec)
withQueueLock :: q -> Text -> IO a -> IO a
class StoreQueueClass q => QueueStoreClass q s where
type QueueStoreCfg s
newQueueStore :: QueueStoreCfg s -> IO s
closeQueueStore :: s -> IO ()
getEntityCounts :: s -> IO EntityCounts
loadedQueues :: s -> TMap RecipientId q
compactQueues :: s -> IO Int64
addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
getQueue_ :: QueueParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueues_ :: BatchParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueue_ :: QueueParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueues_ :: BatchParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
deleteQueueLinkData :: s -> q -> IO (Either ErrorType ())
@@ -64,8 +57,3 @@ data EntityCounts = EntityCounts
rcvServiceQueuesCount :: Int,
ntfServiceQueuesCount :: Int
}
withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a
withLoadedQueues st f = readTVarIO (loadedQueues st) >>= foldM run mempty
where
run !acc = fmap (acc <>) . f
src/Simplex/Messaging/Server/Stats.hs
+41
View File
@@ -128,6 +128,12 @@ data ServerStats = ServerStats
ntfServices :: ServiceStats,
rcvServicesSubMsg :: IORef Int,
rcvServicesSubDuplicate :: IORef Int,
authDelayExceeded :: IORef Int,
-- commands that waited for a free slot in forkCmd, total and max wait in ms, and waits that timed out
cmdSlotWaits :: IORef Int,
cmdSlotWaitMs :: IORef Int,
cmdSlotWaitMaxMs :: IORef Int,
cmdSlotWaitTimeouts :: IORef Int,
qCount :: IORef Int,
msgCount :: IORef Int,
ntfCount :: IORef Int,
@@ -190,6 +196,11 @@ data ServerStatsData = ServerStatsData
_rcvServices :: ServiceStatsData,
_rcvServicesSubMsg :: Int,
_rcvServicesSubDuplicate :: Int,
_authDelayExceeded :: Int,
_cmdSlotWaits :: Int,
_cmdSlotWaitMs :: Int,
_cmdSlotWaitMaxMs :: Int,
_cmdSlotWaitTimeouts :: Int,
_qCount :: Int,
_msgCount :: Int,
_ntfCount :: Int,
@@ -254,6 +265,11 @@ newServerStats ts = do
ntfServices <- newServiceStats
rcvServicesSubMsg <- newIORef 0
rcvServicesSubDuplicate <- newIORef 0
authDelayExceeded <- newIORef 0
cmdSlotWaits <- newIORef 0
cmdSlotWaitMs <- newIORef 0
cmdSlotWaitMaxMs <- newIORef 0
cmdSlotWaitTimeouts <- newIORef 0
qCount <- newIORef 0
msgCount <- newIORef 0
ntfCount <- newIORef 0
@@ -315,6 +331,11 @@ newServerStats ts = do
ntfServices,
rcvServicesSubMsg,
rcvServicesSubDuplicate,
authDelayExceeded,
cmdSlotWaits,
cmdSlotWaitMs,
cmdSlotWaitMaxMs,
cmdSlotWaitTimeouts,
qCount,
msgCount,
ntfCount,
@@ -378,6 +399,11 @@ getServerStatsData s = do
_ntfServices <- getServiceStatsData $ ntfServices s
_rcvServicesSubMsg <- readIORef $ rcvServicesSubMsg s
_rcvServicesSubDuplicate <- readIORef $ rcvServicesSubDuplicate s
_authDelayExceeded <- readIORef $ authDelayExceeded s
_cmdSlotWaits <- readIORef $ cmdSlotWaits s
_cmdSlotWaitMs <- readIORef $ cmdSlotWaitMs s
_cmdSlotWaitMaxMs <- readIORef $ cmdSlotWaitMaxMs s
_cmdSlotWaitTimeouts <- readIORef $ cmdSlotWaitTimeouts s
_qCount <- readIORef $ qCount s
_msgCount <- readIORef $ msgCount s
_ntfCount <- readIORef $ ntfCount s
@@ -439,6 +465,11 @@ getServerStatsData s = do
_ntfServices,
_rcvServicesSubMsg,
_rcvServicesSubDuplicate,
_authDelayExceeded,
_cmdSlotWaits,
_cmdSlotWaitMs,
_cmdSlotWaitMaxMs,
_cmdSlotWaitTimeouts,
_qCount,
_msgCount,
_ntfCount,
@@ -503,6 +534,11 @@ setServerStats s d = do
setServiceStats (ntfServices s) $! _ntfServices d
writeIORef (rcvServicesSubMsg s) $! _rcvServicesSubMsg d
writeIORef (rcvServicesSubDuplicate s) $! _rcvServicesSubDuplicate d
writeIORef (authDelayExceeded s) $! _authDelayExceeded d
writeIORef (cmdSlotWaits s) $! _cmdSlotWaits d
writeIORef (cmdSlotWaitMs s) $! _cmdSlotWaitMs d
writeIORef (cmdSlotWaitMaxMs s) $! _cmdSlotWaitMaxMs d
writeIORef (cmdSlotWaitTimeouts s) $! _cmdSlotWaitTimeouts d
writeIORef (qCount s) $! _qCount d
writeIORef (msgCount s) $! _msgCount d
writeIORef (ntfCount s) $! _ntfCount d
@@ -705,6 +741,11 @@ instance StrEncoding ServerStatsData where
_ntfServices,
_rcvServicesSubMsg = 0,
_rcvServicesSubDuplicate = 0,
_authDelayExceeded = 0,
_cmdSlotWaits = 0,
_cmdSlotWaitMs = 0,
_cmdSlotWaitMaxMs = 0,
_cmdSlotWaitTimeouts = 0,
_qCount,
_msgCount = 0,
_ntfCount = 0,
src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs
+3 -12
View File
@@ -14,19 +14,16 @@ module Simplex.Messaging.Server.StoreLog.ReadWrite
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ASubscriberParty (..), ErrorType, RecipientId, SParty (..))
import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..))
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..))
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..), withLoadedQueues)
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Util (tshow)
import Simplex.Messaging.Util (tshow, ($>>=))
import System.IO
writeQueueStore :: forall q. StoreQueueClass q => StoreLog 'WriteMode -> STMQueueStore q -> IO ()
@@ -68,13 +65,7 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
printError :: String -> IO ()
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
withQueue :: forall a. RecipientId -> T.Text -> (q -> IO (Either ErrorType a)) -> IO ()
withQueue qId op a = runExceptT go >>= qError qId op
where
go = do
q <- ExceptT $ getQueue_ st (\_ -> mkQ) SRecipient qId
liftIO (readTVarIO $ queueRec q) >>= \case
Nothing -> logWarn $ logPfx qId op <> "already deleted"
Just _ -> void $ ExceptT $ a q
withQueue qId op a = (getQueue_ st mkQ SRecipient qId $>>= a) >>= qError qId op
qError qId op = \case
Left e -> logError $ logPfx qId op <> tshow e
Right _ -> pure ()
src/Simplex/Messaging/Transport.hs
+5 -9
View File
@@ -46,7 +46,6 @@ module Simplex.Messaging.Transport
minServerSMPRelayVersion,
currentClientSMPRelayVersion,
currentServerSMPRelayVersion,
shortLinksSMPVersion,
serviceCertsSMPVersion,
newNtfCredsSMPVersion,
clientNoticesSMPVersion,
@@ -191,11 +190,8 @@ type VersionRangeSMP = VersionRange SMPVersion
pattern VersionSMP :: Word16 -> VersionSMP
pattern VersionSMP v = Version v
_proxyServerHandshakeSMPVersion :: VersionSMP
_proxyServerHandshakeSMPVersion = VersionSMP 14
shortLinksSMPVersion :: VersionSMP
shortLinksSMPVersion = VersionSMP 15
_shortLinksSMPVersion :: VersionSMP
_shortLinksSMPVersion = VersionSMP 15
serviceCertsSMPVersion :: VersionSMP
serviceCertsSMPVersion = VersionSMP 16
@@ -224,10 +220,10 @@ fwdNoncesSMPVersion :: VersionSMP
fwdNoncesSMPVersion = VersionSMP 23
minClientSMPRelayVersion :: VersionSMP
minClientSMPRelayVersion = VersionSMP 14
minClientSMPRelayVersion = VersionSMP 15
minServerSMPRelayVersion :: VersionSMP
minServerSMPRelayVersion = VersionSMP 14
minServerSMPRelayVersion = VersionSMP 15
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 23
@@ -245,7 +241,7 @@ currentServerSMPRelayVersion = VersionSMP 23
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 23
-- minimal supported protocol version is 14
-- minimal supported protocol version is 15
supportedClientSMPRelayVRange :: VersionRangeSMP
supportedClientSMPRelayVRange = mkVersionRange minClientSMPRelayVersion currentClientSMPRelayVersion
tests/AgentTests.hs
+4 -15
View File
@@ -19,17 +19,12 @@ import Simplex.Messaging.Server.Env.STM (AStoreType (..))
import Simplex.Messaging.Transport (ASrvTransport)
import Test.Hspec hiding (fit, it)
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#else
#if !defined(dbPostgres)
import AgentTests.SQLiteTests (storeTests)
#endif
#if defined(dbServerPostgres)
import AgentTests.NotificationTests (notificationTests)
import SMPClient (postgressBracket)
import NtfClient (ntfTestServerDBConnectInfo)
#endif
agentCoreTests :: Spec
@@ -42,16 +37,10 @@ agentCoreTests = do
agentTests :: (ASrvTransport, AStoreType) -> Spec
agentTests ps = do
#if defined(dbPostgres)
after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do
#else
do
#endif
describe "Functional API" $ functionalAPITests ps
describe "Chosen servers" serverChoiceTests
describe "Functional API" $ functionalAPITests ps
describe "Chosen servers" serverChoiceTests
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Notification tests" $ notificationTests ps
describe "Notification tests" $ notificationTests ps
#endif
#if !defined(dbPostgres)
describe "SQLite store" storeTests
tests/AgentTests/ConnectionRequestTests.hs
+4
View File
@@ -362,6 +362,10 @@ connectionRequestTests =
smpEncodingTest $ AgentServiceRequest [qInfo] Nothing "service request payload"
smpEncodingTest $ AgentServiceResponse "service response payload"
smpEncodingTest $ AgentRejection "rejected: not allowed"
it "should serialize and parse ratchet key info" $ do
smpDecode "R" `shouldBe` Right (AgentRatchetInfo RatchetInfo {answeredKeyHash = Nothing})
smpDecode "R1\3abcdef" `shouldBe` Right (AgentRatchetInfo RatchetInfo {answeredKeyHash = Just "abc"})
smpEncodingTest $ AgentRatchetInfo RatchetInfo {answeredKeyHash = Just "0123456789abcdef0123456789abcdef"}
where
smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation
smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a
tests/AgentTests/FunctionalAPITests.hs
+483 -222
View File
File diff suppressed because it is too large. Load diff
tests/AgentTests/NotificationTests.hs
+50 -42
View File
@@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@@ -65,7 +66,7 @@ import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, te
import SMPClient
import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken)
@@ -85,6 +86,7 @@ import Simplex.Messaging.Protocol (ErrorType (AUTH), NetworkError (..), MsgFlags
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
import Simplex.Messaging.Server.Information (ServerPublicInfo (..))
import Simplex.Messaging.Server.QueueStore.QueueInfo (QueueInfo (..))
import Simplex.Messaging.Transport (ASrvTransport)
import Simplex.Messaging.Transport.Server (TransportServerConfig (..))
import System.Process (callCommand)
@@ -138,7 +140,8 @@ notificationTests ps@(t, _) = do
testNtfTokenReRegisterInvalidOnCheck t apns
describe "notification server tests" $ do
it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Right Nothing
let srv1 = testNtfServer {keyHash = "1234"}
let srv1 :: HasTestEnv => NtfServer
srv1 = testNtfServer {keyHash = "1234"}
it "should fail with incorrect fingerprint" $ do
testRunNTFServerTests t srv1 `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
describe "Managing notification subscriptions" $ do
@@ -186,7 +189,7 @@ notificationTests ps@(t, _) = do
testNotificationsNewToken apns ntf
it "should migrate to service subscriptions" $ testMigrateToServiceSubscriptions ps
testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix ps@(_, msType) runTest = do
describe "next and current" $ do
it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest
@@ -200,6 +203,7 @@ testNtfMatrix ps@(_, msType) runTest = do
it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest
it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest
where
cfg', cfgVPrev' :: HasTestEnv => AServerConfig
cfg' = cfgMS msType
cfgVPrev' = cfgVPrev msType
@@ -212,7 +216,7 @@ checkNtfToken c = A.checkNtfToken c NRMInteractive
verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
verifyNtfToken c = A.verifyNtfToken c NRMInteractive
runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
let smpCfg' = withServerCfg smpCfg $ \cfg_ -> ASrvCfg qt mt cfg_ {serverStoreCfg}
@@ -222,7 +226,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId
threadDelay 100000
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken :: HasTestEnv => APNSMockServer -> IO ()
testNotificationToken apns = do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -230,7 +234,7 @@ testNotificationToken apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
@@ -246,7 +250,7 @@ v .-> key = do
-- logCfg :: LogConfig
-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
testNtfTokenRepeatRegistration :: HasTestEnv => APNSMockServer -> IO ()
testNtfTokenRepeatRegistration apns = do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -254,7 +258,7 @@ testNtfTokenRepeatRegistration apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
getMockNotification apns tkn
@@ -265,7 +269,7 @@ testNtfTokenRepeatRegistration apns = do
NTActive <- checkNtfToken a tkn
pure ()
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
testNtfTokenSecondRegistration :: HasTestEnv => APNSMockServer -> IO ()
testNtfTokenSecondRegistration apns =
withAgentClients2 $ \a a' -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -273,14 +277,14 @@ testNtfTokenSecondRegistration apns =
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
getMockNotification apns tkn
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
nonce' <- C.unsafeCbNonce <$> ntfData' .-> "nonce"
-- at this point the first token is still active
NTActive <- checkNtfToken a tkn
@@ -295,7 +299,7 @@ testNtfTokenSecondRegistration apns =
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -311,12 +315,12 @@ testNtfTokenServerRestart t apns = do
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServer t $ runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a -> do
@@ -327,7 +331,7 @@ testNtfTokenServerRestartReverify t apns = do
pure ntfData
runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
Left (BROKER _ (NETWORK _)) <- tryE $ verifyNtfToken a tkn nonce verification
pure ()
threadDelay 1500000
@@ -339,7 +343,7 @@ testNtfTokenServerRestartReverify t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -348,7 +352,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
pure (nonce, verification)
-- this emulates the situation when server verified token but the client did not receive the response
@@ -374,7 +378,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -393,12 +397,12 @@ testNtfTokenServerRestartReregister t apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -428,7 +432,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
@@ -439,7 +443,7 @@ getTestNtfTokenPort a =
Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
Nothing -> error "no active NtfToken"
testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
@@ -450,7 +454,7 @@ testNtfTokenMultipleServers t apns = do
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
-- shut down the "other" server
@@ -463,7 +467,7 @@ testNtfTokenMultipleServers t apns = do
Left _ <- tryError (checkNtfToken a tkn)
pure ()
testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers t apns =
withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do
tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -493,7 +497,7 @@ testNtfTokenChangeServers t apns =
tkn <- registerTestToken a "qwer" NMInstant apns
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
testNtfTokenReRegisterInvalid :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -518,7 +522,7 @@ testNtfTokenReRegisterInvalid t apns = do
NTActive <- checkNtfToken a tkn1
pure ()
testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -543,13 +547,13 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
NTActive <- checkNtfToken a tkn1
pure ()
testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testRunNTFServerTests :: HasTestEnv => ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testRunNTFServerTests t srv =
withNtfServer t $
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv Nothing)
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection :: HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
(bobId, aliceId, nonce, message) <- runRight $ do
-- establish connection
@@ -566,9 +570,10 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
getMockNotification apns tkn
verification <- ntfData .-> "verification"
vNonce <- C.cbNonce <$> ntfData .-> "nonce"
vNonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken alice tkn vNonce verification
NTActive <- checkNtfToken alice tkn
waitNotifier bobId
-- send message
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
@@ -609,6 +614,9 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
noNotification alice apns
where
msgId = subtract baseId
waitNotifier connId = do
ServerQueueInfo {info = QueueInfo {qiNtf}} <- getConnectionQueueInfo alice NRMInteractive connId
unless qiNtf $ liftIO (threadDelay 20000) >> waitNotifier connId
testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionNewConnection apns baseId alice bob =
@@ -657,12 +665,12 @@ registerTestToken a token mode apns = do
Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <-
timeout 1000000 $ getMockNotification apns tkn
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
nonce' <- C.unsafeCbNonce <$> ntfData' .-> "nonce"
verifyNtfToken a tkn nonce' verification'
NTActive <- checkNtfToken a tkn
pure tkn
testChangeNotificationsMode :: HasCallStack => APNSMockServer -> IO ()
testChangeNotificationsMode :: (HasCallStack, HasTestEnv) => APNSMockServer -> IO ()
testChangeNotificationsMode apns =
withAgentClients2 $ \alice bob -> runRight_ $ do
-- establish connection
@@ -725,7 +733,7 @@ testChangeNotificationsMode apns =
baseId = 1
msgId = subtract baseId
testChangeToken :: APNSMockServer -> IO ()
testChangeToken :: HasTestEnv => APNSMockServer -> IO ()
testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
(aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
-- establish connection
@@ -765,7 +773,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d
baseId = 1
msgId = subtract baseId
testNotificationsStoreLog :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
(aliceId, bobId) <- withNtfServer t $ runRight $ do
@@ -800,7 +808,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withNtfServer t $ runRight_ $ do
void $ messageNotificationData alice apns
testNotificationsSMPRestart :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do
(aliceId, bobId) <- makeConnection alice bob
@@ -828,7 +836,7 @@ testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestartBatch :: Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch :: HasTestEnv => Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
threadDelay 1000000
@@ -869,12 +877,12 @@ testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
runServers :: ExceptT AgentErrorType IO a -> IO a
runServers a = do
withSmpServerStoreLogOn ps testPort $ \t1 -> do
res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 ->
res <- withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \t2 ->
runRight a `finally` killThread t2
killThread t1
pure res
testSwitchNotifications :: AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications :: HasTestEnv => AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications cfg completeSwitch servers apns =
withAgentClientsCfgServers2 cfg cfg servers $ \a b -> runRight_ $ do
(aId, bId) <- makeConnection a b
@@ -893,7 +901,7 @@ testSwitchNotifications cfg completeSwitch servers apns =
liftIO $ threadDelay 500000
testMessage "hello again"
testNotificationsOldToken :: APNSMockServer -> IO ()
testNotificationsOldToken :: HasTestEnv => APNSMockServer -> IO ()
testNotificationsOldToken apns =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
@@ -912,7 +920,7 @@ testNotificationsOldToken apns =
let testMessageAC = testMessage_ apns a acId c caId
testMessageAC "greetings"
testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
testNotificationsNewToken :: HasTestEnv => APNSMockServer -> ThreadId -> IO ()
testNotificationsNewToken apns oldNtf =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
@@ -934,7 +942,7 @@ testNotificationsNewToken apns oldNtf =
let testMessageAC = testMessage_ apns a acId c caId
testMessageAC "greetings"
testMigrateToServiceSubscriptions :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testMigrateToServiceSubscriptions :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO ()
testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> do
(c1, c2, c3) <- withSmpServerConfigOn t cfgNoService testPort $ \_ -> do
(c1, c2) <- withAPNSMockServer $ \apns -> do
@@ -1032,10 +1040,10 @@ testMessage_ apns a aId b bId msg = do
messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
messageNotification apns tkn = do
500000 `timeout` getMockNotification apns tkn >>= \case
5000000 `timeout` getMockNotification apns tkn >>= \case
Nothing -> error "no notification"
Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do
nonce <- C.cbNonce <$> ntfData .-> "nonce"
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
message <- ntfData .-> "message"
pure (nonce, message)
_ -> error "bad notification"
tests/AgentTests/ResolveNameTests.hs
+15 -15
View File
@@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
import Simplex.Messaging.Transport
import Test.Hspec hiding (fit, it)
import Util (it)
import Util (HasTestEnv, it)
nameSrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, names = True} (Just 1) . SMP.noAuthSrv
@@ -40,16 +40,16 @@ nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, na
proxySrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
proxySrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = True, names = False} (Just 1) . SMP.noAuthSrv
oneSrv :: ServerCfg 'SMP.PSMP -> InitialAgentServers
oneSrv :: HasTestEnv => ServerCfg 'SMP.PSMP -> InitialAgentServers
oneSrv cfg_ = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = [(1, [cfg_])]}
withDirectResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withDirectResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withDirectResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withProxyAndResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withProxyAndResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
@@ -59,12 +59,12 @@ withProxyAndResolver (st, body) k =
-- only testSMPServer2 (the resolver) has the names role; testSMPServer is the proxy
proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = [(1, [proxySrvCfg testSMPServer, nameSrvCfg testSMPServer2])]}
withNoResolver :: (AgentClient -> IO a) -> IO a
withNoResolver :: HasTestEnv => (AgentClient -> IO a) -> IO a
withNoResolver k =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withNoNameServers :: (AgentClient -> IO a) -> IO a
withNoNameServers :: HasTestEnv => (AgentClient -> IO a) -> IO a
withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer)) testDB k
resolveNameTests :: Spec
@@ -88,7 +88,7 @@ resolveNameTests = do
describe "name availability" $
it "an unregistered name answers as available" testAvailSuccess
testAvailSuccess :: HasCallStack => IO ()
testAvailSuccess :: (HasCallStack, HasTestEnv) => IO ()
testAvailSuccess =
withDirectResolver (status200, availableBody) $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -98,7 +98,7 @@ testAvailSuccess =
-- | 404 is a resolver that predates /v2/resolve: no status from that endpoint
-- means "not registered", since an unregistered name answers NRAvailable.
testDirectResolverErr :: HasCallStack => IO ()
testDirectResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testDirectResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -106,7 +106,7 @@ testDirectResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testProxyResolverErr :: HasCallStack => IO ()
testProxyResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testProxyResolverErr =
withProxyAndResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -114,7 +114,7 @@ testProxyResolverErr =
Left (SMP host (SMP.NAME (SMP.RESOLVER _))) | testPort `isInfixOf` host -> pure ()
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME (RESOLVER _))), got: " <> show r
testTestingTldResolverErr :: HasCallStack => IO ()
testTestingTldResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testTestingTldResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" [])
@@ -122,7 +122,7 @@ testTestingTldResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testWebTldResolverErr :: HasCallStack => IO ()
testWebTldResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testWebTldResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" [])
@@ -130,7 +130,7 @@ testWebTldResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testNoResolver :: HasCallStack => IO ()
testNoResolver :: (HasCallStack, HasTestEnv) => IO ()
testNoResolver =
withNoResolver $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -138,7 +138,7 @@ testNoResolver =
Left (SMP _ (SMP.NAME SMP.NO_RESOLVER)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NO_RESOLVER)), got: " <> show r
testNoNameServers :: HasCallStack => IO ()
testNoNameServers :: (HasCallStack, HasTestEnv) => IO ()
testNoNameServers =
withNoNameServers $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -146,7 +146,7 @@ testNoNameServers =
Left NO_NAME_SERVERS -> pure ()
_ -> expectationFailure $ "expected Left NO_NAME_SERVERS, got: " <> show r
testBackendError :: HasCallStack => IO ()
testBackendError :: (HasCallStack, HasTestEnv) => IO ()
testBackendError =
withDirectResolver (status502, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -154,7 +154,7 @@ testBackendError =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER ..))), got: " <> show r
testDirectSuccess :: HasCallStack => IO ()
testDirectSuccess :: (HasCallStack, HasTestEnv) => IO ()
testDirectSuccess =
withDirectResolver (status200, registeredBody testNameRecord) $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
tests/AgentTests/SQLiteTests.hs
+44 -4
View File
@@ -20,12 +20,13 @@ import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception (SomeException)
import Control.Monad (replicateM_)
import Control.Monad (forM_, replicateM_)
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.ByteArray (ScrubbedBytes)
import Data.ByteString.Char8 (ByteString)
import Data.List (isInfixOf)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time
@@ -51,6 +52,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Ratchet (pattern IKPQOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding (Encoding (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (EntityId (..), QueueMode (..), SubscriptionMode (..), pattern VersionSMPC)
import qualified Simplex.Messaging.Protocol as SMP
@@ -135,6 +137,8 @@ storeTests = do
testCreateRcvMsg
testCreateSndMsg
testCreateRcvAndSndMsgs
describe "deleteRatchetKeyHashesExpired" testDeleteRatchetKeyHashesExpired
it "should keep only the newest skipped message keys" testGetSkippedMsgKeys
describe "Work items" $ do
it "should getPendingQueueMsg" testGetPendingQueueMsg
it "should getPendingServerCommand" testGetPendingServerCommand
@@ -509,7 +513,7 @@ hw = encodeUtf8 "Hello world!"
ts :: UTCTime
ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> BrokerId -> MsgHash -> RcvMsgData
mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> ByteString -> MsgHash -> RcvMsgData
mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
RcvMsgData
{ internalRcvId,
@@ -518,7 +522,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
{ integrity = MsgOk,
recipient = (unId internalId, ts),
sndMsgId = externalSndId,
broker = (brokerId, ts),
broker = (SMP.unsafeMsgId $ mconcat (replicate 24 brokerId), ts),
pqEncryption = CR.PQEncOn
},
msgType = AM_A_MSG_,
@@ -599,6 +603,42 @@ testCreateRcvAndSndMsgs =
testCreateSndMsg_ db "snd_hash_1" connId sq $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
testCreateSndMsg_ db "snd_hash_2" connId sq $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
testDeleteRatchetKeyHashesExpired :: SpecWith DBStore
testDeleteRatchetKeyHashesExpired =
it "should delete expired ratchet key hashes except the newest in each connection" . withStoreTransaction $ \db -> do
g <- C.newRandom
Right connId <- createNewConn db g cData1 {connId = ""} SCMInvitation
Right connId' <- createNewConn db g cData1 {connId = ""} SCMContact
let hashes = ["h1", "h2", "h3", "h4", "h5", "h6"]
forM_ hashes $ addProcessedRatchetKeyHash db connId
forM_ (take 4 hashes) $ addProcessedRatchetKeyHash db connId'
deleteRatchetKeyHashesExpired db 86400 4
mapM (checkRatchetKeyHashExists db connId) hashes `shouldReturn` replicate 6 True
deleteRatchetKeyHashesExpired db 0 4
mapM (checkRatchetKeyHashExists db connId) hashes `shouldReturn` [False, False, True, True, True, True]
mapM (checkRatchetKeyHashExists db connId') (take 4 hashes) `shouldReturn` replicate 4 True
testGetSkippedMsgKeys :: DBStore -> Expectation
testGetSkippedMsgKeys st = do
g <- C.newRandom
withTransaction st $ \db -> do
Right connId <- createNewConn db g cData1 {connId = ""} SCMInvitation
Right connId' <- createNewConn db g cData1 {connId = ""} SCMInvitation
createSkippedKeys db connId'
createSkippedKeys db connId
M.map M.keys <$> getSkippedMsgKeys db connId 4
`shouldReturn` M.singleton (C.Key "header_key") [1, 2, 3, 4]
getMsgNs db connId `shouldReturn` [1 .. 4]
getMsgNs db connId' `shouldReturn` [1 .. 10]
where
createSkippedKeys :: DB.Connection -> ConnId -> IO ()
createSkippedKeys db connId = do
DB.execute db "INSERT INTO ratchets (conn_id) VALUES (?)" (Only connId)
forM_ ([10, 9 .. 1] :: [Int]) $ \msgN ->
DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, "header_key" :: ByteString, msgN, smpEncode ("key" :: ByteString, "iv" :: ByteString))
getMsgNs :: DB.Connection -> ConnId -> IO [Int]
getMsgNs db connId = map fromOnly <$> DB.query db "SELECT msg_n FROM skipped_messages WHERE conn_id = ? ORDER BY msg_n" (Only connId)
testCloseReopenStore :: IO ()
testCloseReopenStore = do
st <- createStore'
@@ -648,7 +688,7 @@ hasMigrations :: DBStore -> Expectation
hasMigrations st = getMigrations st `shouldReturn` True
errorGettingMigrations :: DBStore -> Expectation
errorGettingMigrations st = getMigrations st `shouldThrow` \(e :: SomeException) -> "ErrorMisuse" `isInfixOf` show e
errorGettingMigrations st = getMigrations st `shouldThrow` \(e :: SomeException) -> "withTransaction: database closed" `isInfixOf` show e
testGetPendingQueueMsg :: DBStore -> Expectation
testGetPendingQueueMsg st = do
tests/AgentTests/SchemaDump.hs
+36 -1
View File
@@ -48,6 +48,8 @@ schemaDumpTest = do
it "verify strict tables" testVerifyStrict
it "should NOT create user record for new database" testUsersMigrationNew
it "should create user record for old database" testUsersMigrationOld
it "should remove duplicate ratchet key hashes before adding unique index" testRatchetKeyHashesUniqueMigration
it "should clear received_qend switch status on downgrade" testRcvSwitchStatusDowngrade
testVerifySchemaDump :: IO ()
testVerifySchemaDump = do
@@ -114,12 +116,45 @@ testUsersMigrationOld = do
`shouldReturn` ([Only (1 :: Int)])
closeDBStore st'
testRatchetKeyHashesUniqueMigration :: IO ()
testRatchetKeyHashesUniqueMigration = do
let beforeUnique = takeWhile (("m20260929_ratchet_indexes" /=) . name) appMigrations
Right st <- createDBStore (DBOpts testDB [] "" False True TQOff) beforeUnique (MigrationConfig MCError Nothing)
withTransaction' st $ \db -> do
SQL.execute_ db "INSERT INTO users (user_id) VALUES (1)"
SQL.execute_ db "INSERT INTO connections (conn_id, conn_mode, user_id) VALUES (x'01', 'INV', 1), (x'02', 'INV', 1)"
SQL.execute_ db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (x'01', x'aa'), (x'01', x'aa'), (x'01', x'bb'), (x'02', x'aa'), (x'01', x'aa')"
closeDBStore st
Right st' <- createDBStore (DBOpts testDB [] "" False True TQOff) appMigrations (MigrationConfig MCYesUp Nothing)
withTransaction' st' (`SQL.query_` "SELECT processed_ratchet_key_hash_id FROM processed_ratchet_key_hashes ORDER BY processed_ratchet_key_hash_id")
`shouldReturn` [Only (1 :: Int), Only 3, Only 4]
closeDBStore st'
testRcvSwitchStatusDowngrade :: IO ()
testRcvSwitchStatusDowngrade = do
Right st <- createDBStore (DBOpts testDB [] "" False True TQOff) appMigrations (MigrationConfig MCError Nothing)
withTransaction' st $ \db -> do
SQL.execute_ db "INSERT INTO users (user_id) VALUES (1)"
SQL.execute_ db "INSERT INTO connections (conn_id, conn_mode, user_id) VALUES (x'01', 'INV', 1)"
SQL.execute_ db "INSERT INTO servers (host, port, key_hash) VALUES ('localhost', '5001', x'00')"
SQL.execute_ db "INSERT INTO rcv_queues (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, snd_id, status, rcv_queue_id, rcv_primary, switch_status) VALUES ('localhost', '5001', x'01', x'01', x'00', x'00', x'00', x'01', 'active', 1, 0, 'received_qend'), ('localhost', '5001', x'02', x'01', x'00', x'00', x'00', x'02', 'active', 2, 1, 'sending_qadd')"
closeDBStore st
let beforeRcvSwitchStatus = takeWhile (("m20261008_rcv_switch_status" /=) . name) appMigrations
Right st' <- createDBStore (DBOpts testDB [] "" False True TQOff) beforeRcvSwitchStatus (MigrationConfig MCYesUpDown Nothing)
withTransaction' st' (`SQL.query_` "SELECT switch_status FROM rcv_queues ORDER BY rcv_queue_id")
`shouldReturn` [Only (Nothing :: Maybe Text), Only (Just "sending_qadd")]
closeDBStore st'
skipComparisonForDownMigrations :: [String]
skipComparisonForDownMigrations =
[ -- on down migration idx_messages_internal_snd_id_ts index moves down to the end of the file
"m20230814_indexes",
-- snd_secure and last_broker_ts columns swap order on down migration
"m20250322_short_links"
"m20250322_short_links",
-- on down migration idx_processed_ratchet_key_hashes_hash index moves down to the end of the file
"m20260929_ratchet_indexes",
-- sqlite_sequence moves after commands table after VACUUM
"m20261005_commands_autoincrement"
]
getSchema :: FilePath -> FilePath -> IO String
tests/AgentTests/ServerChoice.hs
+2 -2
View File
@@ -57,7 +57,7 @@ storageOnly = ServerRoles {storage = True, proxy = False, names = False}
proxyOnly :: ServerRoles
proxyOnly = ServerRoles {storage = False, proxy = True, names = False}
initServers :: InitialAgentServers
initServers :: HasTestEnv => InitialAgentServers
initServers =
InitialAgentServers
{ smp = M.fromList [(1, testSMPServers)],
@@ -70,7 +70,7 @@ initServers =
presetServers = []
}
testChooseDifferentOperator :: IO ()
testChooseDifferentOperator :: HasTestEnv => IO ()
testChooseDifferentOperator = withAgent 1 agentCfg initServers testDB $ \c -> runRight_ $ do
-- chooses the only operator with storage role
srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs []
tests/CLITests.hs
+22 -22
View File
@@ -49,32 +49,32 @@ import Util
import qualified Data.ByteString.Char8 as B
import qualified Database.PostgreSQL.Simple as PSQL
import Database.PostgreSQL.Simple.Types (Query (..))
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestServerDBOpts)
import SMPClient (postgressBracket)
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Notifications.Server.Main
#endif
cfgPath :: FilePath
cfgPath = "tests/tmp/cli/etc/opt/simplex"
cfgPath :: HasTestEnv => FilePath
cfgPath = testPath "cli/etc/opt/simplex"
logPath :: FilePath
logPath = "tests/tmp/cli/etc/var/simplex"
logPath :: HasTestEnv => FilePath
logPath = testPath "cli/etc/var/simplex"
webPath :: FilePath
webPath = "tests/tmp/cli/var/www"
webPath :: HasTestEnv => FilePath
webPath = testPath "cli/var/www"
ntfCfgPath :: FilePath
ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
ntfCfgPath :: HasTestEnv => FilePath
ntfCfgPath = testPath "cli/etc/opt/simplex-notifications"
ntfLogPath :: FilePath
ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
ntfLogPath :: HasTestEnv => FilePath
ntfLogPath = testPath "cli/etc/var/simplex-notifications"
fileCfgPath :: FilePath
fileCfgPath = "tests/tmp/cli/etc/opt/simplex-files"
fileCfgPath :: HasTestEnv => FilePath
fileCfgPath = testPath "cli/etc/opt/simplex-files"
fileLogPath :: FilePath
fileLogPath = "tests/tmp/cli/etc/var/simplex-files"
fileLogPath :: HasTestEnv => FilePath
fileLogPath = testPath "cli/etc/var/simplex-files"
cliTests :: Spec
cliTests = do
@@ -87,7 +87,7 @@ cliTests = do
it "static files" smpServerTestStatic
it "cloud scripts disable embedded web without certificates" smpCloudScriptsDisableWeb
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestStoreDBOpts) $
around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestServerDBOpts) $
describe "Ntf server CLI" $ do
it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
@@ -96,7 +96,7 @@ cliTests = do
it "should initialize, start and delete the server (no store log)" $ xftpServerTest False
it "should initialize, start and delete the server (with store log)" $ xftpServerTest True
smpServerTest :: Bool -> Bool -> IO ()
smpServerTest :: HasTestEnv => Bool -> Bool -> IO ()
smpServerTest storeLog basicAuth = do
-- init
capture_ (withArgs (["init", "-y"] <> ["--disable-store-log" | not storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
@@ -122,7 +122,7 @@ smpServerTest storeLog basicAuth = do
XF.readSignedObject certPath >>= \case
[cert'] -> pure . X.signedObject $ X.getSigned cert'
_ -> error "bad crt format"
r' <- lines <$> capture_ (withArgs ["cert"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
r' <- lines <$> capture_ (withArgs ["cert"] $ smpServerCLI cfgPath logPath)
r' `shouldContain` ["Generated new server credentials"]
newCrt <-
XF.readSignedObject certPath >>= \case
@@ -137,7 +137,7 @@ smpServerTest storeLog basicAuth = do
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
smpServerTestStatic :: HasCallStack => IO ()
smpServerTestStatic :: (HasCallStack, HasTestEnv) => IO ()
smpServerTestStatic = do
let iniFile = cfgPath <> "/smp-server.ini"
capture_ (withArgs ["init", "-y", "--no-password", "--web-path", webPath] $ smpServerCLI cfgPath logPath)
@@ -225,7 +225,7 @@ createNtfSchema connInfo DBOpts {schema} = do
void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
PSQL.close db
ntfServerTest :: Bool -> IO ()
ntfServerTest :: HasTestEnv => Bool -> IO ()
ntfServerTest storeLog = do
capture_ (withArgs (["init", "--database=" <> B.unpack ntfTestServerDBConnstr] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
@@ -244,9 +244,9 @@ ntfServerTest storeLog = do
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
#endif
xftpServerTest :: Bool -> IO ()
xftpServerTest :: HasTestEnv => Bool -> IO ()
xftpServerTest storeLog = do
capture_ (withArgs (["init", "-p", "tests/tmp", "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
capture_ (withArgs (["init", "-p", testDir, "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> fileCfgPath <> "/file-server.ini") `isPrefixOf`))
Right ini <- readIniFile $ fileCfgPath <> "/file-server.ini"
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
tests/CoreTests/BatchingTests.hs
+29 -5
View File
@@ -14,11 +14,13 @@ import Control.Monad
import Crypto.Random (ChaChaDRG)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.List.NonEmpty as L
import Data.Time.Clock.System (SystemTime, getSystemTime)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import qualified Data.X509.File as XF
import Foreign.Ptr (plusPtr)
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -40,6 +42,8 @@ batchingTests = do
it "should batch subscription responses with message" testBatchSubResponses
it "should break on message that does not fit" testClientBatchWithMessage
it "should break on large message" testClientBatchWithLargeMessage
describe "tDecodeServer" $
it "should copy IDs out of received block" testDecodeServerCopiesIds
testBatchSubscriptions :: IO ()
testBatchSubscriptions = do
@@ -166,6 +170,26 @@ testClientBatchWithLargeMessage = do
(length rs1', length rs2') `shouldBe` (75, 135)
all lenOk [s1', s2'] `shouldBe` True
testDecodeServerCopiesIds :: IO ()
testDecodeServerCopiesIds = do
sessId <- atomically . C.randomBytes 32 =<< C.newRandom
subs <- replicateM 2 $ randomSUB sessId
let thParams = testTHandleParams sessId
[TBTransmissions s 2 _] <- pure $ batchTransmissions thParams $ L.fromList subs
forM_ (tParse thParams s) $ \t -> do
let (corrId, entId, _) = tDecodeClient @SMPVersion @ErrorType @Cmd thParams t
Right (_, _, (corrId', entId', _)) <- pure $ tDecodeServer @SMPVersion @ErrorType @Cmd (testTHandleParams sessId) t
(corrId', entId') `shouldBe` (corrId, entId)
sharesBuffer s (bs corrId) `shouldReturn` True
sharesBuffer s (unEntityId entId) `shouldReturn` True
sharesBuffer s (bs corrId') `shouldReturn` False
sharesBuffer s (unEntityId entId') `shouldReturn` False
sharesBuffer :: ByteString -> ByteString -> IO Bool
sharesBuffer block s =
unsafeUseAsCString block $ \blockPtr -> unsafeUseAsCString s $ \ptr ->
pure $ ptr >= blockPtr && ptr < blockPtr `plusPtr` B.length block
testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
testClientStub = do
g <- C.newRandom
@@ -183,7 +207,7 @@ randomSUB sessId = do
thAuth_ <- testTHandleAuth g rKey
let thParams = testTHandleParams sessId
TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB)
pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) nonce tForAuth
pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) (Just nonce) tForAuth
randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
randomSUBCmd c = do
@@ -202,7 +226,7 @@ randomNMSGCmd :: SystemTime -> IO (Transmission BrokerMsg)
randomNMSGCmd ts = do
g <- C.newRandom
nId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ randomMsgId 24 g
(k, pk) <- atomically $ C.generateKeyPair g
nonce <- atomically $ C.randomCbNonce g
let msgMeta = NMsgMeta {msgId, msgTs = ts}
@@ -221,7 +245,7 @@ randomMSG = do
g <- C.newRandom
corrId <- atomically $ C.randomBytes 24 g
rId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ randomMsgId 24 g
msg <- atomically $ C.randomBytes maxMessageLength g
pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg})
@@ -235,9 +259,9 @@ randomSEND sessId len = do
msg <- atomically $ C.randomBytes len g
let thParams = testTHandleParams sessId
TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) nonce tForAuth
pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) (Just nonce) tForAuth
testTHandleParams :: ByteString -> THandleParams SMPVersion 'TClient
testTHandleParams :: ByteString -> THandleParams SMPVersion p
testTHandleParams sessionId =
THandleParams
{ sessionId,
tests/CoreTests/CryptoFileTests.hs
+8 -8
View File
@@ -24,10 +24,10 @@ cryptoFileTests = do
it "should put/read file" testPutReadFile
it "should fail reading empty or small file" testSmallFile
testFilePath :: FilePath
testFilePath = "tests/tmp/testcryptofile"
testFilePath :: HasTestEnv => FilePath
testFilePath = testPath "testcryptofile"
testWriteReadFile :: IO ()
testWriteReadFile :: HasTestEnv => IO ()
testWriteReadFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
@@ -39,7 +39,7 @@ testWriteReadFile = do
s' <- CF.readFile file
liftIO $ s `shouldBe` s'
testPutGetFile :: IO ()
testPutGetFile :: HasTestEnv => IO ()
testPutGetFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
@@ -59,7 +59,7 @@ testPutGetFile = do
CF.hGetTag h
liftIO $ (s <> s') `shouldBe` LB.fromStrict (s1 <> s2 <> s3)
testWriteGetFile :: IO ()
testWriteGetFile :: HasTestEnv => IO ()
testWriteGetFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
@@ -73,7 +73,7 @@ testWriteGetFile = do
liftIO $ runExceptT (CF.hGetTag h) `shouldReturn` Left FTCEInvalidAuthTag
liftIO $ s `shouldBe` LB.fromStrict (s' <> s'')
testPutReadFile :: IO ()
testPutReadFile :: HasTestEnv => IO ()
testPutReadFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
@@ -92,7 +92,7 @@ testPutReadFile = do
s'' <- CF.readFile file
liftIO $ (s <> s') `shouldBe` s''
testSmallFile :: IO ()
testSmallFile :: HasTestEnv => IO ()
testSmallFile = do
g <- C.newRandom
file <- atomically $ mkCryptoFile g
@@ -101,5 +101,5 @@ testSmallFile = do
LB.writeFile testFilePath "123"
runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile
mkCryptoFile :: HasTestEnv => TVar ChaChaDRG -> STM CryptoFile
mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g
tests/CoreTests/CryptoTests.hs
+4 -4
View File
@@ -146,9 +146,9 @@ instance Eq C.APrivateKey where
Just Refl -> k == k'
Nothing -> False
testPadUnpadFile :: IO ()
testPadUnpadFile :: HasTestEnv => IO ()
testPadUnpadFile = do
let f = "tests/tmp/testpad"
let f = testPath "testpad"
paddedLen = 1024 * 1024
len = 1000000
s = LB.replicate len 'a'
@@ -208,7 +208,7 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s
g <- C.newRandom
k <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
let f = "tests/tmp/testsecretbox"
let f = testPath "testsecretbox"
paddedLen = 4 * 1024 * 1024
len = 4 * 1000 * 1000 :: Int64
s = LC.fastReplicate len 'a'
@@ -236,7 +236,7 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r
g <- C.newRandom
k <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
let f = "tests/tmp/testsecretbox"
let f = testPath "testsecretbox"
paddedLen = 4 * 1024 * 1024
len = 4 * 1000 * 1000 :: Int64
s = LC.fastReplicate len 'a'
tests/CoreTests/MsgStoreTests.hs
+104 -457
View File
@@ -9,15 +9,12 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module CoreTests.MsgStoreTests where
import AgentTests.FunctionalAPITests (runRight, runRight_)
import Control.Concurrent (threadDelay)
import AgentTests.FunctionalAPITests (runRight_)
import Control.Concurrent.STM
import Control.Exception (bracket)
import Control.Monad
@@ -25,82 +22,53 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (fromJust)
import Data.Time.Clock (addUTCTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
import qualified Data.Map.Strict as M
import Data.Time.Clock.System (getSystemTime)
import Simplex.Messaging.Crypto (pattern MaxLenBS)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (EntityId (..), ErrorType, LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags)
import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats)
import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch)
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags, randomMsgId)
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue)
import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile)
import System.FilePath ((</>))
import System.IO (IOMode (..), withFile)
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.TMap (TMap)
import Test.Hspec hiding (fit, it)
import Util
#if defined(dbServerPostgres)
import AgentTests.FunctionalAPITests (runRight)
import Control.Concurrent (threadDelay)
import Data.Time.Clock.System (SystemTime (..))
import Database.PostgreSQL.Simple (Only (..))
import qualified Database.PostgreSQL.Simple as DB
import Simplex.Messaging.Agent.Store.Postgres.Common
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Server.MsgStore.Postgres
import Simplex.Messaging.Server.QueueStore.Postgres
import Simplex.Messaging.Server.QueueStore.Types
import SMPClient (postgressBracket, testServerDBConnectInfo, testStoreDBOpts)
import SMPClient (testStoreDBOpts)
#endif
msgStoreTests :: Spec
msgStoreTests = do
around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests
around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do
someMsgStoreTests
journalMsgStoreTests
it "should export and import journal store" testExportImportStore
describe "STM message store" $ do
someMsgStoreTests testSMTStoreConfig
it "should remove deleted queues from queue store maps" $ withMsgStore testSMTStoreConfig testDeleteQueueMaps
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $ do
around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $
describe "Postgres+journal message store" $ do
someMsgStoreTests
journalMsgStoreTests
around (withMsgStore testPostgresStoreConfig) $
describe "Postgres-only message store" $ do
someMsgStoreTests
it "should correctly update message counts and canWrite flag" testUpdateMessageCounts
it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts
it "should expire messages across commit batches" testExpireMessagesInBatches
describe "Postgres-only message store" $ do
someMsgStoreTests testPostgresStoreConfig
it "should correctly update message counts and canWrite flag" $ withMsgStore testPostgresStoreConfig testUpdateMessageCounts
it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" $ withMsgStore testPostgresStoreConfig testResetMessageCounts
it "should expire messages across commit batches" $ withMsgStore testPostgresStoreConfig testExpireMessagesInBatches
#endif
describe "Journal message store: queue state backup expiration" $ do
it "should remove old queue state backups" testRemoveQueueStateBackups
it "should expire messages in idle queues" testExpireIdleQueues
where
journalMsgStoreTests :: SpecWith (JournalMsgStore s)
journalMsgStoreTests = do
describe "queue state" $ do
it "should restore queue state from the last line" testQueueState
it "should recover when message is written and state is not" testMessageState
it "should remove journal files when queue is empty" testRemoveJournals
describe "missing files" $ do
it "should create read file when missing" testReadFileMissing
it "should switch to write file when read file missing" testReadFileMissingSwitch
it "should create write file when missing" testWriteFileMissing
it "should create read file when read and write files are missing" testReadAndWriteFilesMissing
someMsgStoreTests :: MsgStoreClass s => SpecWith s
someMsgStoreTests = do
it "should get queue and store/read messages" testGetQueue
it "should write/ack messages" testWriteAckMessages
it "should not fail on EOF when changing read journal" testChangeReadJournal
someMsgStoreTests :: MsgStoreClass s => (HasTestEnv => MsgStoreConfig s) -> Spec
someMsgStoreTests cfg = do
it "should get queue and store/read messages" $ withMsgStore cfg testGetQueue
it "should write/ack messages" $ withMsgStore cfg testWriteAckMessages
it "should not add link data to secured messaging queue" $ withMsgStore cfg testLinkDataSecuredQueue
-- TODO constrain to STM stores?
withMsgStore :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO ()
@@ -109,30 +77,15 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore
testSMTStoreConfig :: STMStoreConfig
testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3}
testJournalStoreCfg :: QStoreCfg s -> JournalStoreConfig s
testJournalStoreCfg queueStoreCfg =
JournalStoreConfig
{ storePath = testStoreMsgsDir,
pathParts = journalMsgStoreDepth,
queueStoreCfg,
quota = 3,
maxMsgCount = 4,
maxStateLines = 2,
stateTailSize = 256,
idleInterval = 21600,
expireBackupsAfter = 0,
keepMinBackups = 1
}
#if defined(dbServerPostgres)
testPostgresStoreConfig :: PostgresMsgStoreCfg
testPostgresStoreConfig :: HasTestEnv => PostgresMsgStoreCfg
testPostgresStoreConfig =
PostgresMsgStoreCfg
{ queueStoreCfg = testPostgresStoreCfg,
quota = 3
}
testPostgresStoreCfg :: PostgresStoreCfg
testPostgresStoreCfg :: HasTestEnv => PostgresStoreCfg
testPostgresStoreCfg =
PostgresStoreCfg
{ dbOpts = testStoreDBOpts,
@@ -146,18 +99,12 @@ mkMessage :: MonadIO m => ByteString -> m Message
mkMessage body = liftIO $ do
g <- C.newRandom
msgTs <- getSystemTime
msgId <- atomically $ C.randomBytes 24 g
msgId <- atomically $ randomMsgId 24 g
pure Message {msgId, msgTs, msgFlags = noMsgFlags, msgBody = C.unsafeMaxLenBS body}
pattern Msg :: ByteString -> Maybe Message
pattern Msg s <- Just Message {msgBody = MaxLenBS s}
deriving instance Eq MsgQueueState
deriving instance Eq (JournalState t)
deriving instance Eq (SJournalType t)
testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec)
testNewQueueRec g qm = testNewQueueRecData g qm Nothing
@@ -184,6 +131,18 @@ testNewQueueRecData g qm queueData = do
where
rndId = atomically $ EntityId <$> C.randomBytes 24 g
testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds
testNtfCreds g = do
(notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
(k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
pure
NtfCreds
{ notifierId = EntityId "ijkl",
notifierKey,
rcvNtfDhSecret = C.dh' k pk,
ntfServiceId = Nothing
}
testGetQueue :: MsgStoreClass s => s -> IO ()
testGetQueue ms = do
g <- C.newRandom
@@ -248,76 +207,82 @@ testWriteAckMessages ms = do
void $ ExceptT $ deleteQueue ms q1
void $ ExceptT $ deleteQueue ms q2
testChangeReadJournal :: MsgStoreClass s => s -> IO ()
testChangeReadJournal ms = do
testLinkDataSecuredQueue :: MsgStoreClass s => s -> IO ()
testLinkDataSecuredQueue ms = do
g <- C.newRandom
(sKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let st = queueStore ms
ld = (EncDataBytes "fixed data", EncDataBytes "user data")
rndId = atomically $ EntityId <$> C.randomBytes 24 g
(rId, qr) <- testNewQueueRec g QMMessaging
(cId, cqr) <- testNewQueueRec g QMContact
lnkId <- rndId
cLnkId <- rndId
runRight_ $ do
q <- ExceptT $ addQueue ms rId qr
let write s = writeMsg ms q True =<< mkMessage s
Just (Message {msgId = mId1}, True) <- write "message 1"
(Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1
Just (Message {msgId = mId2}, True) <- write "message 2"
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
Just (Message {msgId = mId3}, True) <- write "message 3"
(Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3
Just (Message {msgId = mId4}, True) <- write "message 4"
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4
Just (Message {msgId = mId5}, True) <- write "message 5"
(Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5
-- the handle is read before SKEY, as in a command that raced with it
staleQ <- ExceptT $ getQueue ms SRecipient rId
ExceptT $ secureQueue st q sKey
liftIO $ addQueueLinkData st staleQ lnkId ld `shouldReturn` Left AUTH
freshQ <- ExceptT $ getQueue ms SRecipient rId
liftIO $ getQueueLinkData st freshQ lnkId `shouldReturn` Left AUTH
cq <- ExceptT $ addQueue ms cId cqr
ExceptT $ secureQueue st cq sKey
ExceptT $ addQueueLinkData st cq cLnkId ld
ld' <- ExceptT $ getQueueLinkData st cq cLnkId
liftIO $ ld' `shouldBe` ld
void $ ExceptT $ deleteQueue ms q
void $ ExceptT $ deleteQueue ms cq
testExportImportStore :: JournalMsgStore 'QSMemory -> IO ()
testExportImportStore ms = do
-- sizes of queues, senders, links and notifiers maps
type QueueMapSizes = (Int, Int, Int, Int)
queueMapSizes :: STMMsgStore -> IO QueueMapSizes
queueMapSizes ms = (,,,) <$> size queues <*> size senders <*> size links <*> size notifiers
where
STMQueueStore {queues, senders, links, notifiers} = queueStore ms
size :: TMap k v -> IO Int
size = fmap M.size . readTVarIO
testDeleteQueueMaps :: STMMsgStore -> IO ()
testDeleteQueueMaps ms = do
g <- C.newRandom
ntfCreds <- testNtfCreds g
let newLinkId = atomically $ EntityId <$> C.randomBytes 24 g
lnkId1 <- newLinkId
lnkId2 <- newLinkId
lnkId3 <- newLinkId
(rId1, qr1) <- testNewQueueRec g QMMessaging
(rId2, qr2) <- testNewQueueRec g QMMessaging
sl <- readWriteQueueStore True (mkQueue ms True) testStoreLogFile $ stmQueueStore ms
(rId2, qr2) <- testNewQueueRecData g QMContact (Just (lnkId1, testLinkData))
(rId3, qr3) <- testNewQueueRec g QMMessaging
(rId4, qr4) <- testNewQueueRec g QMMessaging
let rIds = [rId1, rId2, rId3, rId4] :: [RecipientId]
sIds = map senderId [qr1, qr2, qr3, qr4]
lnkIds = [lnkId1, lnkId2, lnkId3] :: [LinkId]
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
runRight_ $ do
let write q s = writeMsg ms q True =<< mkMessage s
q1 <- ExceptT $ addQueue ms rId1 qr1
liftIO $ logCreateQueue sl rId1 qr1
Just (Message {}, True) <- write q1 "message 1"
Just (Message {}, False) <- write q1 "message 2"
q1 <- ExceptT $ addQueue ms rId1 qr1 {notifier = Just ntfCreds}
q2 <- ExceptT $ addQueue ms rId2 qr2
liftIO $ logCreateQueue sl rId2 qr2
Just (Message {msgId = mId3}, True) <- write q2 "message 3"
Just (Message {msgId = mId4}, False) <- write q2 "message 4"
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q2 mId4
Just (Message {}, True) <- write q2 "message 5"
Just (Message {}, False) <- write q2 "message 6"
Just (Message {}, False) <- write q2 "message 7"
Nothing <- write q2 "message 8"
pure ()
length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3
exportMessages False (StoreJournal ms) testStoreMsgsFile False
closeMsgStore ms
closeStoreLog sl
-- export with closed queues and compare
ms2 <- newMsgStore $ testJournalStoreCfg MQStoreCfg
readWriteQueueStore True (mkQueue ms2 True) testStoreLogFile (stmQueueStore ms2) >>= closeStoreLog
exportMessages False (StoreJournal ms2) (testStoreMsgsFile <> ".copy") False
s <- B.readFile testStoreMsgsFile
B.readFile (testStoreMsgsFile <> ".copy") `shouldReturn` s
q3 <- ExceptT $ addQueue ms rId3 qr3
q4 <- ExceptT $ addQueue ms rId4 qr4
ExceptT $ addQueueLinkData (queueStore ms) q3 lnkId2 testLinkData
ExceptT $ addQueueLinkData (queueStore ms) q4 lnkId3 testLinkData
forM_ sIds $ void . ExceptT . getQueue ms SSender
forM_ lnkIds $ void . ExceptT . getQueue ms SSenderLink
liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 3, 1)
ExceptT $ deleteQueueLinkData (queueStore ms) q3
liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 2, 1)
forM_ ([q1, q2, q3, q4] :: [STMQueue]) $ void . ExceptT . deleteQueue ms
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
forM_ rIds $ \rId -> getQueue ms SRecipient rId >>= expectAuth
forM_ sIds $ \sId -> getQueue ms SSender sId >>= expectAuth
forM_ lnkIds $ \lnkId -> getQueue ms SSenderLink lnkId >>= expectAuth
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
where
expectAuth = either (`shouldBe` AUTH) (\_ -> expectationFailure "deleted queue is still found")
let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2}
ms' <- newMsgStore cfg
readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (stmQueueStore ms') >>= closeStoreLog
stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
importMessages False ms' testStoreMsgsFile Nothing False
printMessageStats "Messages" stats
length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- 2 message files
exportMessages False (StoreJournal ms') testStoreMsgsFile2 False
(B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak")
stmStore <- newMsgStore testSMTStoreConfig
readWriteQueueStore True (mkQueue stmStore True) testStoreLogFile (queueStore stmStore) >>= closeStoreLog
MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
importMessages False stmStore testStoreMsgsFile2 Nothing False
exportMessages False (StoreMemory stmStore) testStoreMsgsFile False
(B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak"))
testLinkData :: QueueLinkData
testLinkData = (EncDataBytes "fixed data", EncDataBytes "user data")
#if defined(dbServerPostgres)
testUpdateMessageCounts :: PostgresMsgStore -> IO ()
@@ -427,321 +392,3 @@ testExpireMessagesInBatches ms = do
where
go n = write q "fill" >>= maybe (pure n) (const $ go (n + 1))
#endif
testQueueState :: JournalMsgStore s -> IO ()
testQueueState ms = do
g <- C.newRandom
rId <- EntityId <$> atomically (C.randomBytes 24 g)
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
createDirectoryIfMissing True dir
state <- newMsgQueueState <$> newJournalId (random ms)
withFile statePath WriteMode (`appendState` state)
length . lines <$> readFile statePath `shouldReturn` 1
readQueueState ms statePath `shouldReturn` (Just state, False)
length <$> listDirectory dir `shouldReturn` 1 -- no backup
let state1 =
state
{ size = 1,
readState = (readState state) {msgCount = 1, byteCount = 100},
writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100}
}
withFile statePath AppendMode (`appendState` state1)
length . lines <$> readFile statePath `shouldReturn` 2
readQueueState ms statePath `shouldReturn` (Just state1, False)
length <$> listDirectory dir `shouldReturn` 1 -- no backup
let state2 =
state
{ size = 2,
readState = (readState state) {msgCount = 2, byteCount = 200},
writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200}
}
withFile statePath AppendMode (`appendState` state2)
length . lines <$> readFile statePath `shouldReturn` 3
copyFile statePath (statePath <> ".2")
readQueueState ms statePath `shouldReturn` (Just state2, True)
length <$> listDirectory dir `shouldReturn` 2 -- new state + copy
ls <- lines <$> readFile statePath
length ls `shouldBe` 3
-- mock compacting file
writeFile statePath $ last ls
-- corrupt the only line
corruptFile statePath
(Nothing, True) <- readQueueState ms statePath
-- corrupt the last line
renameFile (statePath <> ".2") statePath
removeOtherFiles dir statePath
length . lines <$> readFile statePath `shouldReturn` 3
corruptFile statePath
readQueueState ms statePath `shouldReturn` (Just state1, True)
length <$> listDirectory dir `shouldReturn` 1
length . lines <$> readFile statePath `shouldReturn` 3
where
corruptFile f = do
s <- readFile f
removeFile f
writeFile f $ take (length s - 4) s
removeOtherFiles dir keep = do
names <- listDirectory dir
forM_ names $ \name ->
let f = dir </> name
in unless (f == keep) $ removeFile f
testMessageState :: JournalMsgStore s -> IO ()
testMessageState ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
mId1 <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {}, False) <- write q "message 2"
liftIO $ closeMsgQueue ms q
pure mId1
ls <- B.lines <$> B.readFile statePath
B.writeFile statePath $ B.unlines $ take (length ls - 1) ls
runRight_ $ do
q <- ExceptT $ getQueue ms SRecipient rId
Just (Message {msgId = mId3}, False) <- write q "message 3"
(Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms q mId1
(Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3
liftIO $ closeMsgQueue ms q
testRemoveJournals :: JournalMsgStore s -> IO ()
testRemoveJournals ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
ls <- B.lines <$> B.readFile statePath
length ls `shouldBe` 4
journalFilesCount dir `shouldReturn` 1
stateBackupCount dir `shouldReturn` 0
runRight $ do
q <- ExceptT $ getQueue ms SRecipient rId
-- not removed yet
liftIO $ journalFilesCount dir `shouldReturn` 1
liftIO $ stateBackupCount dir `shouldReturn` 0
Nothing <- tryPeekMsg ms q
-- still not removed, queue is empty and not opened
liftIO $ journalFilesCount dir `shouldReturn` 1
_mq <- isolateQueue ms q "test" $ getMsgQueue ms q False
-- journal is removed
liftIO $ journalFilesCount dir `shouldReturn` 0
liftIO $ stateBackupCount dir `shouldReturn` 1
Just (Message {msgId = mId3}, True) <- write q "message 3"
-- journal is created
liftIO $ journalFilesCount dir `shouldReturn` 1
Just (Message {msgId = mId4}, False) <- write q "message 4"
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q mId3
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4
Just (Message {msgId = mId5}, True) <- write q "message 5"
Just (Message {msgId = mId6}, False) <- write q "message 6"
liftIO $ journalFilesCount dir `shouldReturn` 1
Just (Message {msgId = mId7}, False) <- write q "message 7"
-- separate write journal is created
liftIO $ journalFilesCount dir `shouldReturn` 2
Nothing <- write q "message 8"
(Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5
liftIO $ journalFilesCount dir `shouldReturn` 2
(Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6
-- read journal is removed
liftIO $ journalFilesCount dir `shouldReturn` 1
(Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7
(Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8
liftIO $ closeMsgQueue ms q
journalFilesCount dir `shouldReturn` 1
runRight $ do
q <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, True) <- write q "message 8"
liftIO $ journalFilesCount dir `shouldReturn` 1
liftIO $ stateBackupCount dir `shouldReturn` 2
liftIO $ closeMsgQueue ms q
where
journalFilesCount dir = length . filter ("messages." `isPrefixOf`) <$> listDirectory dir
stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir
testRemoveQueueStateBackups :: IO ()
testRemoveQueueStateBackups = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0}
-- set expiration time 1 second ahead
let ms = ms' {expireBackupsBefore = addUTCTime 1 $ expireBackupsBefore ms'}
let dir = msgQueueDirectory ms rId
write q s = writeMsg ms q True =<< mkMessage s
runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
liftIO $ stateBackupCount dir `shouldReturn` 0
q1 <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, True) <- write q1 "message 3"
Just (Message {}, False) <- write q1 "message 4"
liftIO $ closeMsgQueue ms q1
liftIO $ stateBackupCount dir `shouldReturn` 0
liftIO $ threadDelay 1000000
q2 <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, False) <- write q2 "message 5"
Nothing <- write q2 "message 5"
liftIO $ closeMsgQueue ms q2
liftIO $ stateBackupCount dir `shouldReturn` 1
where
stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir
testExpireIdleQueues :: IO ()
testExpireIdleQueues = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0}
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
q <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
pure q
(Just MsgQueueState {size = 0, readState = rs, writeState = ws}, True) <- readQueueState ms statePath
msgCount rs `shouldBe` 2
msgCount ws `shouldBe` 2
old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages
now <- systemSeconds <$> getSystemTime
(expired_, stored) <- runRight $ isolateQueue ms q "" $ withIdleMsgQueue now ms q $ deleteExpireMsgs_ old q
expired_ `shouldBe` Just 0
stored `shouldBe` 0
(Nothing, False) <- readQueueState ms statePath
pure ()
testReadFileMissing :: JournalMsgStore s -> IO ()
testReadFileMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let write q s = writeMsg ms q True =<< mkMessage s
q <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {}, True) <- write q "message 1"
Msg "message 1" <- tryPeekMsg ms q
pure q
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Nothing <- tryPeekMsg ms q'
Just (Message {}, True) <- write q' "message 2"
Msg "message 2" <- tryPeekMsg ms q'
pure ()
testReadFileMissingSwitch :: JournalMsgStore s -> IO ()
testReadFileMissingSwitch ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, False) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 5" <- tryPeekMsg ms q'
pure ()
testWriteFileMissing :: JournalMsgStore s -> IO ()
testWriteFileMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {writeState = ws} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws
print path
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Just Message {msgId = mId3} <- tryPeekMsg ms q'
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q' mId3
Just Message {msgId = mId4} <- tryPeekMsg ms q'
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q' mId4
Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 6" <- tryPeekMsg ms q'
pure ()
testReadAndWriteFilesMissing :: JournalMsgStore s -> IO ()
testReadAndWriteFilesMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq
closeMsgQueue ms q
removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Nothing <- tryPeekMsg ms q'
Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 6" <- tryPeekMsg ms q'
pure ()
writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s)
writeMessages ms rId qr = runRight $ do
q <- ExceptT $ addQueue ms rId qr
let write s = writeMsg ms q True =<< mkMessage s
Just (Message {msgId = mId1}, True) <- write "message 1"
Just (Message {msgId = mId2}, False) <- write "message 2"
Just (Message {}, False) <- write "message 3"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2
Just (Message {}, False) <- write "message 4"
Just (Message {}, False) <- write "message 5"
pure q
tests/CoreTests/RetryIntervalTests.hs
+34 -34
View File
@@ -29,9 +29,9 @@ testRI =
RetryInterval2
{ riSlow =
RetryInterval
{ initialInterval = 20000,
increaseAfter = 40000,
maxInterval = 40000
{ initialInterval = 100000,
increaseAfter = 200000,
maxInterval = 200000
},
riFast = testFastRI
}
@@ -39,9 +39,9 @@ testRI =
testFastRI :: RetryInterval
testFastRI =
RetryInterval
{ initialInterval = 10000,
increaseAfter = 20000,
maxInterval = 40000
{ initialInterval = 50000,
increaseAfter = 100000,
maxInterval = 200000
}
type WithRetry2 = RetryInterval2 -> (RI2State -> (RetryIntervalMode -> IO ()) -> IO ()) -> IO ()
@@ -61,15 +61,15 @@ testRetryIntervalSameMode withRetry =
when (length ints < 9) $ loop RIFast
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [ (20000, 10000),
(20000, 10000),
(20000, 15000),
(20000, 22500),
(20000, 33750),
(20000, 40000),
(20000, 40000),
(20000, 40000),
(20000, 40000)
`shouldReturn` [ (100000, 50000),
(100000, 50000),
(100000, 75000),
(100000, 112500),
(100000, 168750),
(100000, 200000),
(100000, 200000),
(100000, 200000),
(100000, 200000)
]
testRetryIntervalSwitchMode :: WithRetry2 -> Spec
@@ -84,17 +84,17 @@ testRetryIntervalSwitchMode withRetry =
when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [ (20000, 10000),
(20000, 10000),
(20000, 15000),
(20000, 22500),
(20000, 33750),
(20000, 40000),
(20000, 40000),
(30000, 40000),
(40000, 40000),
(40000, 40000),
(40000, 40000)
`shouldReturn` [ (100000, 50000),
(100000, 50000),
(100000, 75000),
(100000, 112500),
(100000, 168750),
(100000, 200000),
(100000, 200000),
(150000, 200000),
(200000, 200000),
(200000, 200000),
(200000, 200000)
]
testRetryForeground :: Spec
@@ -110,7 +110,7 @@ testRetryForeground =
when (length ints < 8) $ loop
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 200000, 200000, 200000]
testRetryToBackground :: Spec
testRetryToBackground =
@@ -121,7 +121,7 @@ testRetryToBackground =
foreground <- newTVarIO True
concurrently_
( do
threadDelay 50000
threadDelay 250000
atomically $ writeTVar foreground False
)
( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
@@ -131,7 +131,7 @@ testRetryToBackground =
)
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 200000, 200000, 200000]
testRetrySkipWhenForeground :: Spec
testRetrySkipWhenForeground =
@@ -142,11 +142,11 @@ testRetrySkipWhenForeground =
foreground <- newTVarIO False
concurrently_
( do
threadDelay 65000
threadDelay 312500
atomically $ writeTVar foreground True
threadDelay 10000
threadDelay 150000
atomically $ writeTVar foreground False
threadDelay 100000
threadDelay 381250
atomically $ writeTVar foreground True
)
( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
@@ -156,11 +156,11 @@ testRetrySkipWhenForeground =
)
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 3, 1]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 10000, 10000, 15000, 22500, 33750, 40000, 10000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 50000, 50000, 75000, 112500, 168750, 200000, 50000]
addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
addInterval intervals ts = do
ts' <- getCurrentTime
atomically $ do
int :: Int <- truncate . (* 100) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
int :: Int <- truncate . (* 20) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
stateTVar intervals $ \ints -> (int : ints, int : ints)
tests/CoreTests/StoreLogTests.hs
+9 -21
View File
@@ -28,7 +28,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Protocol.Types (ClientNotice (..))
import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Server.MsgStore.STM (STMMsgStore (..))
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
@@ -48,18 +48,6 @@ import Simplex.Messaging.Server.Main
testPublicAuthKey :: C.APublicAuthKey
testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds
testNtfCreds g = do
(notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
(k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
pure
NtfCreds
{ notifierId = EntityId "ijkl",
notifierKey,
rcvNtfDhSecret = C.dh' k pk,
ntfServiceId = Nothing
}
data StoreLogTestCase r s = SLTC {name :: String, saved :: [r], state :: s, compacted :: [r]}
type SMPStoreLogTestCase = StoreLogTestCase StoreLogRecord (M.Map RecipientId QueueRec)
@@ -177,10 +165,10 @@ testSMPStoreLog testSuite tests =
closeStoreLog l
replicateM_ 3 $ testReadWrite t
#if defined(dbServerPostgres)
(sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts
(sCnt, qCnt) <- importStoreLogToDatabase testStoreLogFile testStoreDBOpts
fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t)
imported <- B.readFile $ testStoreLogFile <> ".bak"
(sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile
(sCnt', qCnt') <- exportDatabaseToStoreLog testStoreDBOpts testStoreLogFile
sCnt' `shouldBe` fromIntegral sCnt
qCnt' `shouldBe` fromIntegral qCnt
exported <- B.readFile testStoreLogFile
@@ -188,14 +176,14 @@ testSMPStoreLog testSuite tests =
#endif
where
testReadWrite SLTC {compacted, state} = do
st <- newMsgStore $ testJournalStoreCfg MQStoreCfg
l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ stmQueueStore st
st <- newMsgStore testSMTStoreConfig
l <- readWriteQueueStore True (mkQueue st) testStoreLogFile $ queueStore st
storeState st `shouldReturn` state
closeStoreLog l
([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile
compacted' `shouldBe` compacted
storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec)
storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec))
storeState :: STMMsgStore -> IO (M.Map RecipientId QueueRec)
storeState st = M.mapMaybe id <$> (readTVarIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec))
type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
@@ -207,8 +195,8 @@ deriving instance Eq FileRecipient
deriving instance Eq FileStoreLogRecord
testFileStoreLogFile :: FilePath
testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
testFileStoreLogFile :: HasTestEnv => FilePath
testFileStoreLogFile = testPath "xftp-server-store.log"
fileExpirationTests :: Spec
fileExpirationTests =
tests/CoreTests/XFTPStoreTests.hs
+16 -16
View File
@@ -47,7 +47,7 @@ xftpMigrationTests = describe "XFTP migration round-trip" $ do
-- Test helpers
withPgStore :: (PostgresFileStore -> IO ()) -> IO ()
withPgStore :: HasTestEnv => (PostgresFileStore -> IO ()) -> IO ()
withPgStore test = do
st <- newFileStore testXFTPPostgresCfg :: IO PostgresFileStore
test st
@@ -75,7 +75,7 @@ testExpiresAt = RoundedSystemTime 2000000
-- Tests
testAddGetFileSender :: Expectation
testAddGetFileSender :: HasTestEnv => Expectation
testAddGetFileSender = withPgStore $ \st -> do
g <- C.newRandom
(sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -91,7 +91,7 @@ testAddGetFileSender = withPgStore $ \st -> do
key `shouldBe` sk
Left e -> expectationFailure $ "getFile failed: " <> show e
testAddGetFileRecipient :: Expectation
testAddGetFileRecipient :: HasTestEnv => Expectation
testAddGetFileRecipient = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -106,7 +106,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do
key `shouldBe` rcpKey
Left e -> expectationFailure $ "getFile failed: " <> show e
testDuplicateFile :: Expectation
testDuplicateFile :: HasTestEnv => Expectation
testDuplicateFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -114,12 +114,12 @@ testDuplicateFile = withPgStore $ \st -> do
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_
testGetNonexistent :: Expectation
testGetNonexistent :: HasTestEnv => Expectation
testGetNonexistent = withPgStore $ \st -> do
getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ())
getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ())
testSetFilePath :: Expectation
testSetFilePath :: HasTestEnv => Expectation
testSetFilePath = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -134,7 +134,7 @@ testSetFilePath = withPgStore $ \st -> do
Right (FileRec {filePath}, _) -> readTVarIO filePath `shouldReturn` Just "/tmp/test_file"
Left e -> expectationFailure $ "getFile failed: " <> show e
testDuplicateRecipient :: Expectation
testDuplicateRecipient :: HasTestEnv => Expectation
testDuplicateRecipient = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -144,7 +144,7 @@ testDuplicateRecipient = withPgStore $ \st -> do
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_
testDeleteFileCascade :: Expectation
testDeleteFileCascade :: HasTestEnv => Expectation
testDeleteFileCascade = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -157,7 +157,7 @@ testDeleteFileCascade = withPgStore $ \st -> do
getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ())
getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ())
testBlockFile :: Expectation
testBlockFile :: HasTestEnv => Expectation
testBlockFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -170,7 +170,7 @@ testBlockFile = withPgStore $ \st -> do
Right (FileRec {fileStatus}, _) -> readTVarIO fileStatus `shouldReturn` EntityBlocked blockInfo
Left e -> expectationFailure $ "getFile failed: " <> show e
testAckFile :: Expectation
testAckFile :: HasTestEnv => Expectation
testAckFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -186,7 +186,7 @@ testAckFile = withPgStore $ \st -> do
Right _ -> pure ()
Left e -> expectationFailure $ "getFile failed: " <> show e
testExpiredFiles :: Expectation
testExpiredFiles :: HasTestEnv => Expectation
testExpiredFiles = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -207,7 +207,7 @@ testExpiredFiles = withPgStore $ \st -> do
sz `shouldBe` 128000
_ -> expectationFailure "expected 1 expired file"
testExpiredFilesStoredExpiration :: Expectation
testExpiredFilesStoredExpiration :: HasTestEnv => Expectation
testExpiredFilesStoredExpiration = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -219,7 +219,7 @@ testExpiredFilesStoredExpiration = withPgStore $ \st -> do
expired <- expiredFiles st (RoundedSystemTime 500000) 0 100
map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
testStorageAndCount :: Expectation
testStorageAndCount :: HasTestEnv => Expectation
testStorageAndCount = withPgStore $ \st -> do
testStorageAndCountForStore st
@@ -250,10 +250,10 @@ testStorageAndCountForStore st = do
-- Migration round-trip test
testMigrationRoundTrip :: Expectation
testMigrationRoundTrip :: HasTestEnv => Expectation
testMigrationRoundTrip = do
let storeLogPath = "tests/tmp/xftp-migration-test.log"
storeLogPath2 = "tests/tmp/xftp-migration-test2.log"
let storeLogPath = testPath "xftp-migration-test.log"
storeLogPath2 = testPath "xftp-migration-test2.log"
-- 1. Create STM store with test data
stmStore <- newFileStore () :: IO STMFileStore
g <- C.newRandom
tests/FileDescriptionTests.hs
+5 -5
View File
@@ -33,8 +33,8 @@ fileDescriptionTests = do
fileDescPath :: FilePath
fileDescPath = "tests/fixtures/file_description.yaml"
tmpFileDescPath :: FilePath
tmpFileDescPath = "tests/tmp/file_description.yaml"
tmpFileDescPath :: HasTestEnv => FilePath
tmpFileDescPath = testPath "file_description.yaml"
testSbKey :: C.SbKey
testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY="
@@ -144,7 +144,7 @@ testParseYAMLFileDescription = do
yfd <- Y.decodeFileThrow fileDescPath
yfd `shouldBe` yamlFileDesc
testSerializeYAMLFileDescription :: IO ()
testSerializeYAMLFileDescription :: HasTestEnv => IO ()
testSerializeYAMLFileDescription = withRemoveTmpFile $ do
Y.encodeFile tmpFileDescPath yamlFileDesc
fdSer <- B.readFile tmpFileDescPath
@@ -158,7 +158,7 @@ testParseFileDescription = do
Left e -> expectationFailure $ show e
Right fd -> fd `shouldBe` fileDesc
testSerializeFileDescription :: IO ()
testSerializeFileDescription :: HasTestEnv => IO ()
testSerializeFileDescription = withRemoveTmpFile $ do
B.writeFile tmpFileDescPath $ strEncode fileDesc
fdSer <- B.readFile tmpFileDescPath
@@ -177,7 +177,7 @@ testFileDescriptionURIExtras = do
let descr = FileDescriptionURI SSSimplex vfd $ Just "{\"something\":\"extra\",\"more\":true}"
strDecode (strEncode descr) `shouldBe` Right descr
withRemoveTmpFile :: IO () -> IO ()
withRemoveTmpFile :: HasTestEnv => IO () -> IO ()
withRemoveTmpFile =
bracket_
(pure ())
tests/NamesResolverServer.hs
+7 -3
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
@@ -30,6 +31,7 @@ import SMPClient (AServerConfig (..), cfgMS, proxyCfgMS, testStoreLogFile2, test
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.Names (NamesConfig (..))
import Util (HasTestEnv)
-- | Run an action with a local HTTP resolver on a free port.
withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
@@ -64,20 +66,22 @@ testNamesConfig port =
resolverMaxResponseBytes = 65536
}
memCfg :: AServerConfig
memCfg :: HasTestEnv => AServerConfig
memCfg = cfgMS (ASType SQSMemory SMSMemory)
memProxyCfg :: AServerConfig
memProxyCfg :: HasTestEnv => AServerConfig
memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
memCfg2 :: AServerConfig
memCfg2 :: HasTestEnv => AServerConfig
memCfg2 = case memCfg of
ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)}
where
newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s
newStoreCfg = \case
SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2})
#if defined(dbServerPostgres)
other -> other
#endif
withNames :: Int -> AServerConfig -> AServerConfig
withNames port c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just (testNamesConfig port)}
tests/NtfClient.hs
+31 -27
View File
@@ -60,30 +60,31 @@ import UnliftIO.Async
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import Util
testHost :: NonEmpty TransportHost
testHost = "localhost"
apnsTestPort :: ServiceName
apnsTestPort = "6010"
apnsTestPort :: HasTestEnv => ServiceName
apnsTestPort = testServerPort 5
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
ntfTestStoreLogFile :: FilePath
ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
ntfTestStoreLogFile :: HasTestEnv => FilePath
ntfTestStoreLogFile = testPath "ntf-server-store.log"
ntfTestStoreLogFile2 :: FilePath
ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2"
ntfTestStoreLogFile2 :: HasTestEnv => FilePath
ntfTestStoreLogFile2 = testPath "ntf-server-store.log.2"
ntfTestStoreLastNtfsFile :: FilePath
ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log"
ntfTestStoreLastNtfsFile :: HasTestEnv => FilePath
ntfTestStoreLastNtfsFile = testPath "ntf-server-last-notifications.log"
ntfTestPrometheusMetricsFile :: FilePath
ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt"
ntfTestPrometheusMetricsFile :: HasTestEnv => FilePath
ntfTestPrometheusMetricsFile = testPath "ntf-server-metrics.txt"
ntfTestStoreDBOpts :: DBOpts
ntfTestStoreDBOpts =
ntfTestServerDBOpts :: DBOpts
ntfTestServerDBOpts =
DBOpts
{ connstr = ntfTestServerDBConnstr,
schema = "ntf_server",
@@ -91,8 +92,11 @@ ntfTestStoreDBOpts =
createSchema = True
}
ntfTestStoreDBOpts2 :: DBOpts
ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = "smp_server2"}
ntfTestStoreDBOpts :: HasTestEnv => DBOpts
ntfTestStoreDBOpts = ntfTestServerDBOpts {schema = testSchemaName "ntf_server"}
ntfTestStoreDBOpts2 :: HasTestEnv => DBOpts
ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = testSchemaName "smp_server2"}
ntfTestServerDBConnstr :: ByteString
ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db"
@@ -104,7 +108,7 @@ ntfTestServerDBConnectInfo =
connectDatabase = "ntf_test_server_db"
}
ntfTestDBCfg :: PostgresStoreCfg
ntfTestDBCfg :: HasTestEnv => PostgresStoreCfg
ntfTestDBCfg =
PostgresStoreCfg
{ dbOpts = ntfTestStoreDBOpts,
@@ -113,10 +117,10 @@ ntfTestDBCfg =
deletedTTL = 86400
}
ntfTestDBCfg2 :: PostgresStoreCfg
ntfTestDBCfg2 :: HasTestEnv => PostgresStoreCfg
ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2}
testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
testNtfClient :: (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a
testNtfClient client = do
Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
@@ -124,7 +128,7 @@ testNtfClient client = do
Right th -> client th
Left e -> error $ show e
ntfServerCfg :: NtfServerConfig
ntfServerCfg :: HasTestEnv => NtfServerConfig
ntfServerCfg =
NtfServerConfig
{ transports = [],
@@ -151,7 +155,7 @@ ntfServerCfg =
-- stats config
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsLogFile = testPath "ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = ntfTestPrometheusMetricsFile,
@@ -171,7 +175,7 @@ ntfServerCfg =
-- smpCfg' = smpCfg smpAgentCfg'
-- serverVRange' = serverVRange smpCfg'
withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn t port' dbStoreConfig =
withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
@@ -184,18 +188,18 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
(\started -> runNtfServerBlocking started cfg)
(pure ())
withNtfServerOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const
withNtfServer :: HasCallStack => ASrvTransport -> (HasCallStack => IO a) -> IO a
withNtfServer :: (HasCallStack, HasTestEnv) => ASrvTransport -> (HasCallStack => IO a) -> IO a
withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg
runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
runNtfTest :: forall c a. (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
(HasTestEnv, Transport c, Encoding smp) =>
TProxy c 'TServer ->
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
IO (Maybe TAuthorizations, ByteString, ByteString, NtfResponse)
@@ -210,7 +214,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
[(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h
pure (Nothing, corrId, qId, cmd)
ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
data APNSMockRequest = APNSMockRequest
@@ -225,7 +229,7 @@ data APNSMockServer = APNSMockServer
http2Server :: HTTP2Server
}
apnsMockServerConfig :: HTTP2ServerConfig
apnsMockServerConfig :: HasTestEnv => HTTP2ServerConfig
apnsMockServerConfig =
HTTP2ServerConfig
{ qSize = 2,
@@ -242,7 +246,7 @@ apnsMockServerConfig =
transportConfig = mkTransportServerConfig True Nothing False
}
withAPNSMockServer :: (APNSMockServer -> IO a) -> IO a
withAPNSMockServer :: HasTestEnv => (APNSMockServer -> IO a) -> IO a
withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
deriving instance Generic APNSAlertBody
tests/NtfServerTests.hs
+13 -13
View File
@@ -69,13 +69,13 @@ ntfSyntaxTests (ATransport t) = do
it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", NRErr $ CMD HAS_AUTH)
where
(>#>) ::
Encoding smp =>
(HasTestEnv, Encoding smp) =>
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
(Maybe TAuthorizations, ByteString, ByteString, NtfResponse) ->
Expectation
command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
testApnsTestProviderRejected :: ASrvTransport -> Expectation
testApnsTestProviderRejected :: HasTestEnv => ASrvTransport -> Expectation
testApnsTestProviderRejected (ATransport (t :: TProxy c 'TServer)) = do
g <- C.newRandom
(tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -136,7 +136,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
let dhSecret = C.dh' ntfDh dhPriv
decryptCode nd =
let Right verification = nd .-> "verification"
Right nonce = C.cbNonce <$> nd .-> "nonce"
Right nonce = C.cbNonce =<< nd .-> "nonce"
Right pt = C.cbDecrypt dhSecret nonce verification
in NtfRegCode pt
let code = decryptCode ntfData
@@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
-- receive notification
APNSMockRequest {notification} <- getMockNotification apns tkn
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification
Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
Right nonce' = C.cbNonce =<< ntfData' .-> "nonce"
Right message = ntfData' .-> "message"
Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
@@ -171,7 +171,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
notifierId `shouldBe` nId
-- receive message
Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId1 body)
mId1 `shouldBe` msgId
mTs `shouldBe` msgTs
(msgBody, "hello") #== "delivered from queue"
@@ -183,7 +183,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <-
getMockNotification apns tkn'
let Right verification2 = ntfData2 .-> "verification"
Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce"
Right nonce2 = C.cbNonce =<< ntfData2 .-> "nonce"
Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2
RespNtf "8" _ NROk <- signSendRecvNtf nh tknKey ("8", tId, TVFY code2)
RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK)
@@ -191,7 +191,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2")
APNSMockRequest {notification = notification3} <- getMockNotification apns tkn'
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3
Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
Right nonce3 = C.cbNonce =<< ntfData3 .-> "nonce"
Right message3 = ntfData3 .-> "message"
Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
@@ -199,7 +199,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
smpServer3 `shouldBe` srv
notifierId3 `shouldBe` nId
Resp "" _ (MSG RcvMessage {msgId = mId2, msgBody = EncRcvMsgBody body2}) <- tGet1 rh
Right ClientRcvMsgBody {msgBody = "hello 2"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId2) body2)
Right ClientRcvMsgBody {msgBody = "hello 2"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId2 body2)
Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId2)
q2 <- createQueue rh sPub nPub
@@ -218,7 +218,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
Resp "14" _ OK <- signSendRecv sh sKey ("14", sId, _SEND' "hello 3")
APNSMockRequest {notification = notification4} <- getMockNotification apns tkn'
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData4} = notification4
Right nonce4 = C.cbNonce <$> ntfData4 .-> "nonce"
Right nonce4 = C.cbNonce =<< ntfData4 .-> "nonce"
Right message4 = ntfData4 .-> "message"
Right ntfDataDecrypted4 = C.cbDecrypt dhSecret nonce4 message4
Right pnMsgs4 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted4
@@ -226,14 +226,14 @@ testNotificationSubscription (ATransport t, msType) createQueue =
smpServer4 `shouldBe` srv
notifierId4 `shouldBe` nId
Resp "" _ (MSG RcvMessage {msgId = mId3, msgBody = EncRcvMsgBody body3}) <- tGet1 rh
Right ClientRcvMsgBody {msgBody = "hello 3"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId3) body3)
Right ClientRcvMsgBody {msgBody = "hello 3"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret mId3 body3)
Resp "15" _ OK <- signSendRecv rh rKey ("15", rId, ACK mId3)
-- deliver to queue with ntf sub created while SMP was offline
Resp "16" _ OK <- signSendRecv sh sKey ("16", sId', _SEND' "hello 4")
APNSMockRequest {notification = notification5} <- getMockNotification apns tkn'
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData5} = notification5
Right nonce5 = C.cbNonce <$> ntfData5 .-> "nonce"
Right nonce5 = C.cbNonce =<< ntfData5 .-> "nonce"
Right message5 = ntfData5 .-> "message"
Right ntfDataDecrypted5 = C.cbDecrypt dhSecret nonce5 message5
Right pnMsgs5 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted5
@@ -241,7 +241,7 @@ testNotificationSubscription (ATransport t, msType) createQueue =
smpServer5 `shouldBe` srv
notifierId5 `shouldBe` nId'
Resp "" _ (MSG RcvMessage {msgId = mId4, msgBody = EncRcvMsgBody body4}) <- tGet1 rh
Right ClientRcvMsgBody {msgBody = "hello 4"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret' (C.cbNonce mId4) body4)
Right ClientRcvMsgBody {msgBody = "hello 4"} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret' mId4 body4)
Resp "17" _ OK <- signSendRecv rh rKey' ("17", rId', ACK mId4)
pure ()
@@ -307,7 +307,7 @@ registerToken nh apns token = do
let dhSecret = C.dh' ntfDh dhPriv
decryptCode nd =
let Right verification = nd .-> "verification"
Right nonce = C.cbNonce <$> nd .-> "nonce"
Right nonce = C.cbNonce =<< nd .-> "nonce"
Right pt = C.cbDecrypt dhSecret nonce verification
in NtfRegCode pt
let code = decryptCode ntfData
tests/PostgresSchemaDump.hs
+5 -4
View File
@@ -15,6 +15,7 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
import Simplex.Messaging.Util (ifM, whenM)
import System.Directory (doesFileExist, removeFile)
import System.Info (os)
import System.Process (readCreateProcess, shell)
import Test.Hspec hiding (fit, it)
import Util
@@ -57,14 +58,14 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
getSchema :: FilePath -> IO String
getSchema schemaPath = do
ci <- envCI
let cmd =
("pg_dump " <> B.unpack connstr <> " --schema " <> B.unpack testDBSchema)
<> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > "
<> schemaPath
void $ readCreateProcess (shell cmd) ""
threadDelay 20000
let sed = (if ci then "sed -i" else "sed -i ''")
let sed = (if os == "linux" then "sed -i" else "sed -i ''")
void $ readCreateProcess (shell $ sed <> " '/^--/d; /^\\\\restrict/d; /^\\\\unrestrict/d' " <> schemaPath) ""
sch <- readFile schemaPath
sch `deepseq` pure sch
sch <- unlines . dropWhileEnd null . dropWhile null . lines <$> readFile schemaPath
sch `deepseq` writeFile schemaPath sch
pure sch
tests/RSLVTests.hs
+109 -22
View File
@@ -11,11 +11,14 @@
module RSLVTests (rslvTests) where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.IORef (IORef, readIORef)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (getCurrentTime)
@@ -47,26 +50,27 @@ import Simplex.Messaging.Protocol
tPut,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.SimplexName (SimplexDomain)
import Simplex.Messaging.Transport
import Simplex.Messaging.Version (mkVersionRange)
import Test.Hspec hiding (fit, it)
import Util (it)
import Util (HasTestEnv, it)
domain :: Text -> SimplexDomain
domain = either error id . strDecode . encodeUtf8
withResolverServer :: (Status, LB.ByteString) -> IO a -> IO a
withResolverServer :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a
withResolverServer (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const runTest)
withResolverServerReqs :: (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a
withResolverServerReqs :: HasTestEnv => (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a
withResolverServerReqs (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const (runTest reqs))
withProxyAndResolver :: (Status, LB.ByteString) -> IO a -> IO a
withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a
withProxyAndResolver (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
@@ -102,10 +106,14 @@ rslvTests = do
it "RSLV sends the 2LD as its hash" testRslvSendsTheHash
it "a name with subnames is sent as text" testSubnameKeepsItsLabels
it "a record naming a different name is rejected" testRslvWrongName
describe "RSLV resource use" $ do
it "one connection has at most client_concurrency lookups in flight" testRslvConnectionCap
it "a lookup waiting for a slot runs when a slot is released" testRslvSlotWait
it "a lookup waiting for a slot fails when the client times out" testRslvSlotWaitTimeout
-- | /v2/resolve answers 200, 400 or 502, so a 404 is a resolver that predates
-- the route, not a name that does not exist.
testRslvBackendNotFound :: IO ()
testRslvBackendNotFound :: HasTestEnv => IO ()
testRslvBackendNotFound =
withResolverServer (status404, "{}") $
testSMPClient @TLS $ \h -> do
@@ -113,21 +121,21 @@ testRslvBackendNotFound =
corrId `shouldBe` CorrId "rs01"
resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 404")))
testRslvBackendHttpErr :: IO ()
testRslvBackendHttpErr :: HasTestEnv => IO ()
testRslvBackendHttpErr =
withResolverServer (status502, "{}") $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs05" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 502")))
testRslvDisabled :: IO ()
testRslvDisabled :: HasTestEnv => IO ()
testRslvDisabled =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs06" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME NO_RESOLVER))
testRslvVersion :: IO ()
testRslvVersion :: HasTestEnv => IO ()
testRslvVersion =
withResolverServer (status200, registeredBody testNameRecord) $ do
g <- C.newRandom
@@ -141,7 +149,7 @@ testRslvVersion =
Left (PCETransportError TEVersion) -> pure ()
_ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r
forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
forwardedResolveAlice :: HasTestEnv => IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
forwardedResolveAlice = do
g <- C.newRandom
ts <- getCurrentTime
@@ -153,21 +161,21 @@ forwardedResolveAlice = do
sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing)
runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex"))
testRslvForwarded :: IO ()
testRslvForwarded :: HasTestEnv => IO ()
testRslvForwarded =
withProxyAndResolver (status404, "{}") $
forwardedResolveAlice >>= \r -> case r of
Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME (RESOLVER _))), got: " <> show r
testRslvForwardedSuccess :: IO ()
testRslvForwardedSuccess :: HasTestEnv => IO ()
testRslvForwardedSuccess =
withProxyAndResolver (status200, registeredBody testNameRecord) $
forwardedResolveAlice >>= \r -> case r of
Right (Right NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right (Right NRRegistered), got: " <> show r
testRslvSuccess :: IO ()
testRslvSuccess :: HasTestEnv => IO ()
testRslvSuccess =
withResolverServer (status200, registeredBody testNameRecord) $
testSMPClient @TLS $ \h -> do
@@ -177,7 +185,7 @@ testRslvSuccess =
Right (RNAME NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right (RNAME NRRegistered), got: " <> show resp
testRslvAvailable :: IO ()
testRslvAvailable :: HasTestEnv => IO ()
testRslvAvailable =
withResolverServer (status200, availableBody) $
testSMPClient @TLS $ \h -> do
@@ -185,7 +193,7 @@ testRslvAvailable =
corrId `shouldBe` CorrId "na01"
resp `shouldBe` Right (RNAME (resolved (NRAvailable testPricing)))
testRslvReserved :: IO ()
testRslvReserved :: HasTestEnv => IO ()
testRslvReserved =
withResolverServer (status200, reservedBody) $
testSMPClient @TLS $ \h -> do
@@ -194,7 +202,7 @@ testRslvReserved =
-- | A client that predates v22 must see exactly what it saw before: the record
-- for a name that resolves, and NOT_FOUND for one that does not.
oldClient :: IO SMPClient
oldClient :: HasTestEnv => IO SMPClient
oldClient = do
g <- C.newRandom
ts <- getCurrentTime
@@ -205,14 +213,14 @@ oldClient = do
pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) oldCfg [] Nothing ts (\_ -> pure ())
either (fail . show) pure pcE
testRslvOldClientRecord :: IO ()
testRslvOldClientRecord :: HasTestEnv => IO ()
testRslvOldClientRecord =
withResolverServer (status200, registeredBody testNameRecord) $ do
pc <- oldClient
r <- runExceptT' (directResolveName pc NRMInteractive (domain "alice.simplex"))
r `shouldBe` NameResponse Nothing (NRRegistered Nothing Nothing Nothing testNameRecord)
testRslvOldClientNotFound :: IO ()
testRslvOldClientNotFound :: HasTestEnv => IO ()
testRslvOldClientNotFound =
withResolverServer (status200, availableBody) $ do
pc <- oldClient
@@ -221,7 +229,7 @@ testRslvOldClientNotFound =
Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
testRslvForwardedAvailable :: IO ()
testRslvForwardedAvailable :: HasTestEnv => IO ()
testRslvForwardedAvailable =
withProxyAndResolver (status200, availableBody) $
forwardedResolveAlice >>= \r -> case r of
@@ -238,7 +246,7 @@ resolvePaths reqs = filter isResolve <$> readIORef reqs
where
isResolve = \case ("v2" : "resolve" : _) -> True; _ -> False
currentClient :: IO SMPClient
currentClient :: HasTestEnv => IO SMPClient
currentClient = do
g <- C.newRandom
ts <- getCurrentTime
@@ -246,7 +254,7 @@ currentClient = do
pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
either (fail . show) pure pcE
testRslvSendsTheHash :: IO ()
testRslvSendsTheHash :: HasTestEnv => IO ()
testRslvSendsTheHash =
withResolverServerReqs (status200, registeredBody testNameRecord) $ \reqs -> do
pc <- currentClient
@@ -257,7 +265,7 @@ testRslvSendsTheHash =
NameResponse {registration = NRRegistered {nameRecord}} -> SMP.nrName nameRecord `shouldBe` "alice.simplex"
_ -> expectationFailure $ "expected NRRegistered, got: " <> show r
testSubnameKeepsItsLabels :: IO ()
testSubnameKeepsItsLabels :: HasTestEnv => IO ()
testSubnameKeepsItsLabels =
withResolverServerReqs (status200, availableBody) $ \reqs -> do
pc <- currentClient
@@ -266,7 +274,7 @@ testSubnameKeepsItsLabels =
-- a hashed query does not tell the router the name, so the record's own name is
-- checked against the one that was asked for
testRslvWrongName :: IO ()
testRslvWrongName :: HasTestEnv => IO ()
testRslvWrongName =
withResolverServer (status200, registeredBody testNameRecord {SMP.nrName = "mallory.simplex"}) $ do
pc <- currentClient
@@ -275,5 +283,84 @@ testRslvWrongName =
Left (PCEUnexpectedResponse _) -> pure ()
_ -> expectationFailure $ "expected Left (PCEUnexpectedResponse ..), got: " <> show r
-- The resolver answers after 3s and the server gives up after 1s, so a request
-- that reached the resolver stays in flight for the whole check.
testRslvConnectionCap :: HasTestEnv => IO ()
testRslvConnectionCap =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (updateCfg (withNames port memCfg) $ \c -> c {serverClientConcurrency = connCap}) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "cap" 16
threadDelay 800000
length <$> resolvePaths reqs `shouldReturn` connCap
recvResponses h 16 `shouldReturn` replicate 16 (Right (ERR (NAME (RESOLVER "timeout"))))
where
connCap = 4
-- 4 lookups take the slots for the 1s resolver timeout, the 5th waits for a slot.
testRslvSlotWait :: HasTestEnv => IO ()
testRslvSlotWait =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (slotWaitCfg port 10000000) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "wait" 5
recvResponses h 5 `shouldReturn` replicate 5 (Right (ERR (NAME (RESOLVER "timeout"))))
length <$> resolvePaths reqs `shouldReturn` 5
threadDelay 1500000
SlotWaitMetrics {waits, waitTimeouts, waitMaxMs, waitSumMs} <- readSlotWaitMetrics
(waits, waitTimeouts) `shouldBe` (1, 0)
waitMaxMs `shouldSatisfy` (\t -> t >= 500 && t < 2000)
waitSumMs `shouldBe` waitMaxMs
-- The client times out after 0.2s, so the 2 waiting lookups fail before the slots are released.
-- The connection does not process further commands while one waits, so the 6th waits after the 5th times out.
testRslvSlotWaitTimeout :: HasTestEnv => IO ()
testRslvSlotWaitTimeout =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (slotWaitCfg port 200000) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "wait" 6
recvResponses h 6 `shouldReturn` (replicate 2 (Right (ERR (NAME (RESOLVER "too many requests")))) <> replicate 4 (Right (ERR (NAME (RESOLVER "timeout")))))
threadDelay 1500000
length <$> resolvePaths reqs `shouldReturn` 4
SlotWaitMetrics {waits, waitTimeouts, waitMaxMs, waitSumMs} <- readSlotWaitMetrics
(waits, waitTimeouts) `shouldBe` (2, 2)
waitMaxMs `shouldSatisfy` (\t -> t >= 200 && t < 1000)
waitSumMs `shouldSatisfy` (>= 400)
slotWaitCfg :: HasTestEnv => Int -> Int -> AServerConfig
slotWaitCfg port clientTimeout =
updateCfg (withNames port memCfg) $ \c -> c {serverClientConcurrency = 4, prometheusInterval = Just 1, maxClientCmdWait = clientTimeout}
data SlotWaitMetrics = SlotWaitMetrics {waits :: Int, waitTimeouts :: Int, waitMaxMs :: Int, waitSumMs :: Int}
readSlotWaitMetrics :: HasTestEnv => IO SlotWaitMetrics
readSlotWaitMetrics = do
ms <- map words . lines <$> readFile testPrometheusMetricsFile
-- metric lines are "name value timestamp"
let metric name = case [v | n : v : _ <- ms, n == name] of
[v] -> pure $ read v
_ -> fail $ "no metric " <> name
SlotWaitMetrics
<$> metric "simplex_smp_cmd_slot_wait_ms_count"
<*> metric "simplex_smp_cmd_slot_wait_timeouts"
<*> metric "simplex_smp_cmd_slot_wait_ms_max"
<*> metric "simplex_smp_cmd_slot_wait_ms_sum"
-- | One RSLV per block, so no batch limit applies.
sendRslvs :: THandleSMP TLS 'TClient -> String -> Int -> IO ()
sendRslvs h@THandle {params} prefix n =
forM_ [1 .. n] $ \i -> do
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId (B.pack $ prefix <> show i), NoEntity, Cmd SResolver (RSLV (NQDomain (domain "alice.simplex"))))
[Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
pure ()
recvResponses :: THandleSMP TLS 'TClient -> Int -> IO [Either ErrorType BrokerMsg]
recvResponses h n
| n <= 0 = pure []
| otherwise = do
rs <- map (\(_, _, r) -> r) . L.toList <$> tGetClient h
(rs <>) <$> recvResponses h (n - length rs)
runExceptT' :: Show e => ExceptT e IO a -> IO a
runExceptT' a = runExceptT a >>= either (fail . show) pure
tests/SMPAgentClient.hs
+32 -30
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -15,79 +16,80 @@ 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 SMPClient (ntfTestPort, testPort)
import SMPClient (ntfTestPort, ntfTestPort2, testHost, testHost2, testKeyHash, testPort, testPort2)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer, pattern NtfServer)
import Simplex.Messaging.Transport
import Util
import XFTPClient (testXFTPServer)
-- name fixtures are reused, but they are used as schema name instead of database file path
#if defined(dbPostgres)
testDB :: String
testDB = "smp_agent_test_protocol_schema"
testDB :: HasTestEnv => String
testDB = testSchemaName "smp_agent_test_protocol_schema"
testDB2 :: String
testDB2 = "smp_agent2_test_protocol_schema"
testDB2 :: HasTestEnv => String
testDB2 = testSchemaName "smp_agent2_test_protocol_schema"
testDB3 :: String
testDB3 = "smp_agent3_test_protocol_schema"
testDB3 :: HasTestEnv => String
testDB3 = testSchemaName "smp_agent3_test_protocol_schema"
#else
testDB :: FilePath
testDB = "tests/tmp/smp-agent.test.protocol.db"
testDB :: HasTestEnv => FilePath
testDB = testPath "smp-agent.test.protocol.db"
testDB2 :: FilePath
testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
testDB2 :: HasTestEnv => FilePath
testDB2 = testPath "smp-agent2.test.protocol.db"
testDB3 :: FilePath
testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
testDB3 :: HasTestEnv => FilePath
testDB3 = testPath "smp-agent3.test.protocol.db"
#endif
testSMPServer :: SMPServer
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
testSMPServer :: HasTestEnv => SMPServer
testSMPServer = SMPServer testHost testPort testKeyHash
testSMPServer2 :: SMPServer
testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5002"
testSMPServer2 :: HasTestEnv => SMPServer
testSMPServer2 = SMPServer testHost2 testPort2 testKeyHash
testNtfServer :: NtfServer
testNtfServer = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"
testNtfServer :: HasTestEnv => NtfServer
testNtfServer = NtfServer testHost ntfTestPort testKeyHash
testNtfServer2 :: NtfServer
testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6002"
testNtfServer2 :: HasTestEnv => NtfServer
testNtfServer2 = NtfServer testHost ntfTestPort2 testKeyHash
initAgentServers :: InitialAgentServers
initAgentServers :: HasTestEnv => InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = userServers [testSMPServer],
ntf = [testNtfServer],
xftp = userServers [testXFTPServer],
entitlements = M.empty,
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 2000000 2000000, tcpConnectTimeout = NetworkTimeout 2000000 2000000},
useServices = M.empty,
presetDomains = [],
presetServers = []
}
initAgentServers2 :: InitialAgentServers
initAgentServers2 :: HasTestEnv => InitialAgentServers
initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]}
initAgentServersProxy :: InitialAgentServers
initAgentServersProxy :: HasTestEnv => InitialAgentServers
initAgentServersProxy = initAgentServersProxy_ SPMAlways SPFProhibit
initAgentServersProxy_ :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy_ :: HasTestEnv => SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy_ smpProxyMode smpProxyFallback =
initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}}
initAgentServersProxy2 :: InitialAgentServers
initAgentServersProxy2 :: HasTestEnv => InitialAgentServers
initAgentServersProxy2 = initAgentServersProxy {smp = userServers [testSMPServer2]}
initAgentServersClientService :: InitialAgentServers
initAgentServersClientService :: HasTestEnv => InitialAgentServers
initAgentServersClientService = initAgentServers {useServices = M.fromList [(1, True)]}
agentCfg :: AgentConfig
agentCfg :: HasTestEnv => AgentConfig
agentCfg =
defaultAgentConfig
{ tcpPort = Nothing,
tests/SMPClient.hs
+129 -114
View File
@@ -33,7 +33,6 @@ import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.Server
@@ -45,12 +44,13 @@ import System.Info (os)
import Test.Hspec hiding (fit, it)
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar)
import UnliftIO.STM (TMVar, atomically, checkSTM, newEmptyTMVarIO, orElse, putTMVar, readTMVar, readTVar, registerDelay, takeTMVar)
import UnliftIO.Timeout (timeout)
import Util
#if defined(dbServerPostgres)
import Database.PostgreSQL.Simple (defaultConnectInfo)
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
#endif
#if defined(dbPostgres) || defined(dbServerPostgres)
@@ -72,29 +72,29 @@ testHost = "localhost"
testHost2 :: NonEmpty TransportHost
testHost2 = "127.0.0.1"
testPort :: ServiceName
testPort = "5001"
testPort :: HasTestEnv => ServiceName
testPort = testServerPort 1
testPort2 :: ServiceName
testPort2 = "5002"
testPort2 :: HasTestEnv => ServiceName
testPort2 = testServerPort 2
ntfTestPort :: ServiceName
ntfTestPort = "6001"
ntfTestPort :: HasTestEnv => ServiceName
ntfTestPort = testServerPort 3
ntfTestPort2 :: ServiceName
ntfTestPort2 = "6002"
ntfTestPort2 :: HasTestEnv => ServiceName
ntfTestPort2 = testServerPort 4
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
testStoreLogFile :: FilePath
testStoreLogFile = "tests/tmp/smp-server-store.log"
testStoreLogFile :: HasTestEnv => FilePath
testStoreLogFile = testPath "smp-server-store.log"
testStoreLogFile2 :: FilePath
testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
testStoreLogFile2 :: HasTestEnv => FilePath
testStoreLogFile2 = testPath "smp-server-store.log.2"
testStoreDBOpts :: DBOpts
testStoreDBOpts =
testServerDBOpts :: DBOpts
testServerDBOpts =
DBOpts
{ connstr = testServerDBConnstr,
schema = "smp_server",
@@ -102,8 +102,11 @@ testStoreDBOpts =
createSchema = True
}
testStoreDBOpts2 :: DBOpts
testStoreDBOpts2 = testStoreDBOpts {schema = "smp_server2"}
testStoreDBOpts :: HasTestEnv => DBOpts
testStoreDBOpts = testServerDBOpts {schema = testSchemaName "smp_server"}
testStoreDBOpts2 :: HasTestEnv => DBOpts
testStoreDBOpts2 = testStoreDBOpts {schema = testSchemaName "smp_server2"}
testServerDBConnstr :: ByteString
testServerDBConnstr = "postgresql://test_server_user@/test_server_db"
@@ -117,48 +120,42 @@ testServerDBConnectInfo =
}
#endif
testStoreMsgsFile :: FilePath
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
testStoreMsgsFile :: HasTestEnv => FilePath
testStoreMsgsFile = testPath "smp-server-messages.log"
testStoreMsgsFile2 :: FilePath
testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2"
testStoreMsgsFile2 :: HasTestEnv => FilePath
testStoreMsgsFile2 = testPath "smp-server-messages.log.2"
testStoreMsgsDir :: FilePath
testStoreMsgsDir = "tests/tmp/messages"
testStoreNtfsFile :: HasTestEnv => FilePath
testStoreNtfsFile = testPath "smp-server-ntfs.log"
testStoreMsgsDir2 :: FilePath
testStoreMsgsDir2 = "tests/tmp/messages.2"
testStoreNtfsFile2 :: HasTestEnv => FilePath
testStoreNtfsFile2 = testPath "smp-server-ntfs.log.2"
testStoreNtfsFile :: FilePath
testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log"
testPrometheusMetricsFile :: HasTestEnv => FilePath
testPrometheusMetricsFile = testPath "smp-server-metrics.txt"
testStoreNtfsFile2 :: FilePath
testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2"
testServerStatsBackupFile :: HasTestEnv => FilePath
testServerStatsBackupFile = testPath "smp-server-stats.log"
testPrometheusMetricsFile :: FilePath
testPrometheusMetricsFile = "tests/tmp/smp-server-metrics.txt"
xit' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit' d t = if os == "linux" then skip "skipped on Linux" $ it d t else it d t
testServerStatsBackupFile :: FilePath
testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit' d = if os == "linux" then skip "skipped on Linux" . it d else it d
xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit'' d = skipOnCI . it d
xit'' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit'' d t = skipOnCI $ it d t
skipOnCI :: SpecWith a -> SpecWith a
skipOnCI t = ifM (runIO envCI) (skip "skipped on CI" t) t
testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient :: (HasTestEnv, Transport c) => (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR :: (HasTestEnv, Transport c) => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR vr client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort vr Nothing client
testSMPServiceClient :: Transport c => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPServiceClient :: (HasTestEnv, Transport c) => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPServiceClient serviceCreds client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort supportedClientSMPRelayVRange (Just serviceCreds) client
@@ -181,13 +178,13 @@ testSMPClient_ host port vr serviceCreds_ client = do
where
clientALPN = Just alpnSupportedSMPHandshakes
runSMPClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPClient _ test' = testSMPClient test'
runSMPServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test'
testNtfServiceClient :: Transport c => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a
testNtfServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a
testNtfServiceClient _ keys client = do
tlsNtfServerCreds <- loadServerCredential ntfTestServerCredentials
serviceCertHash <- loadFingerprint ntfTestServerCredentials
@@ -211,35 +208,44 @@ ntfTestServerCredentials =
certificateFile = "tests/fixtures/server.crt"
}
cfg :: AServerConfig
cfg = cfgMS (ASType SQSMemory SMSJournal)
cfg :: HasTestEnv => AServerConfig
cfg = cfgMS (ASType SQSMemory SMSMemory)
cfgJ2 :: AServerConfig
cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2
cfgS2 :: HasTestEnv => AServerConfig
cfgS2 = memoryCfg cfg testStoreLogFile2 testStoreMsgsFile2
cfgJ2QS :: SQSType s -> AServerConfig
cfgJ2QS = \case
SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2
cfgS2QS :: HasTestEnv => SQSType s -> AServerConfig
cfgS2QS = \case
SQSMemory -> memoryCfg (cfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg (cfgMS postgresStoreType) testStoreDBOpts2
journalCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig
journalCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsPath =
ASrvCfg SQSMemory SMSJournal cfg' {serverStoreCfg = SSCMemoryJournal {storeLogFile, storeMsgsPath}}
memoryCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig
memoryCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsFile =
ASrvCfg SQSMemory SMSMemory cfg' {serverStoreCfg = SSCMemory $ Just StorePaths {storeLogFile, storeMsgsFile = Just storeMsgsFile}}
journalCfgDB :: AServerConfig -> DBOpts -> FilePath -> AServerConfig
journalCfgDB (ASrvCfg _ _ cfg') dbOpts storeMsgsPath' =
databaseCfg :: AServerConfig -> DBOpts -> AServerConfig
#if defined(dbServerPostgres)
databaseCfg (ASrvCfg _ _ cfg') dbOpts =
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400}
in ASrvCfg SQSPostgres SMSJournal cfg' {serverStoreCfg = SSCDatabaseJournal {storeCfg, storeMsgsPath'}}
in ASrvCfg SQSPostgres SMSPostgres cfg' {serverStoreCfg = SSCDatabase storeCfg}
#else
databaseCfg _ _ = error "no dbServerPostgres flag"
#endif
cfgMS :: AStoreType -> AServerConfig
postgresStoreType :: AStoreType
#if defined(dbServerPostgres)
postgresStoreType = ASType SQSPostgres SMSPostgres
#else
postgresStoreType = error "no dbServerPostgres flag"
#endif
cfgMS :: HasTestEnv => AStoreType -> AServerConfig
cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
ServerConfig
{ transports = [],
smpHandshakeTimeout = 60000000,
tbqSize = 4,
msgQueueQuota = 4,
maxJournalMsgCount = 5,
maxJournalStateLines = 2,
queueIdBytes = 24,
msgIdBytes = 24,
serverStoreCfg,
@@ -252,17 +258,17 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
messageExpiration = Just defaultMessageExpiration,
expireMessagesOnStart = True,
expireMessagesOnSend = False,
idleQueueInterval = defaultIdleQueueInterval,
notificationExpiration = defaultNtfExpiration,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/smp-server-stats.daily.log",
serverStatsLogFile = testPath "smp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = testPrometheusMetricsFile,
pendingENDInterval = 500000,
ntfDeliveryInterval = 200000,
authErrorDelay = 20000,
smpCredentials =
ServerCredentials
{ caCertificateFile = Just "tests/fixtures/ca.crt",
@@ -277,6 +283,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
allowSMPProxy = False,
serverClientConcurrency = 2,
serverResolverConcurrency = defaultNameResolverConcurrency,
maxClientCmdWait = defaultMaxClientCmdWait,
namesConfig = Nothing,
information = Nothing,
startOptions = defaultStartOptions
@@ -288,26 +295,28 @@ withStoreCfg (ASSCfg qt mt storeCfg) f = ASrvCfg qt mt (f storeCfg)
defaultStartOptions :: StartOptions
defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = testLogLevel, skipWarnings = False, confirmMigrations = MCYesUp}
testServerStoreConfig :: AStoreType -> AServerStoreCfg
testServerStoreConfig :: HasTestEnv => AStoreType -> AServerStoreCfg
testServerStoreConfig = serverStoreConfig_ False
serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg
serverStoreConfig_ :: HasTestEnv => Bool -> AStoreType -> AServerStoreCfg
#if defined(dbServerPostgres)
serverStoreConfig_ useDbStoreLog = \case
#else
serverStoreConfig_ _ = \case
#endif
ASType SQSMemory SMSMemory ->
ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
ASType SQSMemory SMSJournal ->
ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir}
ASType SQSPostgres SMSJournal ->
ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
#if defined(dbServerPostgres)
ASType SQSPostgres SMSPostgres ->
ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg
#endif
where
dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
#else
ASType SQSPostgres _ -> error "no dbServerPostgres flag"
#endif
cfgVPrev :: AStoreType -> AServerConfig
cfgVPrev :: HasTestEnv => AStoreType -> AServerConfig
cfgVPrev msType = updateCfg (cfgMS msType) $ \cfg' -> cfg' {smpServerVRange = prevRange $ smpServerVRange cfg'}
prevRange :: VersionRange v -> VersionRange v
@@ -319,10 +328,10 @@ prevVersion (Version v) = Version (v - 1)
nextVersion :: Version v -> Version v
nextVersion (Version v) = Version (v + 1)
proxyCfg :: AServerConfig
proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal)
proxyCfg :: HasTestEnv => AServerConfig
proxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
proxyCfgMS :: AStoreType -> AServerConfig
proxyCfgMS :: HasTestEnv => AStoreType -> AServerConfig
proxyCfgMS msType =
updateCfg (cfgMS msType) $ \cfg' ->
let smpAgentCfg' = smpAgentCfg cfg'
@@ -331,17 +340,17 @@ proxyCfgMS msType =
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}}
}
proxyCfgJ2 :: AServerConfig
proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2
proxyCfgS2 :: HasTestEnv => AServerConfig
proxyCfgS2 = memoryCfg proxyCfg testStoreLogFile2 testStoreMsgsFile2
proxyCfgJ2QS :: SQSType qs -> AServerConfig
proxyCfgJ2QS = \case
SQSMemory -> journalCfg (proxyCfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB (proxyCfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2
proxyCfgS2QS :: HasTestEnv => SQSType qs -> AServerConfig
proxyCfgS2QS = \case
SQSMemory -> memoryCfg (proxyCfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg (proxyCfgMS postgresStoreType) testStoreDBOpts2
-- Proxy config with a short relay-connection timeout, to bound how long a failing
-- proxy->relay connection attempt blocks in the relay reconnection tests.
proxyCfgShortTimeout :: AServerConfig
proxyCfgShortTimeout :: HasTestEnv => AServerConfig
proxyCfgShortTimeout =
updateCfg proxyCfg $ \cfg' ->
let aCfg = smpAgentCfg cfg'
@@ -349,7 +358,7 @@ proxyCfgShortTimeout =
nt = NetworkTimeout {backgroundTimeout = 4_000000, interactiveTimeout = 4_000000}
in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpConnectTimeout = nt}}}}
proxyCfgVPrev :: AStoreType -> AServerConfig
proxyCfgVPrev :: HasTestEnv => AStoreType -> AServerConfig
proxyCfgVPrev msType =
updateCfg (proxyCfgMS msType) $ \cfg' ->
let aCfg = smpAgentCfg cfg'
@@ -359,11 +368,11 @@ proxyCfgVPrev msType =
smpAgentCfg = aCfg {smpCfg = cCfg {serverVRange = prevRange $ serverVRange cCfg}}
}
withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn (t, msType) =
withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn (t, msType) =
withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {serverStatsBackupFile = Just testServerStatsBackupFile}
@@ -379,26 +388,32 @@ withSmpServerConfigOn t (ASrvCfg _ _ cfg') port' =
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
(threadDelay 10000)
withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType)
serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a
serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
startError <- newEmptyTMVarIO
stopped <- newEmptyTMVarIO
E.bracket
(forkIOWithUnmask (\unmask -> unmask (process started) `E.catchAny` handleStartError started))
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t >>= \r -> r <$ threadDelay 100000)
(forkIOWithUnmask (\unmask -> (unmask (process started) `E.catchAny` handleStartError started startError) `E.finally` atomically (putTMVar stopped ())))
(\t -> forkIO (killThread t) >> afterProcess >> waitStopped stopped)
(\t -> checkStarted started startError >> f t >>= \r -> r <$ threadDelay 100000)
where
-- it putTMVar is called twise to unlock both parts of the bracket in case of start failure
handleStartError started e = do
atomically $ putTMVar started False
handleStartError started startError e = do
atomically $ putTMVar startError e
atomically $ putTMVar started False
E.throwIO e
waitFor started s =
checkStarted started startError =
5_000_000 `timeout` atomically (takeTMVar started) >>= \case
Nothing -> error $ "server did not " <> s
_ -> pure ()
Nothing -> error "server did not start"
Just True -> pure ()
Just False -> atomically (readTMVar startError) >>= \e -> error $ "server did not start: " <> show e
waitStopped stopped = do
delay <- registerDelay 30_000_000
ok <- atomically $ (True <$ takeTMVar stopped) `orElse` (False <$ (readTVar delay >>= checkSTM))
unless ok $ error "server did not stop"
-- A TCP server that accepts connections but never performs a TLS handshake, so a client
-- connecting to it stays blocked in the TLS handshake until its connection timeout.
@@ -409,28 +424,28 @@ withStallingServerOn port action =
(pure ())
(const action)
withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const
withSmpServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServer :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServer ps = withSmpServerOn ps testPort
withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServerProxy :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const
withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const
withSmpServers2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgS2QS qs) testPort2 . const
withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const
withSmpServersProxy2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgS2QS qs) testPort2 . const
runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test
runSmpTestN :: forall c a. (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestN :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestNCfg :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
where
run :: Int -> [THandleSMP c 'TClient] -> IO a
@@ -439,11 +454,11 @@ runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c
smpServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
(HasTestEnv, Transport c, Encoding smp) =>
TProxy c 'TServer ->
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
IO (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg)
smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h
smpServerTest _ t = runSmpTest (ASType SQSMemory SMSMemory) $ \h -> tPut' h t >> tGet' h
where
tPut' :: THandleSMP c 'TClient -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO ()
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
@@ -454,30 +469,30 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >
[(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h
pure (Nothing, corrId, qId, cmd)
smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest :: (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest _ msType test' = runSmpTest msType test' `shouldReturn` ()
smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN :: (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg :: forall c. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 _ msType test' = smpTestN msType 3 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 _ msType test' = smpTestN msType 4 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
tests/SMPProxyTests.hs
+100 -75
View File
@@ -26,7 +26,7 @@ import qualified Data.List.NonEmpty as L
import Data.Time.Clock (getCurrentTime)
import SMPAgentClient
import SMPClient
import ServerTests (decryptMsgV3, sendRecv)
import ServerTests (decryptMsgV3, responseTime, sendRecv)
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
@@ -45,13 +45,9 @@ import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import System.FilePath (splitExtensions)
import System.Random (randomRIO)
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import UnliftIO
import Util
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#endif
smpProxyTests :: SpecWith AStoreType
smpProxyTests = do
@@ -75,74 +71,76 @@ smpProxyTests = do
xit "batching proxy requests" todo
it "relay rejects forwarded command with changed version" $ \_ ->
testChangedFwdVersion
it "proxy rejects forwarded correlation ID that is not 24 bytes" $ \_ ->
testFwdCorrIdSize
it "relay delays AUTH errors to forwarded commands" $ \_ ->
testForwardedAuthErrorDelay
describe "deliver message via SMP proxy" $ do
let srv1 = SMPServer testHost testPort testKeyHash
let srv1, srv2 :: HasTestEnv => SMPServer
srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost2 testPort2 testKeyHash
describe "client API" $ do
let maxLen = maxMessageLength
describe "one server" $ do
it "deliver via proxy" . oneServer $ do
it "deliver via proxy" $ oneServer $ do
deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"
describe "two servers" $ do
let proxyServ = srv1
let proxyServ, relayServ :: HasTestEnv => SMPServer
proxyServ = srv1
relayServ = srv2
(msg1, msg2) <- runIO $ do
g <- C.newRandom
atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g
it "deliver via proxy" . twoServersFirstProxy $
it "deliver via proxy" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2"
it "max message size, Ed448 keys" . twoServersFirstProxy $
it "max message size, Ed448 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2
it "max message size, Ed25519 keys" . twoServersFirstProxy $
it "max message size, Ed25519 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2
it "max message size, X25519 keys" . twoServersFirstProxy $
it "max message size, X25519 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2
describe "version compatibility" $ do
let deliver clientVR = deliverMessagesViaProxyVR clientVR srv1 srv2 C.SEd448 ["hello 1"] ["hello 2"]
it "prev client" . twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange)
it "prev proxy" . twoServersPrevProxy $ deliver supportedClientSMPRelayVRange
it "prev relay" . twoServersPrevRelay $ deliver supportedClientSMPRelayVRange
it "prev client" $ twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange)
it "prev proxy" $ twoServersPrevProxy $ deliver supportedClientSMPRelayVRange
it "prev relay" $ twoServersPrevRelay $ deliver supportedClientSMPRelayVRange
describe "stress test 1k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x1000" . twoServersFirstProxy $ deliver 1000
it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100
it "1x1000" $ twoServersFirstProxy $ deliver 1000
it "5x200" $ twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" $ twoServersFirstProxy $ 10 `inParrallel` deliver 100
describe "stress test - no host" $ do
it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
it "1x1000, no delay" $ oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" $ oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" $ oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
xdescribe "stress test 10k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x10000" . twoServersFirstProxy $ deliver 10000
it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20
#if defined(dbPostgres)
after_ (dropAllSchemasExceptSystem testDBConnectInfo) . describe "agent API" $ do
#else
it "1x10000" $ twoServersFirstProxy $ deliver 10000
it "5x2000" $ twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" $ twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" $ twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" $ twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" $ twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" $ twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" $ twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" $ twoServersFirstProxy $ 500 `inParrallel` deliver 20
describe "agent API" $ do
#endif
describe "one server" $ do
it "always via proxy" . oneServer $
it "always via proxy" $ oneServer $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . oneServer $
it "without proxy" $ oneServer $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
describe "two servers" $ do
it "always via proxy" $ \msType -> twoServers
(agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1)
msType
it "both via proxy" . twoServers $
it "both via proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy" . twoServers $
it "first via proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . twoServers $
it "without proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy for unknown" . twoServers $
it "first via proxy for unknown" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1
it "retries sending when destination or proxy relay is offline" $ \_ ->
agentViaProxyRetryOffline
@@ -150,29 +148,35 @@ smpProxyTests = do
agentViaProxyRetryNoSession
describe "stress test 1k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "2 agents, 250 messages" . oneServer $ deliver 2 250
it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50
it "2 agents, 250 messages" $ oneServer $ deliver 2 250
xdescribe "stress test 10k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
it "25 agents, 300 pairs, 17 messages" $ oneServer $ withNumCapabilities 4 $ deliver 25 17
where
oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test
twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType
twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersPrevProxy test msType = twoServers_ (proxyCfgVPrev msType) (cfgMS msType) test msType
twoServersPrevRelay test msType = twoServers_ (proxyCfgMS msType) (prevServerVRange $ cfgMS msType) test msType
prevServerVRange cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange $ smpServerVRange cfg_}
twoServers_ :: AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO ()
twoServers_ :: HasTestEnv => AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO ()
twoServers_ cfg1 cfg2 runTest (ASType qsType _) =
withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ ->
let cfg2' = case qsType of
SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2
SQSMemory -> memoryCfg cfg2 testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg cfg2 testStoreDBOpts2
in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest
smpProxyCapabilityTests :: SpecWith AStoreType
smpProxyCapabilityTests = do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [testSMPServer]) (map bshow [1 :: Int .. nMsgs])
it "5 agents, 10 pairs, 50 messages, N1" $ oneServer $ withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" $ oneServer $ withNumCapabilities 4 $ deliver 5 50
oneServer :: HasTestEnv => IO a -> AStoreType -> IO a
oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) testPort $ const test
deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg']
@@ -239,7 +243,7 @@ proxyConnectDeadRelay n d proxyServ = do
Right !_noWay -> error "got unexpected client"
Left !_err -> threadDelay d
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO ()
agentDeliverMessageViaProxy :: (HasTestEnv, C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
@@ -278,7 +282,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy_ smpProxyMode SPFAllow) {smp = userServers srvs}
agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc :: HasTestEnv => [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc agentServers msgs =
withAgents $ \agents -> do
let pairs = combinations 2 agents
@@ -345,7 +349,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy_ SPMAlways SPFAllow) {smp = userServers srvs}
agentViaProxyRetryOffline :: IO ()
agentViaProxyRetryOffline :: HasTestEnv => IO ()
agentViaProxyRetryOffline = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
@@ -401,15 +405,11 @@ agentViaProxyRetryOffline = do
ackMessage alice bobId (baseId + 4) Nothing
where
withServer :: (ThreadId -> IO a) -> IO a
withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort
-- TODO [postgres]
-- withServer = withServer_ testStoreDBOpts testStoreMsgsDir testStoreNtfsFile testPort
withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort
withServer2 :: (ThreadId -> IO a) -> IO a
withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2
-- TODO [postgres]
-- withServer2 = withServer_ testStoreDBOpts2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2
withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2
withServer_ storeLog storeMsgs storeNtfs =
let cfg' = updateCfg (journalCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs}
let cfg' = updateCfg (memoryCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs}
in withSmpServerConfigOn (transport @TLS) cfg'
a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
@@ -418,7 +418,7 @@ agentViaProxyRetryOffline = do
msgId = subtract baseId . fst
servers srv = initAgentServersProxy {smp = userServers [srv]}
agentViaProxyRetryNoSession :: IO ()
agentViaProxyRetryNoSession :: HasTestEnv => IO ()
agentViaProxyRetryNoSession = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
@@ -435,17 +435,17 @@ agentViaProxyRetryNoSession = do
_ <- runRight $ makeConnection b a
pure ()
where
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2
servers srv = initAgentServersProxy {smp = userServers [srv]}
testNoProxy :: AStoreType -> IO ()
testNoProxy :: HasTestEnv => AStoreType -> IO ()
testNoProxy msType = do
withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing)
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
testProxyAuth :: AStoreType -> IO ()
testProxyAuth :: HasTestEnv => AStoreType -> IO ()
testProxyAuth msType = do
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
testSMPClient_ "127.0.0.1" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
@@ -456,12 +456,12 @@ testProxyAuth msType = do
-- Connect a sender client to the proxy and request a relay session to testSMPServer2 (PRXY).
-- On success the reply is PKEY; otherwise it is the proxy error for the relay connection.
requestRelaySession :: IO (Either SMP.ErrorType SMP.BrokerMsg)
requestRelaySession :: HasTestEnv => IO (Either SMP.ErrorType SMP.BrokerMsg)
requestRelaySession =
testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) ->
(\(_, _, reply) -> reply) <$> sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing)
testChangedFwdVersion :: IO ()
testChangedFwdVersion :: HasTestEnv => IO ()
testChangedFwdVersion =
withSmpServerConfigOn (transport @TLS) cfg testPort $ \_ -> do
g <- C.newRandom
@@ -472,16 +472,41 @@ testChangedFwdVersion =
nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
let v = currentClientSMPRelayVersion
et <- either (fail . show) (pure . SMP.EncTransmission) $ C.cbEncrypt (C.dh' peerServerPubKey cmdPrivKey) (SMP.encTransmissionNonce v nonce) "" SMP.paddedProxiedTLength
let forward fwdVersion = forwardSMPTransmission rc (SMP.CorrId corrId) fwdVersion cmdPubKey et
let forward fwdVersion = forwardSMPTransmission rc (either error id $ C.corrCbNonce corrId) fwdVersion cmdPubKey et
_ <- runExceptT' $ forward v
runExceptT (forward $ prevVersion v) `shouldReturn` Left (PCEProtocolError SMP.CRYPTO)
testFwdCorrIdSize :: HasTestEnv => IO ()
testFwdCorrIdSize =
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ ->
testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, Right (SMP.PKEY sessId _ _)) <- sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing)
g <- C.newRandom
(cmdPubKey, _) <- atomically $ C.generateKeyPair g
forM_ (["", "2", "3333333333333333333333333"] :: [ByteString]) $ \corrId -> do
(_, _, reply) <- sendRecv th (Nothing, corrId, SMP.EntityId sessId, SMP.PFWD currentClientSMPRelayVersion cmdPubKey (SMP.EncTransmission ""))
reply `shouldBe` Right (SMP.ERR $ SMP.CMD SMP.SYNTAX)
testForwardedAuthErrorDelay :: HasTestEnv => IO ()
testForwardedAuthErrorDelay =
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) (updateCfg cfgS2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do
g <- C.newRandom
ts <- getCurrentTime
pc <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, testSMPServer, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive testSMPServer2 Nothing
(sendTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxySMPMessage pc NRMInteractive sess Nothing (SMP.EntityId "1234") noMsgFlags "hello"
(getLinkTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxyGetSMPQueueLink pc NRMInteractive sess (SMP.EntityId "1234")
sendTime `shouldSatisfy` (>= 0.5)
getLinkTime `shouldSatisfy` (>= 0.5)
-- Shared "phase 2" of the reconnection tests: start a healthy relay, confirm it is reachable
-- directly (PING, not via the proxy) so a proxy failure can only mean the proxy didn't reconnect,
-- let any stored connection error expire, then require the proxy to establish the session (PKEY).
requireProxyReconnect :: IO ()
requireProxyReconnect :: HasTestEnv => IO ()
requireProxyReconnect =
withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 $ \_ -> do
withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING)
reply `shouldBe` Right SMP.PONG
@@ -494,7 +519,7 @@ requireProxyReconnect =
-- The connect fails by timing out (storing a Left error that self-heals via persistErrorInterval),
-- so once a healthy relay is running the proxy reconnects. This proves the stalling relay alone
-- does not cause the permanent failure - only the mid-connection disconnect does.
testProxyRecoversWithoutDisconnect :: IO ()
testProxyRecoversWithoutDisconnect :: HasTestEnv => IO ()
testProxyRecoversWithoutDisconnect =
withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do
withStallingServerOn testPort2 $
@@ -516,7 +541,7 @@ testProxyRecoversWithoutDisconnect =
-- The stalling relay (accepts TCP, never completes TLS) holds the connect open long enough to
-- interleave the disconnect. Phase 2 (requireProxyReconnect) is identical to the control above;
-- the only difference is this disconnect.
testProxyReconnectAfterRelayRestart :: IO ()
testProxyReconnectAfterRelayRestart :: HasTestEnv => IO ()
testProxyReconnectAfterRelayRestart =
withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do
-- disconnect the sender 1s into the 4s connect to the stalling relay, killing the in-flight worker
@@ -530,14 +555,14 @@ testProxyReconnectAfterRelayRestart =
-- skipped and the empty var is left in smpClients, so every later connection to that server times
-- out on it. Phase 1 cancels a connect to a stalling relay; phase 2 requires a fresh connect to a
-- healthy relay to succeed.
testAgentClientReconnectAfterCancel :: IO ()
testAgentClientReconnectAfterCancel :: HasTestEnv => IO ()
testAgentClientReconnectAfterCancel =
withAgent 1 agentCfg agentServersLeak testDB $ \a -> do
withStallingServerOn testPort2 $ do
t <- async $ runExceptT $ A.createConnection a NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
threadDelay 1000000 -- let the connect to the stalling relay start, then kill it mid-flight
cancel t
withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ -> do
withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING)
reply `shouldBe` Right SMP.PONG -- the relay is up and reachable, so a timeout can only be the poisoned var
tests/ServerTests.hs
+92 -73
View File
@@ -24,7 +24,6 @@ import Control.Concurrent.STM
import Control.Exception (SomeException, throwIO, try)
import Control.Monad
import Control.Monad.IO.Class
import CoreTests.MsgStoreTests (testJournalStoreCfg)
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
@@ -36,6 +35,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.List (isPrefixOf)
import Data.Maybe (catMaybes)
import Data.String (IsString (..))
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Text.Read (readMaybe)
import Data.Type.Equality
import qualified Data.X509.Validation as XV
@@ -46,27 +46,26 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (exportMessages)
import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SMSType (..), SQSType (..), newMsgStore)
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Credentials
import Simplex.Messaging.Util (whenM)
import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile)
import System.Directory (doesFileExist, removeFile)
import System.IO (IOMode (..), withFile)
import System.TimeIt (timeItT)
import System.Timeout
import Test.HUnit
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import Util
#if defined(dbServerPostgres)
import CoreTests.MsgStoreTests (testPostgresStoreConfig)
import CoreTests.MsgStoreTests (testPostgresStoreConfig, testSMTStoreConfig)
import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore)
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
#endif
serverTests :: SpecWith (ASrvTransport, AStoreType)
@@ -96,7 +95,7 @@ serverTests = do
describe "Restore messages" testRestoreMessages
describe "Restore messages (old / v2)" testRestoreExpireMessages
describe "Save prometheus metrics" testPrometheusMetrics
describe "Timing of AUTH error" testTiming
describe "Delay of AUTH error" testAuthErrorDelay
describe "Message notifications" $ do
testMessageNotifications
testMessageServiceNotifications
@@ -166,7 +165,7 @@ signSend_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId,
authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of
C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t'
C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t'
C.SX25519 -> (\THAuthClient {peerServerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t') <$> thAuth params
C.SX25519 -> (\THAuthClient {peerServerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.unsafeCbNonce corrId) t') <$> thAuth params
#if !MIN_VERSION_base(4,18,0)
_sx448 -> undefined -- ghc8107 fails to the branch excluded by types
#endif
@@ -194,12 +193,12 @@ _SEND = SEND noMsgFlags
_SEND' :: MsgBody -> Command 'Sender
_SEND' = SEND MsgFlags {notification = True}
decryptMsgV2 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either C.CryptoError ByteString
decryptMsgV2 dhShared = C.cbDecrypt dhShared . C.cbNonce
decryptMsgV2 :: C.DhSecret 'C.X25519 -> MsgId -> ByteString -> Either C.CryptoError ByteString
decryptMsgV2 = C.cbDecrypt
decryptMsgV3 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either String MsgBody
decryptMsgV3 :: C.DhSecret 'C.X25519 -> MsgId -> ByteString -> Either String MsgBody
decryptMsgV3 dhShared nonce body =
case parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body) of
case parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared nonce body) of
Right ClientRcvMsgBody {msgBody} -> Right msgBody
Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota"
Left e -> Left e
@@ -425,7 +424,7 @@ testCreateDelete =
Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, _SEND "hello")
(err8, ERR AUTH) #== "rejects unsigned SEND too when deleted"
Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK "")
Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK mId2)
(err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted"
Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF)
@@ -609,7 +608,7 @@ testGetSubCommands =
Resp "4" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("4", rId, ACK mId1)
(dec mId2 msg2, Right "hello 2") #== "received from queue via SUB"
-- bad msgId returns error
Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK "1234")
Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK mId2)
-- already ACK'd by subscriber, but still returns OK when msgId matches
Resp "5a" _ OK <- signSendRecv rh2 rKey ("5a", rId, ACK mId1)
-- msg2 is not lost - even if subscriber does not ACK it, it is delivered to getter
@@ -904,7 +903,7 @@ testServiceSubsTotalCount =
_ -> pure Nothing
]
threadDelay 1500000
readFile testPrometheusMetricsFile >>= \m -> readServiceSubsMetric m `shouldBe` Just 2
B.readFile testPrometheusMetricsFile >>= \m -> readServiceSubsMetric (B.unpack m) `shouldBe` Just 2
-- Phase 2: associate 1 more queue via SUB, reconnect with SUBS 3, check metric = 3
(rPub3, rKey3) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -934,7 +933,7 @@ testServiceSubsTotalCount =
_ -> pure Nothing
]
threadDelay 1500000
readFile testPrometheusMetricsFile >>= \m -> readServiceSubsMetric m `shouldBe` Just 3
B.readFile testPrometheusMetricsFile >>= \m -> readServiceSubsMetric (B.unpack m) `shouldBe` Just 3
readServiceSubsMetric :: String -> Maybe Int
readServiceSubsMetric content =
@@ -1034,15 +1033,15 @@ testWithStoreLog =
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6)
removeFile testStoreLogFile
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
serverStoreLogCfg :: AStoreType -> (AServerConfig, Bool)
serverStoreLogCfg :: HasTestEnv => AStoreType -> (AServerConfig, Bool)
serverStoreLogCfg msType =
let cfg' =
withServerCfg (cfgMS msType) $ \cfg_ ->
@@ -1068,7 +1067,6 @@ testRestoreMessages =
it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
removeFileIfExists testStoreLogFile
removeFileIfExists testStoreMsgsFile
whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
removeFileIfExists testServerStatsBackupFile
g <- C.newRandom
@@ -1138,15 +1136,14 @@ testRestoreMessages =
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
removeFileIfExists testStoreMsgsFile
whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
removeFile testServerStatsBackupFile
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
@@ -1216,36 +1213,31 @@ testRestoreExpireMessages =
Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
_msgExpired `shouldBe` 2
where
exportStoreMessages :: AStoreType -> IO ()
exportStoreMessages :: HasTestEnv => AStoreType -> IO ()
exportStoreMessages = \case
ASType _ SMSJournal -> export
ASType _ SMSPostgres -> exportDB
ASType _ SMSMemory -> pure ()
where
export = do
ms <- readWriteQueues
exportMessages False (StoreJournal ms) testStoreMsgsFile False
closeMsgStore ms
#if defined(dbServerPostgres)
exportDB = do
readWriteQueues >>= closeMsgStore
ms' <- newMsgStore (testPostgresStoreConfig {quota = 4} :: PostgresMsgStoreCfg)
_n <- withFile testStoreMsgsFile WriteMode $ exportDbMessages False ms'
closeMsgStore ms'
readWriteQueues = do
ms <- newMsgStore testSMTStoreConfig
readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog
removeFileIfExists testStoreMsgsFile
pure ms
#else
exportDB = error "compiled without server_postgres flag"
#endif
readWriteQueues = do
ms <- newMsgStore ((testJournalStoreCfg MQStoreCfg) {quota = 4} :: JournalStoreConfig 'QSMemory)
readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog
removeFileIfExists testStoreMsgsFile
pure ms
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
testPrometheusMetrics :: SpecWith (ASrvTransport, AStoreType)
@@ -1274,21 +1266,21 @@ testTiming =
smpTest2Cfg (cfgMS msType) supportedServerSMPRelayVRange t $ \rh sh ->
testSameTiming rh sh tst msType
where
testName :: (C.AuthAlg, C.AuthAlg, Int) -> String
testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, _) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg]
timingTests :: [(C.AuthAlg, C.AuthAlg, Int)]
testName :: (C.AuthAlg, C.AuthAlg) -> String
testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg]
timingTests :: [(C.AuthAlg, C.AuthAlg)]
timingTests =
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200),
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519, 200),
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd448, 150),
(C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519), -- correct key type
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448),
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448), -- correct key type
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519),
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519),
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd448),
(C.AuthAlg C.SX25519, C.AuthAlg C.SX25519) -- correct key type
]
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
timeRepeat = fmap fst . responseTime . replicateM_ 5
similarTime t1 t2 msType
| t1 <= t2 = abs (1 - t1 / t2) < diff
| otherwise = similarTime t2 t1 msType
@@ -1297,14 +1289,14 @@ testTiming =
diff = case msType of
ASType SQSPostgres _ -> 0.45
_ -> 0.3
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> AStoreType -> Expectation
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) msType = do
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg) -> AStoreType -> Expectation
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) msType = do
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub)
Resp "abcdabcdabcdabcdabcdabcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcdabcdabcdabcdabcdabcd", NoEntity, New rPub dhPub)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
Resp "cdab" _ resp <- signSendRecv rh rKey ("cdab", rId, SUB)
Resp "cdabcdabcdabcdabcdabcdab" _ resp <- signSendRecv rh rKey ("cdabcdabcdabcdabcdabcdab", rId, SUB)
case resp of
OK -> pure ()
SOK Nothing -> pure ()
@@ -1314,9 +1306,9 @@ testTiming =
runTimingTest rh badKey rId SUB
(sPub, sKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
Resp "dabcdabcdabcdabcdabcdabc" _ OK <- signSendRecv rh rKey ("dabcdabcdabcdabcdabcdabc", rId, KEY sPub)
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
Resp "bcdabcdabcdabcdabcdabcda" _ OK <- signSendRecv sh sKey ("bcdabcdabcdabcdabcdabcda", sId, _SEND "hello")
Resp "" _ (Msg mId msg) <- tGet1 rh
(dec mId msg, Right "hello") #== "delivered from queue"
@@ -1325,17 +1317,17 @@ testTiming =
runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO ()
runTimingTest h badKey qId cmd = do
threadDelay 100000
_ <- timeRepeat n $ do
_ <- timeRepeat $ do
-- "warm up" the server
Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd)
return ()
threadDelay 100000
timeWrongKey <- timeRepeat n $ do
Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd)
timeWrongKey <- timeRepeat $ do
Resp "cdabcdabcdabcdabcdabcdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdabcdabcdabcdabcdabcdab", qId, cmd)
return ()
threadDelay 100000
timeNoQueue <- timeRepeat n $ do
Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
timeNoQueue <- timeRepeat $ do
Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd)
return ()
let ok = similarTime timeNoQueue timeWrongKey msType
unless ok . putStrLn . unwords $
@@ -1347,6 +1339,33 @@ testTiming =
]
ok `shouldBe` True
testAuthErrorDelay :: SpecWith (ASrvTransport, AStoreType)
testAuthErrorDelay =
it "should send AUTH errors after the delay and other responses without it" $ \(ATransport t, msType) ->
smpTest2Cfg (updateCfg (cfgMS msType) $ \cfg' -> cfg' {authErrorDelay = 500000}) supportedClientSMPRelayVRange t $ \rh sh -> do
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "1" NoEntity (Ids rId sId _) <- signSendRecv rh rKey ("1", NoEntity, New rPub dhPub)
(_, badKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(wrongKeyTime, Resp "2" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("2", rId, SUB)
(noQueueTime, Resp "3" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("3", EntityId "1234", SUB)
(noLinkTime, Resp "4" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "4", EntityId "1234", LGET)
(subTime, Resp "5" _ (SOK Nothing)) <- responseTime $ signSendRecv rh rKey ("5", rId, SUB)
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, OFF)
(suspendedTime, Resp "7" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "7", sId, _SEND "hello")
wrongKeyTime `shouldSatisfy` (>= 0.5)
noQueueTime `shouldSatisfy` (>= 0.5)
suspendedTime `shouldSatisfy` (>= 0.5)
noLinkTime `shouldSatisfy` (>= 0.5)
subTime `shouldSatisfy` (< 0.5)
responseTime :: IO a -> IO (NominalDiffTime, a)
responseTime action = do
t <- getCurrentTime
r <- action
(,r) . (`diffUTCTime` t) <$> getCurrentTime
testMessageNotifications :: SpecWith (ASrvTransport, AStoreType)
testMessageNotifications =
it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do
@@ -1511,7 +1530,7 @@ testServiceNotificationsTwoRestarts =
Resp "3.2" _ (SOK Nothing) <- signSendRecv rh rKey ("3.2", rId, SUB)
deliverMessage rh rId rKey sh sId sKey nh "hello 3" dec
where
runTest2 :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest2 :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest2 _ test' server = do
a <- testSMPClient $ \h1 -> testSMPClient $ \h2 -> test' h1 h2
killThread server
@@ -1549,7 +1568,7 @@ testMsgExpireOnInterval =
it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
testSMPClient @c $ \sh -> do
(sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
@@ -1602,7 +1621,7 @@ testBlockMessageQueue =
Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent Nothing))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
(sId2, sId) #== "same queue ID in response"
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest _ test' server = do
a <- testSMPClient test'
killThread server
@@ -1814,10 +1833,10 @@ serverSyntaxTests (ATransport t) = do
it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
describe "ACK" $ do
it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
it "no parameters" $ (sampleSig, "abcd", "12345678", ACK_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "123456789012345678901234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
describe "PING" $ do
it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)
describe "broker response not allowed" $ do
@@ -1830,7 +1849,7 @@ serverSyntaxTests (ATransport t) = do
it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
(>#>) ::
Encoding smp =>
(HasTestEnv, Encoding smp) =>
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
(Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) ->
Expectation
tests/Test.hs
+111 -110
View File
@@ -1,11 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
import AgentTests (agentCoreTests, agentTests)
import AgentTests.FunctionalAPITests (functionalAPITimingTests)
import CLITests
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Control.Exception (bracket_)
import Control.Logger.Simple
import CoreTests.BatchingTests
import CoreTests.CryptoFileTests
@@ -19,20 +18,19 @@ import CoreTests.TSessionSubs
import CoreTests.UtilTests
import CoreTests.VersionRangeTests
import FileDescriptionTests (fileDescriptionTests)
import GHC.IO.Exception (IOException (..))
import qualified GHC.IO.Exception as IOException
import RSLVTests (rslvTests)
import RemoteControl (remoteControlTests)
import SMPNamesTests (smpNamesTests)
import SMPProxyTests (smpProxyTests)
import SMPProxyTests (smpProxyCapabilityTests, smpProxyTests)
import ServerTests
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Transport (TLS, Transport (..))
-- import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import System.Environment (setEnv)
import System.Directory (createDirectory, removePathForcibly)
import System.Environment (getArgs, setEnv, withArgs)
import Test.Hspec hiding (fit, it)
import Test.Hspec.Core.Runner (defaultConfig, evalSpec, evaluateResult, readConfig, runSpecForest)
import Util
import XFTPAgent
import XFTPCLI (xftpCLIFileTests)
@@ -44,18 +42,18 @@ import XFTPWebTests (xftpWebTests)
#if defined(dbPostgres)
import Fixtures
import SMPAgentClient (testDB)
import Simplex.Messaging.Agent.Store.Postgres.Migrations.App
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#else
import AgentTests.SchemaDump (schemaDumpTest)
import System.Directory (listDirectory)
import System.FilePath ((</>))
#endif
#if defined(dbServerPostgres)
import CoreTests.XFTPStoreTests (xftpStoreTests, xftpMigrationTests)
import NtfServerTests (ntfServerTests)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts)
import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBOpts)
import SMPClient (testServerDBConnectInfo, testServerDBOpts)
import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
import XFTPClient (testXFTPDBConnectInfo)
@@ -75,132 +73,135 @@ main = do
withGlobalLogging logCfg $ do
setEnv "APNS_KEY_ID" "H82WD9K9AQ"
setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
hspec
hspecInTmpDir
#if defined(dbPostgres)
. aroundAll_ (postgressBracket testDBConnectInfo)
#endif
. before_ (createDirectoryIfMissing False "tests/tmp")
. after_ (eventuallyRemove "tests/tmp" 3)
$ do
describe "Core tests" $ do
describe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Message store tests" msgStoreTests
describe "Retry interval tests" retryIntervalTests
describe "SOCKS settings tests" socksSettingsTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "Store log tests" storeLogTests
#else
describe "Store log tests" storeLogTests
. aroundAll_ (postgressBracket testServerDBConnectInfo)
. aroundAll_ (postgressBracket ntfTestServerDBConnectInfo)
. aroundAll_ (postgressBracket testXFTPDBConnectInfo)
#endif
describe "XFTP store log tests" fileStoreLogTests
fileExpirationTests
describe "TSessionSubs tests" tSessionSubsTests
describe "Util tests" utilTests
describe "Names resolver tests" smpNamesTests
describe "RSLV functional API tests" rslvTests
describe "Agent core tests" agentCoreTests
$ do
parallel $ do
describe "Core tests" $ do
describe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Message store tests" msgStoreTests
describe "SOCKS settings tests" socksSettingsTests
describe "Store log tests" storeLogTests
describe "XFTP store log tests" fileStoreLogTests
fileExpirationTests
describe "TSessionSubs tests" tSessionSubsTests
describe "Util tests" utilTests
describe "Names resolver tests" smpNamesTests
describe "RSLV functional API tests" rslvTests
describe "Agent core tests" agentCoreTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "SMP server schema dump" $
postgresSchemaDumpTest
serverMigrations
[ "20250320_short_links", -- snd_secure moves to the bottom on down migration
"20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration
] -- skipComparisonForDownMigrations
testStoreDBOpts
"src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "SMP server via TLS, postgres+jornal message store" $
-- before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
describe "SMP server via TLS, postgres-only message store" $
before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests
#endif
describe "SMP server via TLS, jornal message store" $ do
describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests
describe "SMP server via TLS, memory message store" $
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests
-- xdescribe "SMP server via WebSockets" $ do
-- describe "SMP syntax" $ serverSyntaxTests (transport @WS)
-- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests
describe "SMP server via TLS, memory message store" $ do
describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests
-- xdescribe "SMP server via WebSockets" $ do
-- describe "SMP syntax" $ serverSyntaxTests (transport @WS)
-- before (pure (transport @WS, ASType SQSMemory SMSMemory)) serverTests
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Ntf server schema dump" $
postgresSchemaDumpTest
ntfServerMigrations
[] -- skipComparisonForDownMigrations
ntfTestStoreDBOpts
"src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
around_ (postgressBracket ntfTestServerDBConnectInfo) $ do
describe "Notifications server (SMP server: memory store)" $
ntfServerTests (transport @TLS, ASType SQSMemory SMSMemory)
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "Notifications server (SMP server: postgres+jornal store)" $
-- ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal)
describe "Notifications server (SMP server: postgres-only store)" $
ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
describe "Notifications server (SMP server: postgres-only store)" $
ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
describe "SMP client agent, server postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres)
-- xdescribe "SMP proxy, postgres+jornal message store" $
-- before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
describe "SMP proxy, postgres-only message store" $
before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
#endif
-- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
describe "SMP proxy, jornal message store" $
before (pure $ ASType SQSMemory SMSJournal) smpProxyTests
describe "XFTP" $ do
describe "XFTP server" $
before (pure $ AFSType SFSMemory) xftpServerTests
describe "XFTP file description" fileDescriptionTests
describe "XFTP CLI (memory)" $
before (pure $ AFSType SFSMemory) xftpCLIFileTests
describe "XFTP agent" $
before (pure $ AFSType SFSMemory) xftpAgentTests
describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
describe "SMP proxy, memory message store" $
before (pure $ ASType SQSMemory SMSMemory) smpProxyTests
describe "XFTP" $ do
describe "XFTP server" $
before (pure $ AFSType SFSMemory) xftpServerTests
describe "XFTP file description" fileDescriptionTests
describe "XFTP agent" $
before (pure $ AFSType SFSMemory) xftpAgentTests
#if defined(dbServerPostgres)
around_ (postgressBracket testXFTPDBConnectInfo) $ do
describe "XFTP Postgres store operations" xftpStoreTests
describe "XFTP migration round-trip" xftpMigrationTests
describe "XFTP server (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpServerTests
describe "XFTP agent (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpAgentTests
#endif
describe "XFTP Web Client" xftpWebTests
describe "XRCP" remoteControlTests
describe "Web" webTests
sequential $ do
describe "Core tests" $ describe "Retry interval tests" retryIntervalTests
#if defined(dbServerPostgres)
describe "SMP server via TLS, postgres-only message store" $
before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) $ describe "Timing of AUTH error" testTiming
#endif
describe "SMP server via TLS, memory message store" $
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) $ describe "Timing of AUTH error" testTiming
#if defined(dbServerPostgres)
describe "SMP client agent, server postgres-only message store" $
describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSPostgres SMSPostgres)
#endif
describe "SMP client agent, server memory message store" $
describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSMemory SMSMemory)
#if defined(dbServerPostgres)
describe "SMP proxy capabilities, postgres-only message store" $
before (pure $ ASType SQSPostgres SMSPostgres) smpProxyCapabilityTests
#endif
describe "SMP proxy capabilities, memory message store" $
before (pure $ ASType SQSMemory SMSMemory) smpProxyCapabilityTests
describe "XFTP CLI (memory)" $
before (pure $ AFSType SFSMemory) xftpCLIFileTests
#if defined(dbServerPostgres)
describe "XFTP CLI (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpCLIFileTests
#endif
#if defined(dbPostgres)
describe "XFTP Web Client" $ xftpWebTests (dropAllSchemasExceptSystem testDBConnectInfo)
#else
describe "XFTP Web Client" $ xftpWebTests (pure ())
describe "Server CLIs" cliTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "SMP server schema dump" $
postgresSchemaDumpTest
serverMigrations
[ "20250320_short_links", -- snd_secure moves to the bottom on down migration
"20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration
] -- skipComparisonForDownMigrations
testServerDBOpts
"src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Ntf server schema dump" $
postgresSchemaDumpTest
ntfServerMigrations
[] -- skipComparisonForDownMigrations
ntfTestServerDBOpts
"src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
#endif
describe "XRCP" remoteControlTests
describe "Web" webTests
describe "Server CLIs" cliTests
#if defined(dbPostgres)
around_ (postgressBracket testDBConnectInfo) $
describe "Agent PostgreSQL schema dump" $
postgresSchemaDumpTest
appMigrations
["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration
(testDBOpts testDB)
"src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql"
around_ (postgressBracket testDBConnectInfo) $
describe "Agent PostgreSQL schema dump" $
postgresSchemaDumpTest
appMigrations
["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration
(testDBOpts "smp_agent_test_protocol_schema")
"src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql"
#else
describe "Agent SQLite schema dump" schemaDumpTest
after_ (listDirectory tmpDir >>= mapM_ (removeFileIfExists . (tmpDir </>))) $
describe "Agent SQLite schema dump" schemaDumpTest
#endif
eventuallyRemove :: FilePath -> Int -> IO ()
eventuallyRemove path retries = case retries of
0 -> action
n ->
action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
_ -> E.throwIO ioe
where
action = removeDirectoryRecursive path
hspecInTmpDir :: Spec -> IO ()
hspecInTmpDir spec = do
(config, forest) <- evalSpec defaultConfig spec
config' <- getArgs >>= readConfig config
withTmpDir (withArgs [] $ runSpecForest forest config') >>= evaluateResult
withTmpDir :: IO a -> IO a
withTmpDir = bracket_ (removePathForcibly tmpDir >> createDirectory tmpDir) (eventuallyRemove tmpDir 3)
tests/Util.hs
+89 -10
View File
@@ -1,21 +1,33 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Util where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception as E
import Control.Logger.Simple
import Control.Monad (replicateM, when)
import Data.Either (partitionEithers)
import Data.List (tails)
import Data.String (IsString (..))
import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
import System.Directory (doesFileExist, removeFile)
import GHC.IO.Exception (IOException (..))
import qualified GHC.IO.Exception as IOException
import Network.Socket (ServiceName)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import System.Process (callCommand)
import System.Timeout (timeout)
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import qualified Test.Hspec as Hspec
import Test.Hspec.Core.Spec (Example (..), Result (..), ResultStatus (..))
@@ -44,7 +56,70 @@ removeFileIfExists filePath = do
fileExists <- doesFileExist filePath
when fileExists $ removeFile filePath
newtype TestWrapper a = TestWrapper a
data TestEnv = TestEnv
{ testNo :: Int,
portBase :: Int
}
type HasTestEnv = (?testEnv :: TestEnv)
tmpDir :: FilePath
tmpDir = "tests/tmp"
testDir :: HasTestEnv => FilePath
testDir = tmpDir </> show (testNo ?testEnv)
testPath :: HasTestEnv => FilePath -> FilePath
testPath = (testDir </>)
testServerPort :: HasTestEnv => Int -> ServiceName
testServerPort offset = show (portBase ?testEnv + offset)
testSchemaName :: (HasTestEnv, IsString s) => String -> s
testSchemaName name = fromString $ "test" <> show (testNo ?testEnv) <> "_" <> name
senderFiles :: HasTestEnv => FilePath
senderFiles = testPath "xftp-sender-files"
recipientFiles :: HasTestEnv => FilePath
recipientFiles = testPath "xftp-recipient-files"
testCounter :: TVar Int
testCounter = unsafePerformIO $ newTVarIO 0
{-# NOINLINE testCounter #-}
portBases :: TVar [Int]
portBases = unsafePerformIO $ newTVarIO [10000, 10010 .. 19990]
{-# NOINLINE portBases #-}
withTestEnv :: (HasTestEnv => IO a) -> IO a
withTestEnv action =
bracket takePortBase releasePortBase $ \portBase -> do
testNo <- atomically $ stateTVar testCounter $ \n -> (n, n + 1)
let ?testEnv = TestEnv {testNo, portBase}
bracket_
(mapM_ (createDirectoryIfMissing True) [senderFiles, recipientFiles])
(eventuallyRemove testDir 3)
action
where
takePortBase =
atomically $
readTVar portBases >>= \case
b : bs -> b <$ writeTVar portBases bs
[] -> retry
releasePortBase b = atomically $ modifyTVar' portBases (<> [b])
eventuallyRemove :: FilePath -> Int -> IO ()
eventuallyRemove path retries = case retries of
0 -> action
n ->
action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
_ -> E.throwIO ioe
where
action = removeDirectoryRecursive path
data TestWrapper a = TestWrapper (HasTestEnv => a)
-- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs"
testLogLevel :: LogLevel
@@ -56,11 +131,12 @@ instance Example a => Example (TestWrapper a) where
ci <- envCI
runTest `E.catches` [E.Handler (onTestFailure ci), E.Handler (onTestException ci)]
where
tt = 120
tt = 300
runTest =
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
withTestEnv $
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
onTestFailure :: Bool -> ResultStatus -> IO Result
onTestFailure ci = \case
Failure loc_ reason | ci -> do
@@ -80,8 +156,11 @@ instance Example a => Example (TestWrapper a) where
envCI :: IO Bool
envCI = (Just "true" ==) <$> lookupEnv "CI"
it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
it :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
it label action = Hspec.it label (TestWrapper action)
fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
fit = fmap focus . it
fit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
fit label action = focus $ it label action
xit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit label action = Hspec.xit label (TestWrapper action)
tests/XFTPAgent.hs
+52 -47
View File
@@ -48,34 +48,25 @@ import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), s
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServer, XFTPServerWithAuth)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
import Simplex.Messaging.Server.Information (ServerPublicInfo)
import Simplex.Messaging.Transport (EntitlementConfig (..))
import Simplex.Messaging.Util (tshow)
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
import System.FilePath ((</>))
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import UnliftIO
import UnliftIO.Concurrent
import Util
import XFTPCLI
import XFTPClient
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#endif
pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile
pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _
xftpAgentTests :: SpecWith AFStoreType
xftpAgentTests =
around_ testBracket
#if defined(dbPostgres)
. after_ (dropAllSchemasExceptSystem testDBConnectInfo)
#endif
. describe "agent XFTP API" $ do
describe "agent XFTP API" $ do
it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive
-- uncomment CPP option slow_servers and run hpack to run this test
xit "should send and receive file with slow server responses" $ \_ ->
@@ -100,18 +91,21 @@ xftpAgentTests =
it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
describe "XFTP server test via agent API" $ do
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right (Just (Right testServerInformation))
let srv1 = testXFTPServer2 {keyHash = "1234"}
let srv1 :: HasTestEnv => XFTPServer
srv1 = testXFTPServer2 {keyHash = "1234"}
it "should fail with incorrect fingerprint" $ \_ -> do
testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
describe "server with password" $ do
let auth = Just "abcd"
srv :: HasTestEnv => Maybe BasicAuth -> XFTPServerWithAuth
srv = ProtoServerWithAuth testXFTPServer2
authErr :: HasTestEnv => ProtocolTestFailure
authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr
it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testXFTPServerTest :: (HasCallStack, HasTestEnv) => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testXFTPServerTest newFileBasicAuth srv =
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2, information = Just testServerInformation} $ \_ ->
-- initially passed server is not running
@@ -143,7 +137,7 @@ checkProgress (prev, expected) (progress, total) loop
| progress < total = loop progress
| otherwise = pure ()
testXFTPAgentSendReceive :: HasCallStack => IO ()
testXFTPAgentSendReceive :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendReceive = do
filePath <- createRandomFile
-- send file, delete snd file internally
@@ -160,7 +154,7 @@ testXFTPAgentSendReceive = do
rfId <- runRight $ testReceive rcp rfd originalFilePath
xftpDeleteRcvFile rcp rfId
testXFTPAgentSendReceiveEncrypted :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveEncrypted :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
g <- C.newRandom
filePath <- createRandomFile
@@ -181,13 +175,14 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
xftpDeleteRcvFile rcp rfId
testXFTPAgentSendReceiveRedirect :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
--- sender
filePathIn <- createRandomFile
let fileSize = mb 17
totalSize = fileSize + mb 1
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
@@ -222,7 +217,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
--- recipient
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
@@ -239,12 +234,13 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
inBytes <- B.readFile filePathIn
B.readFile out `shouldReturn` inBytes
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveNoRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
--- sender
let fileSize = mb 5
filePathIn <- createRandomFile_ fileSize "testfile"
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
let totalSize = fileSize + mb 1
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
@@ -267,6 +263,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
let ValidFileDescription FileDescription {redirect} = description
redirect `shouldBe` Nothing
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
-- NO extra "RFPROG 65k 65k" before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
@@ -280,7 +277,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
inBytes <- B.readFile filePathIn
B.readFile out `shouldReturn` inBytes
testXFTPAgentPrepareReceive :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentPrepareReceive :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentPrepareReceive = withXFTPServer $ do
filePath <- createRandomFile
(_, _, rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ testSend sndr filePath
@@ -305,7 +302,7 @@ testXFTPAgentPrepareReceive = withXFTPServer $ do
file <- B.readFile filePath
B.readFile path `shouldReturn` file
testXFTPAgentPrepareSend :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentPrepareSend :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentPrepareSend = withXFTPServer $ do
filePath1 <- createRandomFile' "testfile1"
filePath2 <- createRandomFile' "testfile2"
@@ -343,11 +340,12 @@ testXFTPAgentSendReceiveMatrix = do
it "old sender, new recipient" $ run newServer oldClient newClient
it "old clients" $ run newServer oldClient oldClient
where
oldClient, newClient :: HasTestEnv => AgentConfig
oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}}
newClient = agentCfg
oldServer = withXFTPServerCfgNoALPN
newServer = withXFTPServerCfg
run :: HasCallStack => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
run :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
run withServer sender receiver =
withServer testXFTPServerConfig $ \_t -> do
filePath <- createRandomFile_ (kb 319 :: Integer) "testfile"
@@ -355,29 +353,30 @@ testXFTPAgentSendReceiveMatrix = do
(sfId, _, rfd1, _) <- runRight $ testSendCF' sndr (CF.plain filePath) (kb 320)
rfd1 <$ xftpDeleteSndFileInternal sndr sfId
withAgent 2 receiver initAgentServers testDB2 $ \rcp -> do
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rfId <- runRight $ testReceiveCF' rcp rfd Nothing filePath (kb 320)
xftpDeleteRcvFile rcp rfId
createRandomFile :: HasCallStack => IO FilePath
createRandomFile :: (HasCallStack, HasTestEnv) => IO FilePath
createRandomFile = createRandomFile' "testfile"
createRandomFile' :: HasCallStack => FilePath -> IO FilePath
createRandomFile' :: (HasCallStack, HasTestEnv) => FilePath -> IO FilePath
createRandomFile' = createRandomFile_ (mb 17 :: Integer)
createRandomFile_ :: (HasCallStack, Integral s, Show s) => s -> FilePath -> IO FilePath
createRandomFile_ :: (HasCallStack, HasTestEnv, Integral s) => s -> FilePath -> IO FilePath
createRandomFile_ size fileName = do
let filePath = senderFiles </> fileName
xftpCLI ["rand", filePath, show size] `shouldReturn` ["File created: " <> filePath]
B.writeFile filePath =<< atomically . C.randomBytes (fromIntegral size) =<< C.newRandom
getFileSize filePath `shouldReturn` toInteger size
pure filePath
testSend :: HasCallStack => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend :: (HasCallStack, HasTestEnv) => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend sndr = testSendCF sndr . CF.plain
testSendCF :: HasCallStack => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF sndr file = testSendCF' sndr file $ mb 18
testSendCF' :: HasCallStack => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF' :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF' sndr file size = do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 file 2
@@ -392,7 +391,7 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO ()
testNoRedundancy (ValidFileDescription FileDescription {chunks}) =
all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True
testXFTPAgentEntitlement :: HasCallStack => IO ()
testXFTPAgentEntitlement :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentEntitlement = do
Right (issuerPk, issuerSk) <- bbsKeyGen
now <- getCurrentTime
@@ -429,10 +428,10 @@ testXFTPAgentEntitlement = do
("", _, SFPROG _ _) -> waitSndDone sndr
r -> error $ "Expected SFDONE, got " <> show r
testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive rcp rfd = testReceiveCF rcp rfd Nothing
testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF rcp rfd cfArgs originalFilePath = do
xftpStartWorkers rcp (Just recipientFiles)
testReceiveCF' rcp rfd cfArgs originalFilePath $ mb 18
@@ -454,7 +453,7 @@ testReceiveCF' rcp rfd cfArgs originalFilePath size = do
logCfgNoLogs :: LogConfig
logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
testXFTPAgentReceiveRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentReceiveRestore = do
filePath <- createRandomFile
@@ -498,7 +497,7 @@ testXFTPAgentReceiveRestore = do
-- tmp path should be removed after receiving file
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
testXFTPAgentReceiveCleanup :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -523,13 +522,14 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp'
("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp'
rfId' `shouldBe` rfId
srv `shouldBe` testXFTPServerStr
-- tmp path should be removed after permanent error
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentSendRestore :: HasCallStack => IO ()
testXFTPAgentSendRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -576,7 +576,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
runRight_ . void $ testReceive rcp rfd1 filePath
testXFTPAgentSendCleanup :: HasCallStack => IO ()
testXFTPAgentSendCleanup :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -602,15 +602,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
-- send file - should fail with AUTH error
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", sfId', SFERR (XFTP srv AUTH)) <-
sfGet sndr'
sfId' `shouldBe` sfId
srv `shouldBe` testXFTPServerStr
-- prefix path should be removed after permanent error
doesDirectoryExist prefixPath `shouldReturn` False
doesFileExist encPath `shouldReturn` False
testXFTPAgentDelete :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentDelete :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test
where
test = do
@@ -639,11 +640,12 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
testXFTPAgentDeleteRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -677,11 +679,12 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
testXFTPAgentDeleteOnServer :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentDeleteOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer test
where
test = do
@@ -713,14 +716,15 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te
runRight_ . void $ do
-- receive file 1 again
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId1', RFERR (XFTP srv AUTH)) <-
rfGet rcp
liftIO $ rfId1 `shouldBe` rfId1'
liftIO $ srv `shouldBe` testXFTPServerStr
-- receive file 2
testReceive' rcp rfd2 filePath2
testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentExpiredOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do
filePath1 <- createRandomFile' "testfile1"
@@ -745,9 +749,10 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
-- receive file 1 again - should fail with AUTH error
runRight $ do
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
-- create and send file 2
filePath2 <- createRandomFile' "testfile2"
@@ -760,7 +765,7 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
where
fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentRequestAdditionalRecipientIDs :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
filePath <- createRandomFile
tests/XFTPCLI.hs
+17 -31
View File
@@ -1,6 +1,6 @@
module XFTPCLI (xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where
module XFTPCLI (xftpCLIFileTests, xftpCLI) where
import Control.Exception (bracket_, try)
import Control.Exception (try)
import qualified Data.ByteString as LB
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Simplex.FileTransfer.Client.Main
@@ -10,7 +10,7 @@ import Simplex.FileTransfer.Client.Main
)
import Simplex.FileTransfer.Description (kb, mb)
import Simplex.FileTransfer.Util (safeFileNameStr, uniqueCombine)
import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
import System.Directory (getFileSize, listDirectory)
import System.Environment (withArgs)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (takeFileName, (</>))
@@ -21,7 +21,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType)
import XFTPClient (cfgFS, cfgFS2, withXFTPServer, withXFTPServerConfigOn, testXFTPServerStr, testXFTPServerStr2, xftpServerFiles, xftpServerFiles2)
xftpCLIFileTests :: SpecWith AFStoreType
xftpCLIFileTests = around_ testBracket $ do
xftpCLIFileTests = do
it "shows experimental deprecation notice in help" $ \_ ->
testXFTPCLIHelpDeprecationNotice
it "should send and receive file" $ withXFTPServer testXFTPCLISendReceive_
@@ -43,20 +43,6 @@ xftpCLIFileTests = around_ testBracket $ do
sanitized n = let n' = safeFileNameStr n in n' /= "" && n' /= "." && n' /= ".."
bareName n = let n' = safeFileNameStr n in n' == takeFileName n'
testBracket :: IO () -> IO ()
testBracket =
bracket_
(mapM_ (createDirectoryIfMissing False) testDirs)
(mapM_ removeDirectoryRecursive testDirs)
where
testDirs = [xftpServerFiles, xftpServerFiles2, senderFiles, recipientFiles]
senderFiles :: FilePath
senderFiles = "tests/tmp/xftp-sender-files"
recipientFiles :: FilePath
recipientFiles = "tests/tmp/xftp-recipient-files"
xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
@@ -66,7 +52,7 @@ testXFTPCLIHelpDeprecationNotice = do
result `shouldBe` (Left ExitSuccess :: Either ExitCode ())
unwords (words output) `shouldSatisfy` (xftpClientDeprecationNotice `isInfixOf`)
testXFTPCLISendReceive_ :: IO ()
testXFTPCLISendReceive_ :: HasTestEnv => IO ()
testXFTPCLISendReceive_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -75,7 +61,7 @@ testXFTPCLISendReceive_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -90,19 +76,19 @@ testXFTPCLISendReceive_ = do
testInfoFile fdRcv2 "Recipient"
testReceiveFile fdRcv2 "testfile_1" file
testInfoFile fdSnd "Sender"
xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=" <> testDir]
`shouldThrow` anyException
where
testInfoFile fd party = do
xftpCLI ["info", fd]
`shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
testReceiveFile fd fileName file = do
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"]
progress `shouldSatisfy` downloadProgress fileName
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
testXFTPCLISendReceive2servers_ :: IO ()
testXFTPCLISendReceive2servers_ :: HasTestEnv => IO ()
testXFTPCLISendReceive2servers_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -111,7 +97,7 @@ testXFTPCLISendReceive2servers_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -135,12 +121,12 @@ testXFTPCLISendReceive2servers_ = do
srv1 `shouldContain` testXFTPServerStr
srv2 `shouldContain` testXFTPServerStr2
_ -> print srvs >> error "more than 2 servers returned"
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"]
progress `shouldSatisfy` downloadProgress fileName
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
testXFTPCLIDelete_ :: IO ()
testXFTPCLIDelete_ :: HasTestEnv => IO ()
testXFTPCLIDelete_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -149,7 +135,7 @@ testXFTPCLIDelete_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -161,7 +147,7 @@ testXFTPCLIDelete_ = do
sendRest `shouldSatisfy` any ("https://" `isPrefixOf`)
xftpCLI ["del", fdRcv1]
`shouldThrow` anyException
progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=" <> testDir, "-y"]
progress1 `shouldSatisfy` downloadProgress "testfile"
recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."]
LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
@@ -172,10 +158,10 @@ testXFTPCLIDelete_ = do
`shouldReturn` ["File deleted! \r", "File description " <> fdSnd <> " is deleted."]
listDirectory xftpServerFiles >>= (`shouldBe` [])
listDirectory xftpServerFiles2 >>= (`shouldBe` [])
xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=" <> testDir]
`shouldThrow` anyException
testReceivedFileNameCombine :: IO ()
testReceivedFileNameCombine :: HasTestEnv => IO ()
testReceivedFileNameCombine =
uniqueCombine recipientFiles "../../escaped.txt" `shouldReturn` (recipientFiles </> "escaped.txt")
@@ -202,7 +188,7 @@ uploadProgress s =
&& "Uploading file..." `isInfixOf` s
&& "File uploaded!" `isInfixOf` s
downloadProgress :: FilePath -> String -> Bool
downloadProgress :: HasTestEnv => FilePath -> String -> Bool
downloadProgress fileName s =
"Downloading file..." `isPrefixOf` s
&& "Decrypting file..." `isInfixOf` s
tests/XFTPClient.hs
+48 -45
View File
@@ -26,11 +26,14 @@ import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server
import System.Directory (createDirectoryIfMissing)
import Test.Hspec hiding (fit, it)
import Util
#if defined(dbServerPostgres)
import Control.Monad (void)
import qualified Database.PostgreSQL.Simple as PSQL
import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
import Database.PostgreSQL.Simple.Types (Query (..))
import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts)
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
@@ -44,7 +47,7 @@ data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerCo
updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig
updateXFTPCfg (AXFTPSrvCfg cfg) f = AXFTPSrvCfg (f cfg)
cfgFS :: AFStoreType -> AXFTPServerConfig
cfgFS :: HasTestEnv => AFStoreType -> AXFTPServerConfig
cfgFS (AFSType fs) = case fs of
SFSMemory -> AXFTPSrvCfg testXFTPServerConfig
#if defined(dbServerPostgres)
@@ -53,7 +56,7 @@ cfgFS (AFSType fs) = case fs of
SFSPostgres -> error "no postgres support"
#endif
cfgFS2 :: AFStoreType -> AXFTPServerConfig
cfgFS2 :: HasTestEnv => AFStoreType -> AXFTPServerConfig
cfgFS2 (AFSType fs) = case fs of
SFSMemory -> AXFTPSrvCfg testXFTPServerConfig2
#if defined(dbServerPostgres)
@@ -73,12 +76,12 @@ testXFTPDBConnectInfo =
connectDatabase = "test_xftp_server_db"
}
testXFTPPostgresCfg :: PostgresFileStoreCfg
testXFTPPostgresCfg :: HasTestEnv => PostgresFileStoreCfg
testXFTPPostgresCfg =
PostgresFileStoreCfg
{ dbOpts = defaultXFTPDBOpts
{ connstr = "postgresql://test_xftp_server_user@/test_xftp_server_db",
schema = "xftp_server_test",
schema = testSchemaName "xftp_server_test",
poolSize = 10,
createSchema = True
},
@@ -86,94 +89,94 @@ testXFTPPostgresCfg =
confirmMigrations = MCYesUp
}
clearXFTPPostgresStore :: IO ()
clearXFTPPostgresStore :: HasTestEnv => IO ()
clearXFTPPostgresStore = do
let DBOpts {connstr} = dbOpts testXFTPPostgresCfg
let DBOpts {connstr, schema} = dbOpts testXFTPPostgresCfg
conn <- PSQL.connectPostgreSQL connstr
void $ PSQL.execute_ conn "SET search_path TO xftp_server_test,public"
void $ PSQL.execute_ conn $ Query $ "SET search_path TO " <> schema <> ",public"
void $ PSQL.execute_ conn "DELETE FROM files"
PSQL.close conn
#endif
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> testXFTPClient test) `shouldReturn` ()
xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation
xftpTestN :: (HasCallStack, HasTestEnv) => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation
xftpTestN nClients test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> run nClients []) `shouldReturn` ()
where
run :: Int -> [XFTPClient] -> IO ()
run 0 hs = test hs
run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest2 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest2 test = xftpTestN 2 _test
where
_test [h1, h2] = test h1 h2
_test _ = error "expected 2 handles"
xftpTest4 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest4 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest4 test = xftpTestN 4 _test
where
_test [h1, h2, h3, h4] = test h1 h2 h3 h4
_test _ = error "expected 4 handles"
withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerStoreLogOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {serverStoreCfg = XSCMemory (Just testXFTPLogFile), storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
withXFTPServerCfgNoALPN :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}}
withXFTPServerCfg :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfg cfg =
withXFTPServerCfg cfg@XFTPServerConfig {filesPath} =
serverBracket
(\started -> runXFTPServerBlocking started cfg)
(\started -> createDirectoryIfMissing True filesPath >> runXFTPServerBlocking started cfg)
(threadDelay 10000)
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
withXFTPServer :: HasCallStack => IO a -> AFStoreType -> IO a
withXFTPServer :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a
withXFTPServer test fsType = withXFTPServerConfigOn (cfgFS fsType) $ const test
withXFTPServer2 :: HasCallStack => IO a -> AFStoreType -> IO a
withXFTPServer2 :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a
withXFTPServer2 test fsType = withXFTPServerConfigOn (cfgFS2 fsType) $ const test
-- Constants
xftpTestPort :: ServiceName
xftpTestPort = "8000"
xftpTestPort :: HasTestEnv => ServiceName
xftpTestPort = testServerPort 6
xftpTestPort2 :: ServiceName
xftpTestPort2 = "8001"
xftpTestPort2 :: HasTestEnv => ServiceName
xftpTestPort2 = testServerPort 7
testXFTPServer :: XFTPServer
testXFTPServer :: HasTestEnv => XFTPServer
testXFTPServer = fromString testXFTPServerStr
testXFTPServer2 :: XFTPServer
testXFTPServer2 :: HasTestEnv => XFTPServer
testXFTPServer2 = fromString testXFTPServerStr2
testXFTPServerStr :: String
testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000"
testXFTPServerStr :: HasTestEnv => String
testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort
testXFTPServerStr2 :: String
testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001"
testXFTPServerStr2 :: HasTestEnv => String
testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort2
xftpServerFiles :: FilePath
xftpServerFiles = "tests/tmp/xftp-server-files"
xftpServerFiles :: HasTestEnv => FilePath
xftpServerFiles = testPath "xftp-server-files"
xftpServerFiles2 :: FilePath
xftpServerFiles2 = "tests/tmp/xftp-server-files2"
xftpServerFiles2 :: HasTestEnv => FilePath
xftpServerFiles2 = testPath "xftp-server-files2"
testXFTPLogFile :: FilePath
testXFTPLogFile = "tests/tmp/xftp-server-store.log"
testXFTPLogFile :: HasTestEnv => FilePath
testXFTPLogFile = testPath "xftp-server-store.log"
testXFTPStatsBackupFile :: FilePath
testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
testXFTPStatsBackupFile :: HasTestEnv => FilePath
testXFTPStatsBackupFile = testPath "xftp-server-stats.log"
xftpTestPrometheusMetricsFile :: FilePath
xftpTestPrometheusMetricsFile = "tests/tmp/xftp-server-metrics.txt"
xftpTestPrometheusMetricsFile :: HasTestEnv => FilePath
xftpTestPrometheusMetricsFile = testPath "xftp-server-metrics.txt"
testXFTPServerConfig :: XFTPServerConfig STMFileStore
testXFTPServerConfig :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfig =
XFTPServerConfig
{ xftpPort = xftpTestPort,
@@ -204,7 +207,7 @@ testXFTPServerConfig =
information = Nothing,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
serverStatsLogFile = testPath "xftp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = xftpTestPrometheusMetricsFile,
@@ -213,23 +216,23 @@ testXFTPServerConfig =
webStaticPath = Nothing
}
testXFTPServerConfig2 :: XFTPServerConfig STMFileStore
testXFTPServerConfig2 :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfig2 = testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2}
testXFTPClientConfig :: XFTPClientConfig
testXFTPClientConfig = defaultXFTPClientConfig
testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient = testXFTPClientWith testXFTPClientConfig
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith :: (HasCallStack, HasTestEnv) => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith cfg client = do
ts <- getCurrentTime
getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case
Right c -> client c
Left e -> error $ show e
testXFTPServerConfigSNI :: XFTPServerConfig STMFileStore
testXFTPServerConfigSNI :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfigSNI =
testXFTPServerConfig
{ httpCredentials =
@@ -245,10 +248,10 @@ testXFTPServerConfigSNI =
}
}
withXFTPServerSNI :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerSNI :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerSNI = withXFTPServerCfg testXFTPServerConfigSNI
testXFTPServerConfigEd25519SNI :: XFTPServerConfig STMFileStore
testXFTPServerConfigEd25519SNI :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfigEd25519SNI =
testXFTPServerConfig
{ xftpCredentials =
tests/XFTPServerTests.hs
+50 -51
View File
@@ -47,7 +47,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
import Simplex.Messaging.Transport.Server (loadFileFingerprint)
import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
import System.Directory (removeFile)
import System.FilePath ((</>))
import Test.Hspec hiding (fit, it)
import UnliftIO.STM
@@ -55,8 +55,7 @@ import Util
import XFTPClient
xftpServerTests :: SpecWith AFStoreType
xftpServerTests =
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do
xftpServerTests = do
describe "XFTP file chunk delivery" $ do
it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
@@ -90,8 +89,8 @@ xftpServerTests =
chSize :: Integral a => a
chSize = kb 128
testChunkPath :: FilePath
testChunkPath = "tests/tmp/chunk1"
testChunkPath :: HasTestEnv => FilePath
testChunkPath = testPath "chunk1"
createTestChunk :: FilePath -> IO ByteString
createTestChunk fp = do
@@ -103,16 +102,16 @@ createTestChunk fp = do
createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing
readChunk :: XFTPFileId -> IO ByteString
readChunk :: HasTestEnv => XFTPFileId -> IO ByteString
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
testFileChunkDelivery :: AFStoreType -> Expectation
testFileChunkDelivery :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
testFileChunkDelivery2 :: AFStoreType -> Expectation
testFileChunkDelivery2 :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelivery :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelivery s r = do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -127,12 +126,12 @@ runTestFileChunkDelivery s r = do
uploadXFTPChunk s spKey sId' chunkSpec
`catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
liftIO $ readChunk sId `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk1") chSize (digest <> "_wrong"))
`catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
testFileChunkDeliveryAddRecipients :: AFStoreType -> Expectation
testFileChunkDeliveryAddRecipients :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -149,17 +148,17 @@ testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
let testReceiveChunk r rpKey rId fPath = do
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
liftIO $ B.readFile fPath `shouldReturn` bytes
testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1"
testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3"
testReceiveChunk r1 rpKey1 rId1 (testPath "received_chunk1")
testReceiveChunk r2 rpKey2 rId2 (testPath "received_chunk2")
testReceiveChunk r3 rpKey3 rId3 (testPath "received_chunk3")
testFileChunkDelete :: AFStoreType -> Expectation
testFileChunkDelete :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
testFileChunkDelete2 :: AFStoreType -> Expectation
testFileChunkDelete2 :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelete :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelete s r = do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -171,18 +170,18 @@ runTestFileChunkDelete s r = do
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
uploadXFTPChunk s spKey sId chunkSpec
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
deleteXFTPChunk s spKey sId
liftIO $
readChunk sId
`shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk s spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
testWrongChunkSize :: AFStoreType -> Expectation
testWrongChunkSize :: HasTestEnv => AFStoreType -> Expectation
testWrongChunkSize = xftpTest $ \c -> do
g <- C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -194,7 +193,7 @@ testWrongChunkSize = xftpTest $ \c -> do
void (createXFTPChunk c spKey file [rcvKey] Nothing)
`catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
testFileChunkExpiration :: AFStoreType -> Expectation
testFileChunkExpiration :: HasTestEnv => AFStoreType -> Expectation
testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration}) $
\_ -> testXFTPClient $ \c -> runRight_ $ do
g <- liftIO C.newRandom
@@ -207,18 +206,18 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
uploadXFTPChunk c spKey sId chunkSpec
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
liftIO $ threadDelay 1000000
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk c spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
where
fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1}
testInactiveClientExpiration :: AFStoreType -> Expectation
testInactiveClientExpiration :: HasTestEnv => AFStoreType -> Expectation
testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do
disconnected <- newEmptyTMVarIO
ts <- liftIO getCurrentTime
@@ -234,7 +233,7 @@ testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfg
where
inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
testFileStorageQuota :: AFStoreType -> Expectation
testFileStorageQuota :: HasTestEnv => AFStoreType -> Expectation
testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileSizeQuota = Just $ chSize * 2}) $
\_ -> testXFTPClient $ \c -> runRight_ $ do
g <- liftIO C.newRandom
@@ -245,8 +244,8 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp
let file = FileInfo {sndKey, size = chSize, digest}
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
download rId = do
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
uploadXFTPChunk c spKey sId1 chunkSpec
download rId1
@@ -262,7 +261,7 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp
uploadXFTPChunk c spKey sId3 chunkSpec
download rId3
testFileLog :: AFStoreType -> Expectation
testFileLog :: HasTestEnv => AFStoreType -> Expectation
testFileLog _ = do
g <- C.newRandom
bytes <- liftIO $ createTestChunk testChunkPath
@@ -298,9 +297,9 @@ testFileLog _ = do
rId1 <- liftIO $ readTVarIO rIdVar1
rId2 <- liftIO $ readTVarIO rIdVar2
-- recipients and sender get AUTH error because server restarted without log
downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk c spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -331,10 +330,10 @@ testFileLog _ = do
removeFile testXFTPStatsBackupFile
where
download g c rpKey rId digest bytes = do
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO ()
testFileBasicAuth :: HasTestEnv => Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO ()
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType =
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {allowNewFiles, newFileBasicAuth}) $
\_ -> testXFTPClient $ \c -> do
@@ -350,13 +349,13 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType =
then do
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
uploadXFTPChunk c spKey sId chunkSpec
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest
liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes
else do
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
testFileSkipCommitted :: AFStoreType -> IO ()
testFileSkipCommitted :: HasTestEnv => AFStoreType -> IO ()
testFileSkipCommitted fsType =
withXFTPServerConfigOn (cfgFS fsType) $
\_ -> testXFTPClient $ \c -> do
@@ -372,8 +371,8 @@ testFileSkipCommitted fsType =
uploadXFTPChunk c spKey sId chunkSpec
void . liftIO $ createTestChunk testChunkPath -- trash chunk contents
uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest
liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes -- new chunk content got ignored
-- SNI and CORS tests
@@ -386,7 +385,7 @@ getCerts tls =
let X.CertificateChain cc = tlsPeerCert tls
in map (X.signedObject . X.getSigned) cc
testSNICertSelection :: Expectation
testSNICertSelection :: HasTestEnv => Expectation
testSNICertSelection =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -399,7 +398,7 @@ testSNICertSelection =
leaf : _ -> expectationFailure $ "Expected RSA cert, got: " <> show (X.certPubKey leaf)
[] -> expectationFailure "Empty certificate chain"
testNoSNICertSelection :: Expectation
testNoSNICertSelection :: HasTestEnv => Expectation
testNoSNICertSelection =
withXFTPServerSNI $ \_ -> do
Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
@@ -412,7 +411,7 @@ testNoSNICertSelection =
leaf : _ -> expectationFailure $ "Expected Ed448 cert, got: " <> show (X.certPubKey leaf)
[] -> expectationFailure "Empty certificate chain"
testCORSHeaders :: Expectation
testCORSHeaders :: HasTestEnv => Expectation
testCORSHeaders =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -426,7 +425,7 @@ testCORSHeaders =
lookupResponseHeader "access-control-allow-origin" response `shouldBe` Just "*"
lookupResponseHeader "access-control-expose-headers" response `shouldBe` Just "*"
testCORSPreflight :: Expectation
testCORSPreflight :: HasTestEnv => Expectation
testCORSPreflight =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -442,7 +441,7 @@ testCORSPreflight =
lookupResponseHeader "access-control-allow-headers" response `shouldBe` Just "*"
lookupResponseHeader "access-control-max-age" response `shouldBe` Just "86400"
testNoCORSWithoutSNI :: Expectation
testNoCORSWithoutSNI :: HasTestEnv => Expectation
testNoCORSWithoutSNI =
withXFTPServerSNI $ \_ -> do
Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
@@ -455,11 +454,11 @@ testNoCORSWithoutSNI =
HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000)
lookupResponseHeader "access-control-allow-origin" response `shouldBe` Nothing
testFileChunkDeliverySNI :: Expectation
testFileChunkDeliverySNI :: HasTestEnv => Expectation
testFileChunkDeliverySNI =
withXFTPServerSNI $ \_ -> testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelivery c c
testWebHandshake :: Expectation
testWebHandshake :: HasTestEnv => Expectation
testWebHandshake =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -501,7 +500,7 @@ testWebHandshake =
let ackBody = bodyHead (HC.respBody resp2)
B.length ackBody `shouldBe` 0
testWebReHandshake :: Expectation
testWebReHandshake :: HasTestEnv => Expectation
testWebReHandshake =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -535,7 +534,7 @@ testWebReHandshake =
resp2b <- either (error . show) pure =<< HC.sendRequest h2 (H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded) (Just 5000000)
B.length (bodyHead (HC.respBody resp2b)) `shouldBe` 0
testStaleWebSession :: Expectation
testStaleWebSession :: HasTestEnv => Expectation
testStaleWebSession =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
tests/XFTPWebTests.hs
+39 -44
View File
@@ -51,7 +51,6 @@ import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAge
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers)
import Simplex.Messaging.Agent.Protocol (AEvent (..))
import SMPAgentClient (agentCfg, initAgentServers, testDB)
import XFTPCLI (recipientFiles, senderFiles, testBracket)
import qualified Simplex.Messaging.Crypto.File as CF
xftpWebDir :: FilePath
@@ -168,8 +167,8 @@ impAddr = "import * as Addr from './dist/protocol/address.js';"
jsOut :: String -> String
jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));"
xftpWebTests :: IO () -> Spec
xftpWebTests dbCleanup = do
xftpWebTests :: Spec
xftpWebTests = do
xftpWebSourceHygieneTests
distExists <- runIO $ doesDirectoryExist (xftpWebDir <> "/dist")
if distExists
@@ -189,7 +188,7 @@ xftpWebTests dbCleanup = do
tsClientTests
tsDownloadTests
tsAddressTests
tsIntegrationTests dbCleanup
tsIntegrationTests
else
it "skipped (run 'cd xftp-web && npm install && npm run build' first)" $
pendingWith "TS project not compiled"
@@ -768,7 +767,7 @@ tsSecretboxTests :: Spec
tsSecretboxTests = describe "crypto/secretbox" $ do
let key32 = B.pack [1 .. 32]
nonce24 = B.pack [1 .. 24]
cbNonceVal = C.cbNonce nonce24
cbNonceVal = C.unsafeCbNonce nonce24
sbKeyVal = C.unsafeSbKey key32
describe "NaCl secretbox (tag prepended)" $ do
@@ -979,7 +978,7 @@ tsFileCryptoTests :: Spec
tsFileCryptoTests = describe "crypto/file" $ do
let key32 = B.pack [1 .. 32]
nonce24 = B.pack [1 .. 24]
cbNonceVal = C.cbNonce nonce24
cbNonceVal = C.unsafeCbNonce nonce24
sbKeyVal = C.unsafeSbKey key32
describe "FileHeader encoding" $ do
@@ -2329,7 +2328,7 @@ tsClientTests = describe "protocol/client" $ do
C.cbAuthenticate
(C.PublicKeyX25519 pubA)
(C.PrivateKeyX25519 privB)
(C.cbNonce nonce24)
(C.unsafeCbNonce nonce24)
msg
tsResult <-
callNode $
@@ -2352,7 +2351,7 @@ tsClientTests = describe "protocol/client" $ do
C.cbAuthenticate
(C.PublicKeyX25519 pubA)
(C.PrivateKeyX25519 privB)
(C.cbNonce nonce24)
(C.unsafeCbNonce nonce24)
msg
B.length expected `shouldBe` 80
@@ -2363,7 +2362,7 @@ tsClientTests = describe "protocol/client" $ do
C.cbAuthenticate
(C.PublicKeyX25519 pubA)
(C.PrivateKeyX25519 privB)
(C.cbNonce nonce24)
(C.unsafeCbNonce nonce24)
msg
tsResult <-
callNode $
@@ -2389,7 +2388,7 @@ tsClientTests = describe "protocol/client" $ do
C.cbAuthenticate
(C.PublicKeyX25519 pubA)
(C.PrivateKeyX25519 privB)
(C.cbNonce nonce24)
(C.unsafeCbNonce nonce24)
msg
tsResult <-
callNode $
@@ -2427,7 +2426,7 @@ tsClientTests = describe "protocol/client" $ do
C.cbVerify
(C.PublicKeyX25519 pubB)
(C.PrivateKeyX25519 privA)
(C.cbNonce nonce24)
(C.unsafeCbNonce nonce24)
(C.CbAuthenticator tsAuth)
msg
hsValid `shouldBe` True
@@ -2438,7 +2437,7 @@ tsClientTests = describe "protocol/client" $ do
it "encryptTransportChunk matches Haskell" $ do
let plaintext = B.pack [100 .. 199]
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 plaintext
tag = BA.convert $ LC.sbAuth state1 :: B.ByteString
expected = cipher <> tag
@@ -2457,7 +2456,7 @@ tsClientTests = describe "protocol/client" $ do
it "decryptTransportChunk decrypts Haskell-encrypted data" $ do
let plaintext = B.pack ([200 .. 255] <> [0 .. 99])
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 plaintext
tag = BA.convert $ LC.sbAuth state1 :: B.ByteString
encData = cipher <> tag
@@ -2542,7 +2541,7 @@ tsDownloadTests = describe "download" $ do
-- File-level key/nonce (different from transport)
fileKey32 = B.pack [1 .. 32]
fileNonce24 = B.pack [1 .. 24]
fileCbNonce = C.cbNonce fileNonce24
fileCbNonce = C.unsafeCbNonce fileNonce24
fileSbKey = C.unsafeSbKey fileKey32
describe "processFileResponse" $ do
@@ -2568,7 +2567,7 @@ tsDownloadTests = describe "download" $ do
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
chunkData = B.pack [50 .. 149]
chunkDigest = C.sha256Hash chunkData
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
encData = cipher <> tag
@@ -2592,7 +2591,7 @@ tsDownloadTests = describe "download" $ do
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
chunkData = B.pack [50 .. 149]
wrongDigest = B.replicate 32 0xff
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
encData = cipher <> tag
@@ -2615,7 +2614,7 @@ tsDownloadTests = describe "download" $ do
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
chunkData = B.pack [10 .. 50]
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
encData = cipher <> tag
@@ -2652,7 +2651,7 @@ tsDownloadTests = describe "download" $ do
-- Step 2: transport-level encryption (simulates server sending chunk)
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
dhSecretBytes = case dhSecret of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
ts0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
ts0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(transportCipher, ts1) = LC.sbEncryptChunk ts0 fileEncrypted
transportTag = BA.convert (LC.sbAuth ts1) :: B.ByteString
transportEncData = transportCipher <> transportTag
@@ -2702,7 +2701,7 @@ tsDownloadTests = describe "download" $ do
dhSecret1 = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
dhSecret1Bytes = case dhSecret1 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
nonce1 = nonce24
t1s0 = either (error . show) id $ LC.cbInit dhSecret1 (C.cbNonce nonce1)
t1s0 = either (error . show) id $ LC.cbInit dhSecret1 (C.unsafeCbNonce nonce1)
(t1cipher, t1s1) = LC.sbEncryptChunk t1s0 fileChunk1
t1tag = BA.convert (LC.sbAuth t1s1) :: B.ByteString
transportEnc1 = t1cipher <> t1tag
@@ -2710,7 +2709,7 @@ tsDownloadTests = describe "download" $ do
nonce2 = B.pack [24 .. 47]
dhSecret2 = C.dh' (C.PublicKeyX25519 pubB) (C.PrivateKeyX25519 privA)
dhSecret2Bytes = case dhSecret2 of C.DhSecretX25519 k -> BA.convert k :: B.ByteString
t2s0 = either (error . show) id $ LC.cbInit dhSecret2 (C.cbNonce nonce2)
t2s0 = either (error . show) id $ LC.cbInit dhSecret2 (C.unsafeCbNonce nonce2)
(t2cipher, t2s1) = LC.sbEncryptChunk t2s0 fileChunk2
t2tag = BA.convert (LC.sbAuth t2s1) :: B.ByteString
transportEnc2 = t2cipher <> t2tag
@@ -2748,7 +2747,7 @@ tsDownloadTests = describe "download" $ do
-- Client side: generate FGET command
let dhSecret = C.dh' (C.PublicKeyX25519 pubA) (C.PrivateKeyX25519 privB)
chunkData = "FGET round-trip test data" :: B.ByteString
state0 = either (error . show) id $ LC.cbInit dhSecret (C.cbNonce nonce24)
state0 = either (error . show) id $ LC.cbInit dhSecret (C.unsafeCbNonce nonce24)
(cipher, state1) = LC.sbEncryptChunk state0 chunkData
tag = BA.convert (LC.sbAuth state1) :: B.ByteString
encData = cipher <> tag
@@ -2847,9 +2846,8 @@ tsAddressTests = describe "protocol/address" $ do
-- ── integration ───────────────────────────────────────────────────
tsIntegrationTests :: IO () -> Spec
tsIntegrationTests dbCleanup = describe "integration" $
around_ testBracket . after_ dbCleanup $ do
tsIntegrationTests :: Spec
tsIntegrationTests = describe "integration" $ do
it "web handshake with Ed25519 identity verification" $
webHandshakeTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
it "web handshake with Ed448 identity verification" $
@@ -2872,7 +2870,7 @@ tsIntegrationTests dbCleanup = describe "integration" $
it "cross-language: Haskell upload, TS download" $
haskellUploadTsDownloadTest testXFTPServerConfigSNI
webHandshakeTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
webHandshakeTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
webHandshakeTest cfg caFile = do
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -2914,7 +2912,7 @@ webHandshakeTest cfg caFile = do
<> jsOut "new Uint8Array([idOk ? 1 : 0, ack.length === 0 ? 1 : 0])"
result `shouldBe` B.pack [1, 1]
pingTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
pingTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
pingTest cfg caFile = do
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -2936,9 +2934,8 @@ pingTest cfg caFile = do
<> jsOut "new Uint8Array([1])"
result `shouldBe` B.pack [1]
fullRoundTripTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
fullRoundTripTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
fullRoundTripTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3017,9 +3014,8 @@ agentURIRoundTripTest = do
<> jsOut "new Uint8Array([match])"
result `shouldBe` B.pack [1]
agentUploadDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentUploadDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentUploadDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3050,9 +3046,8 @@ agentUploadDownloadTest cfg caFile = do
<> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])"
result `shouldBe` B.pack [1, 1, 1]
agentDeleteTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentDeleteTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentDeleteTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3082,9 +3077,8 @@ agentDeleteTest cfg caFile = do
<> jsOut "new Uint8Array([deleted])"
result `shouldBe` B.pack [1]
agentRedirectTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentRedirectTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentRedirectTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3116,9 +3110,8 @@ agentRedirectTest cfg caFile = do
<> jsOut "new Uint8Array([hasRedirect, nameMatch, sizeMatch, dataMatch])"
result `shouldBe` B.pack [1, 1, 1, 1]
tsUploadHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadHaskellDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False recipientFiles
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -3151,9 +3144,8 @@ tsUploadHaskellDownloadTest cfg caFile = do
downloadedData <- B.readFile outPath
downloadedData `shouldBe` originalData
tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadRedirectHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadRedirectHaskellDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False recipientFiles
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -3186,9 +3178,8 @@ tsUploadRedirectHaskellDownloadTest cfg caFile = do
downloadedData <- B.readFile outPath
downloadedData `shouldBe` originalData
haskellUploadTsDownloadTest :: XFTPServerConfig STMFileStore -> Expectation
haskellUploadTsDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> Expectation
haskellUploadTsDownloadTest cfg = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False senderFiles
let filePath = senderFiles <> "/hs-to-ts.bin"
originalData <- B.pack <$> replicateM 50000 (randomIO :: IO Word8)
@@ -3201,8 +3192,8 @@ haskellUploadTsDownloadTest cfg = do
(_, _, SFDONE _ [rfd] _) <- sfGet sndr
pure rfd
let yamlDesc = strEncode vfd
tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"
tmpData = "tests/tmp/hs-to-ts-data.bin"
tmpYaml = testPath "hs-to-ts-desc.yaml"
tmpData = testPath "hs-to-ts-data.bin"
B.writeFile tmpYaml yamlDesc
B.writeFile tmpData originalData
result <-
@@ -3212,8 +3203,12 @@ haskellUploadTsDownloadTest cfg = do
\import * as Agent from './dist/agent.js';\
\import {decodeFileDescription, validateFileDescription} from './dist/protocol/description.js';\
\await sodium.ready;\
\const yaml = fs.readFileSync('../tests/tmp/hs-to-ts-desc.yaml', 'utf-8');\
\const expected = new Uint8Array(fs.readFileSync('../tests/tmp/hs-to-ts-data.bin'));\
\const yaml = fs.readFileSync('../"
<> tmpYaml
<> "', 'utf-8');\
\const expected = new Uint8Array(fs.readFileSync('../"
<> tmpData
<> "'));\
\const fd = decodeFileDescription(yaml);\
\const err = validateFileDescription(fd);\
\if (err) throw new Error(err);\