mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
Compare commits
19
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Evgeny Poberezkin
|
7fad02b62d | ||
|
Evgeny Poberezkin
|
f7cbbf300f | ||
|
Evgeny Poberezkin
|
1ff0e1a498 | ||
|
Evgeny Poberezkin
|
6855711c75 | ||
|
Evgeny Poberezkin
|
2965b69981 | ||
|
Evgeny Poberezkin
|
e62314a802 | ||
|
Evgeny Poberezkin
|
7a25174866 | ||
|
Evgeny Poberezkin
|
c8cc2f262b | ||
|
Evgeny Poberezkin
|
14aed2dda7 | ||
|
Evgeny Poberezkin
|
a319a377a1 | ||
|
Evgeny Poberezkin
|
bd5e1847c4 | ||
|
Evgeny Poberezkin
|
3af3f475cf | ||
|
Evgeny Poberezkin
|
45a78639d8 | ||
|
Evgeny Poberezkin
|
6b37c53d15 | ||
|
Evgeny Poberezkin
|
dfa77a1efa | ||
|
Evgeny Poberezkin
|
f3fc087800 | ||
|
Evgeny Poberezkin
|
38a4a4faf5 | ||
|
Evgeny Poberezkin
|
8b656d7dc5 | ||
|
Evgeny Poberezkin
|
1bdf8bc3e3 |
@@ -1,44 +0,0 @@
|
||||
name: 'Set Swap Space'
|
||||
description: 'Add moar swap'
|
||||
branding:
|
||||
icon: 'crop'
|
||||
color: 'orange'
|
||||
inputs:
|
||||
swap-size-gb:
|
||||
description: 'Swap space to create, in Gigabytes.'
|
||||
required: false
|
||||
default: '10'
|
||||
runs:
|
||||
using: "composite"
|
||||
steps:
|
||||
- name: Swap space report before modification
|
||||
shell: bash
|
||||
run: |
|
||||
echo "Memory and swap:"
|
||||
free -h
|
||||
echo
|
||||
swapon --show
|
||||
echo
|
||||
- name: Set Swap
|
||||
shell: bash
|
||||
run: |
|
||||
export SWAP_FILE=$(swapon --show=NAME | tail -n 1)
|
||||
echo "Swap file: $SWAP_FILE"
|
||||
if [ -z "$SWAP_FILE" ]; then
|
||||
SWAP_FILE=/opt/swapfile
|
||||
else
|
||||
sudo swapoff $SWAP_FILE
|
||||
sudo rm $SWAP_FILE
|
||||
fi
|
||||
sudo fallocate -l ${{ inputs.swap-size-gb }}G $SWAP_FILE
|
||||
sudo chmod 600 $SWAP_FILE
|
||||
sudo mkswap $SWAP_FILE
|
||||
sudo swapon $SWAP_FILE
|
||||
- name: Swap space report after modification
|
||||
shell: bash
|
||||
run: |
|
||||
echo "Memory and swap:"
|
||||
free -h
|
||||
echo
|
||||
swapon --show
|
||||
echo
|
||||
+57
-232
@@ -10,25 +10,62 @@ on:
|
||||
pull_request:
|
||||
|
||||
jobs:
|
||||
|
||||
# =============================
|
||||
# Create release
|
||||
# =============================
|
||||
|
||||
# Create release, but only if it's triggered by tag push.
|
||||
# On pull requests/commits push, this job will always complete.
|
||||
|
||||
maybe-release:
|
||||
runs-on: ubuntu-latest
|
||||
build:
|
||||
name: build-${{ matrix.os }}-${{ matrix.ghc }}
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
include:
|
||||
- os: ubuntu-20.04
|
||||
platform_name: 20_04-x86-64
|
||||
ghc: "8.10.7"
|
||||
- os: ubuntu-20.04
|
||||
platform_name: 20_04-x86-64
|
||||
ghc: "9.6.3"
|
||||
- os: ubuntu-22.04
|
||||
platform_name: 22_04-x86-64
|
||||
ghc: "9.6.3"
|
||||
steps:
|
||||
- name: Clone project
|
||||
if: startsWith(github.ref, 'refs/tags/v')
|
||||
uses: actions/checkout@v3
|
||||
|
||||
- name: Build changelog
|
||||
id: build_changelog
|
||||
- name: Setup Haskell
|
||||
uses: haskell-actions/setup@v2
|
||||
with:
|
||||
ghc-version: ${{ matrix.ghc }}
|
||||
cabal-version: "3.10.1.0"
|
||||
|
||||
- name: Cache dependencies
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
path: |
|
||||
~/.cabal/store
|
||||
dist-newstyle
|
||||
key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
|
||||
|
||||
- name: Build
|
||||
shell: bash
|
||||
run: cabal build --enable-tests
|
||||
|
||||
- name: Test
|
||||
timeout-minutes: 40
|
||||
shell: bash
|
||||
run: cabal test --test-show-details=direct
|
||||
|
||||
- name: Prepare binaries
|
||||
if: startsWith(github.ref, 'refs/tags/v')
|
||||
uses: simplex-chat/release-changelog-builder-action@v5
|
||||
shell: bash
|
||||
run: |
|
||||
mv $(cabal list-bin smp-server) smp-server-ubuntu-${{ matrix.platform_name}}
|
||||
mv $(cabal list-bin ntf-server) ntf-server-ubuntu-${{ matrix.platform_name}}
|
||||
mv $(cabal list-bin xftp-server) xftp-server-ubuntu-${{ matrix.platform_name}}
|
||||
mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
|
||||
|
||||
- name: Build changelog
|
||||
if: startsWith(github.ref, 'refs/tags/v')
|
||||
id: build_changelog
|
||||
uses: mikepenz/release-changelog-builder-action@v1
|
||||
with:
|
||||
configuration: .github/changelog_conf.json
|
||||
failOnError: true
|
||||
@@ -38,8 +75,8 @@ jobs:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
- name: Create release
|
||||
if: startsWith(github.ref, 'refs/tags/v')
|
||||
uses: simplex-chat/action-gh-release@v2
|
||||
if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7'
|
||||
uses: softprops/action-gh-release@v1
|
||||
with:
|
||||
body: |
|
||||
See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md).
|
||||
@@ -49,222 +86,10 @@ jobs:
|
||||
prerelease: true
|
||||
files: |
|
||||
LICENSE
|
||||
smp-server-ubuntu-${{ matrix.platform_name}}
|
||||
ntf-server-ubuntu-${{ matrix.platform_name}}
|
||||
xftp-server-ubuntu-${{ matrix.platform_name}}
|
||||
xftp-ubuntu-${{ matrix.platform_name}}
|
||||
fail_on_unmatched_files: true
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
# =============================
|
||||
# Main build job
|
||||
# =============================
|
||||
|
||||
build:
|
||||
name: "ubuntu-${{ matrix.os }}, GHC: ${{ matrix.ghc }}"
|
||||
needs: maybe-release
|
||||
env:
|
||||
apps: "smp-server xftp-server ntf-server xftp"
|
||||
runs-on: ubuntu-${{ matrix.os }}
|
||||
services:
|
||||
postgres:
|
||||
image: postgres:15
|
||||
env:
|
||||
POSTGRES_HOST_AUTH_METHOD: trust # Allows passwordless access
|
||||
options: >-
|
||||
--health-cmd pg_isready
|
||||
--health-interval 10s
|
||||
--health-timeout 5s
|
||||
--health-retries 5
|
||||
ports:
|
||||
# Maps tcp port 5432 on service container to the host
|
||||
- 5432:5432
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
include:
|
||||
- os: 22.04
|
||||
ghc: "8.10.7"
|
||||
platform_name: 22_04-8.10.7
|
||||
should_run: ${{ !(github.ref == 'refs/heads/stable' || startsWith(github.ref, 'refs/tags/v')) }}
|
||||
- os: 22.04
|
||||
ghc: "9.6.3"
|
||||
platform_name: 22_04-x86-64
|
||||
should_run: true
|
||||
- os: 24.04
|
||||
ghc: "9.6.3"
|
||||
platform_name: 24_04-x86-64
|
||||
should_run: true
|
||||
steps:
|
||||
- name: Clone project
|
||||
if: matrix.should_run == true
|
||||
uses: actions/checkout@v3
|
||||
|
||||
- name: Set up Docker Buildx
|
||||
if: matrix.should_run == true
|
||||
uses: simplex-chat/docker-setup-buildx-action@v3
|
||||
|
||||
- name: Setup swap
|
||||
if: matrix.ghc == '8.10.7' && matrix.should_run == true
|
||||
uses: ./.github/actions/swap
|
||||
with:
|
||||
swap-size-gb: 20
|
||||
|
||||
- name: Install PostgreSQL 15 client tools
|
||||
if: matrix.os == '22.04' && matrix.should_run == true
|
||||
shell: bash
|
||||
run: |
|
||||
# Import the repository signing key
|
||||
sudo install -d /usr/share/postgresql-common/pgdg
|
||||
sudo curl -o /usr/share/postgresql-common/pgdg/apt.postgresql.org.asc --fail https://www.postgresql.org/media/keys/ACCC4CF8.asc
|
||||
# Add the PostgreSQL APT repository
|
||||
sudo sh -c 'echo "deb [signed-by=/usr/share/postgresql-common/pgdg/apt.postgresql.org.asc] https://apt.postgresql.org/pub/repos/apt $(lsb_release -cs)-pgdg main" > /etc/apt/sources.list.d/pgdg.list'
|
||||
# Update repository and install postgresql tools
|
||||
sudo apt update
|
||||
sudo apt -y install postgresql-client-15
|
||||
|
||||
- name: Build and cache Docker image
|
||||
if: matrix.should_run == true
|
||||
uses: simplex-chat/docker-build-push-action@v6
|
||||
with:
|
||||
context: .
|
||||
load: true
|
||||
file: Dockerfile.build
|
||||
tags: build/${{ matrix.platform_name }}:latest
|
||||
cache-from: |
|
||||
type=gha
|
||||
type=gha,scope=master
|
||||
cache-to: type=gha,mode=max
|
||||
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: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
|
||||
|
||||
- name: Start container
|
||||
if: matrix.should_run == true
|
||||
shell: bash
|
||||
run: |
|
||||
docker run -t -d \
|
||||
--name builder \
|
||||
-v ~/.cabal:/root/.cabal \
|
||||
-v /home/runner/work/_temp:/home/runner/work/_temp \
|
||||
-v ${{ github.workspace }}:/project \
|
||||
build/${{ matrix.platform_name }}:latest
|
||||
|
||||
- name: Build smp-server (postgresql) and tests
|
||||
if: matrix.should_run == true
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: |
|
||||
cabal update
|
||||
cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
|
||||
mkdir -p /out
|
||||
for i in smp-server simplexmq-test; do
|
||||
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
|
||||
chmod +x "$bin"
|
||||
mv "$bin" /out/
|
||||
done
|
||||
strip /out/smp-server
|
||||
|
||||
- name: Copy simplexmq-test from container
|
||||
if: matrix.should_run == true
|
||||
shell: bash
|
||||
run: |
|
||||
docker cp builder:/out/simplexmq-test .
|
||||
|
||||
- name: Copy smp-server (postgresql) from container and prepare it
|
||||
if: startsWith(github.ref, 'refs/tags/v') && matrix.should_run == true
|
||||
id: prepare-postgres
|
||||
shell: bash
|
||||
run: |
|
||||
name="smp-server-postgres-ubuntu-${{ matrix.platform_name }}"
|
||||
docker cp builder:/out/smp-server $name
|
||||
|
||||
path="${{ github.workspace }}/$name"
|
||||
echo "bin=$path" >> $GITHUB_OUTPUT
|
||||
|
||||
hash="SHA2-256($name)= $(openssl sha256 $path | cut -d' ' -f 2)"
|
||||
printf 'hash=%s' "$hash" >> $GITHUB_OUTPUT
|
||||
|
||||
- name: Build everything else (standard)
|
||||
if: matrix.should_run == true
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: |
|
||||
cabal build --jobs=$(nproc)
|
||||
mkdir -p /out
|
||||
for i in ${{ env.apps }}; do
|
||||
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
|
||||
strip "$bin"
|
||||
chmod +x "$bin"
|
||||
mv "$bin" /out/
|
||||
done
|
||||
|
||||
- name: Copy binaries from container and prepare them
|
||||
id: prepare-regular
|
||||
if: startsWith(github.ref, 'refs/tags/v') && matrix.should_run == true
|
||||
shell: bash
|
||||
run: |
|
||||
docker cp builder:/out .
|
||||
|
||||
printf 'bins<<EOF\n' > bins.output
|
||||
printf 'hashes<<EOF\n' > hashes.output
|
||||
for i in ${{ env.apps }}; do
|
||||
mv ./out/$i ./$i-ubuntu-${{ matrix.platform_name }}
|
||||
|
||||
name="$i-ubuntu-${{ matrix.platform_name }}"
|
||||
|
||||
path="${{ github.workspace }}/$name"
|
||||
hash="SHA2-256($name)= $(openssl sha256 $path | cut -d' ' -f 2)"
|
||||
|
||||
printf '%s\n' "$path" >> bins.output
|
||||
printf '%s\n\n' "$hash" >> hashes.output
|
||||
done
|
||||
printf 'EOF\n' >> bins.output
|
||||
printf 'EOF\n' >> hashes.output
|
||||
|
||||
cat bins.output >> "$GITHUB_OUTPUT"
|
||||
cat hashes.output >> "$GITHUB_OUTPUT"
|
||||
|
||||
- name: Upload binaries
|
||||
if: startsWith(github.ref, 'refs/tags/v') && matrix.should_run == true
|
||||
uses: simplex-chat/action-gh-release@v2
|
||||
with:
|
||||
append_body: true
|
||||
prerelease: true
|
||||
fail_on_unmatched_files: true
|
||||
body: |
|
||||
${{ steps.prepare-regular.outputs.hashes }}
|
||||
${{ steps.prepare-postgres.outputs.hash }}
|
||||
files: |
|
||||
${{ steps.prepare-regular.outputs.bins }}
|
||||
${{ steps.prepare-postgres.outputs.bin }}
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
- name: Test
|
||||
if: matrix.should_run == true
|
||||
timeout-minutes: 120
|
||||
shell: bash
|
||||
env:
|
||||
PGHOST: localhost
|
||||
run: |
|
||||
i=1
|
||||
attempts=1
|
||||
${{ (github.ref == 'refs/heads/stable' || startsWith(github.ref, 'refs/tags/v')) }} && attempts=3
|
||||
while [ "$i" -le "$attempts" ]; do
|
||||
if ./simplexmq-test; then
|
||||
break
|
||||
else
|
||||
echo "Attempt $i failed, retrying..."
|
||||
i=$((i + 1))
|
||||
sleep 1
|
||||
fi
|
||||
done
|
||||
if [ "$i" -gt "$attempts" ]; then
|
||||
echo "All "$attempts" attempts failed."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
@@ -22,14 +22,14 @@ jobs:
|
||||
uses: actions/checkout@v4
|
||||
|
||||
- name: Log in to Docker Hub
|
||||
uses: simplex-chat/docker-login-action@v3
|
||||
uses: docker/login-action@v3
|
||||
with:
|
||||
username: ${{ secrets.DOCKERHUB_USERNAME }}
|
||||
password: ${{ secrets.DOCKERHUB_PASSWORD }}
|
||||
|
||||
- name: Extract metadata for Docker image
|
||||
id: meta
|
||||
uses: simplex-chat/docker-metadata-action@v5
|
||||
uses: docker/metadata-action@v5
|
||||
with:
|
||||
images: ${{ secrets.DOCKERHUB_USERNAME }}/${{ matrix.app }}
|
||||
flavor: |
|
||||
@@ -40,7 +40,7 @@ jobs:
|
||||
type=semver,pattern=v{{major}}
|
||||
|
||||
- name: Build and push Docker image
|
||||
uses: simplex-chat/docker-build-push-action@v6
|
||||
uses: docker/build-push-action@v6
|
||||
with:
|
||||
push: true
|
||||
build-args: |
|
||||
|
||||
@@ -1,45 +0,0 @@
|
||||
name: Reproduce latest release
|
||||
|
||||
on:
|
||||
workflow_dispatch:
|
||||
schedule:
|
||||
- cron: '0 2 * * *' # every day at 02:00 night
|
||||
|
||||
jobs:
|
||||
reproduce:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- name: Checkout code
|
||||
uses: actions/checkout@v3
|
||||
|
||||
- name: Get latest release
|
||||
shell: bash
|
||||
run: |
|
||||
curl --proto '=https' \
|
||||
--tlsv1.2 \
|
||||
-sSf -L \
|
||||
'https://api.github.com/repos/simplex-chat/simplexmq/releases/latest' \
|
||||
2>/dev/null | \
|
||||
grep -i "tag_name" | \
|
||||
awk -F \" '{print "TAG="$4}' >> $GITHUB_ENV
|
||||
|
||||
- name: Execute reproduce script
|
||||
run: |
|
||||
${GITHUB_WORKSPACE}/scripts/reproduce-builds.sh "$TAG"
|
||||
|
||||
- name: Check if build has been reproduced
|
||||
env:
|
||||
url: ${{ secrets.STATUS_SIMPLEX_WEBHOOK_URL }}
|
||||
user: ${{ secrets.STATUS_SIMPLEX_WEBHOOK_USER }}
|
||||
pass: ${{ secrets.STATUS_SIMPLEX_WEBHOOK_PASS }}
|
||||
run: |
|
||||
if [ -f "${GITHUB_WORKSPACE}/$TAG/_sha256sums" ]; then
|
||||
exit 0
|
||||
else
|
||||
curl --proto '=https' --tlsv1.2 -sSf \
|
||||
-u "${user}:${pass}" \
|
||||
-H 'Content-Type: application/json' \
|
||||
-d '{"title": "👾 GitHub: Runner", "description": "⛔️ '"$TAG"' did not reproduce."}' \
|
||||
"$url"
|
||||
exit 1
|
||||
fi
|
||||
+1
-70
@@ -1,72 +1,3 @@
|
||||
# 6.4.1
|
||||
|
||||
SMP protocol:
|
||||
- create notification credentials via NEW command that creates the queue (#1586)
|
||||
|
||||
SMP server:
|
||||
- control port session improvements (#1591)
|
||||
- additional stat counter for ntf credentials created together with the queue (#1589)
|
||||
|
||||
# 6.4.0
|
||||
|
||||
SMP protocol (server/client):
|
||||
- support associated queue data and short connection links (see [RFC](./rfcs/2025-03-16-smp-queues.md)).
|
||||
- service certificates to optimize subscriptions.
|
||||
|
||||
SMP agent:
|
||||
- support retries for interactive connection handshakes.
|
||||
- use web port 443 by default for preset servers.
|
||||
- use static RNG function to avoid creating dynamic C stubs when generating sntrup keys (it was detected as Dynamic Code Loading in GrapheneOS).
|
||||
- different timeouts for interactive and background operations.
|
||||
|
||||
Ntf server:
|
||||
- PostgreSQL storage.
|
||||
- Prometheus metrics.
|
||||
- use service certificates.
|
||||
- fix repeat token registration.
|
||||
|
||||
# 6.3.2
|
||||
|
||||
Servers:
|
||||
- enable store log by default (#1501).
|
||||
|
||||
SMP server:
|
||||
- reduce memory usage (#1498)
|
||||
|
||||
SMP agent:
|
||||
- handle client/agent version downgrades after connection was established (#1508).
|
||||
|
||||
# 6.3.1
|
||||
|
||||
Servers:
|
||||
- handle ECONNABORTED error on client connections.
|
||||
- reproducible builds.
|
||||
- blocking records for content moderation.
|
||||
- update script (simplex-servers-update) downloads scripts from the specified or the latest stable tag.
|
||||
|
||||
SMP server:
|
||||
- support for PostgreSQL database for queue records for higher traffic servers.
|
||||
- fix old clients sending messages to new servers (#1443)
|
||||
- remove empty journals when opening message queues and expiring idle queues (#1456, #1458).
|
||||
- additional start options (#1465):
|
||||
- `maintenance` to run all start/stop operations without starting server.
|
||||
- `skip-warnings` to ignore the last corrupted line in store log (can happen on abnormal termination).
|
||||
|
||||
Ntf server:
|
||||
- record date of last token activity, to allow expiring inactive tokens.
|
||||
- additional token invalidation reasons in logs.
|
||||
|
||||
SMP agent:
|
||||
- store message sent to multiple connections only once, to reduce storage when sending to groups (#1453).
|
||||
- encrypt messages on delivery, to reduce database writes (#1446).
|
||||
- don't block method calls on congested sockets for better concurrency (#1454).
|
||||
- check notification token status on client connection.
|
||||
- option to skip SQLite vacuum on migrations.
|
||||
|
||||
# 6.3.0
|
||||
|
||||
SMP agent: fix joining connection after failure by using the same ratchet.
|
||||
|
||||
# 6.2.2
|
||||
|
||||
SMP server:
|
||||
@@ -101,7 +32,7 @@ Servers: more reliable restoring of state.
|
||||
|
||||
SMP server: reduced memory usage and faster start.
|
||||
|
||||
Notifications: compensate for iOS notifications being dropped by Apple while device is offline (#1378):
|
||||
Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378):
|
||||
- Ntf server: send multiple SMP notifications in one iOS notification.
|
||||
- Agent: get multiple messages for one iOS notification.
|
||||
|
||||
|
||||
@@ -1,31 +0,0 @@
|
||||
# syntax=docker/dockerfile:1.7.0-labs
|
||||
ARG TAG=24.04
|
||||
FROM ubuntu:${TAG} AS build
|
||||
|
||||
### Build stage
|
||||
|
||||
ARG GHC=9.6.3
|
||||
ARG CABAL=3.14.1.1
|
||||
|
||||
# Install curl, git and and simplexmq dependencies
|
||||
RUN apt-get update && apt-get install -y curl libpq-dev git sqlite3 libsqlite3-dev build-essential libgmp3-dev zlib1g-dev llvm llvm-dev libnuma-dev libssl-dev
|
||||
|
||||
# Specify bootstrap Haskell versions
|
||||
ENV BOOTSTRAP_HASKELL_GHC_VERSION=${GHC}
|
||||
ENV BOOTSTRAP_HASKELL_CABAL_VERSION=${CABAL}
|
||||
|
||||
# Do not install Stack
|
||||
ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK=true
|
||||
ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK=true
|
||||
|
||||
# Install ghcup
|
||||
RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh
|
||||
|
||||
# Adjust PATH
|
||||
ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
|
||||
|
||||
# Set both as default
|
||||
RUN ghcup set ghc "${GHC}" && \
|
||||
ghcup set cabal "${CABAL}"
|
||||
|
||||
WORKDIR /project
|
||||
@@ -1,6 +1,6 @@
|
||||
# SimpleXMQ
|
||||
|
||||
[](https://github.com/simplex-chat/simplexmq/actions/workflows/build.yml)
|
||||
[](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild)
|
||||
[](https://github.com/simplex-chat/simplexmq/releases)
|
||||
|
||||
📢 SimpleXMQ v1 is released - with many security, privacy and efficiency improvements, new functionality - see [release notes](https://github.com/simplex-chat/simplexmq/releases/tag/v1.0.0).
|
||||
@@ -116,7 +116,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
|
||||
2. Run your Docker container.
|
||||
|
||||
- `smp-server`
|
||||
|
||||
|
||||
You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
|
||||
```sh
|
||||
docker run -d \
|
||||
@@ -129,7 +129,7 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
|
||||
```
|
||||
|
||||
- `xftp-server`
|
||||
|
||||
|
||||
You must change **your_ip_or_domain** and **maximum_storage**.
|
||||
```sh
|
||||
docker run -d \
|
||||
@@ -187,7 +187,7 @@ On Linux, you can build smp server using Docker.
|
||||
3. Run your Docker container.
|
||||
|
||||
- `smp-server`
|
||||
|
||||
|
||||
You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
|
||||
```sh
|
||||
docker run -d \
|
||||
@@ -200,7 +200,7 @@ On Linux, you can build smp server using Docker.
|
||||
```
|
||||
|
||||
- `xftp-server`
|
||||
|
||||
|
||||
You must change **your_ip_or_domain** and **maximum_storage**.
|
||||
```sh
|
||||
docker run -d \
|
||||
@@ -247,7 +247,7 @@ On Linux, you can build smp server using Docker.
|
||||
|
||||
`xftp-server`
|
||||
```sh
|
||||
cabal list-bin exe:xftp-server
|
||||
cabal list-bin exe:xftp-server
|
||||
```
|
||||
|
||||
- Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
|
||||
|
||||
@@ -15,6 +15,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogInfo
|
||||
cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath
|
||||
logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath
|
||||
withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath
|
||||
|
||||
@@ -16,6 +16,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogDebug
|
||||
cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
|
||||
logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
|
||||
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles cfgPath logPath
|
||||
|
||||
@@ -1,49 +0,0 @@
|
||||
{
|
||||
"applinks": {
|
||||
"details": [
|
||||
{
|
||||
"appIDs": [
|
||||
"5NN7GUYB6T.chat.simplex.app"
|
||||
],
|
||||
"components": [
|
||||
{
|
||||
"/": "/contact/*"
|
||||
},
|
||||
{
|
||||
"/": "/contact"
|
||||
},
|
||||
{
|
||||
"/": "/invitation/*"
|
||||
},
|
||||
{
|
||||
"/": "/invitation"
|
||||
},
|
||||
{
|
||||
"/": "/a/*"
|
||||
},
|
||||
{
|
||||
"/": "/a"
|
||||
},
|
||||
{
|
||||
"/": "/c/*"
|
||||
},
|
||||
{
|
||||
"/": "/c"
|
||||
},
|
||||
{
|
||||
"/": "/g/*"
|
||||
},
|
||||
{
|
||||
"/": "/g"
|
||||
},
|
||||
{
|
||||
"/": "/i/*"
|
||||
},
|
||||
{
|
||||
"/": "/i"
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
@@ -1,16 +0,0 @@
|
||||
[
|
||||
{
|
||||
"relation": [
|
||||
"delegate_permission/common.handle_all_urls"
|
||||
],
|
||||
"target": {
|
||||
"namespace": "android_app",
|
||||
"package_name": "chat.simplex.app",
|
||||
"sha256_cert_fingerprints": [
|
||||
"5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D",
|
||||
"3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85",
|
||||
"AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6"
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
@@ -1 +0,0 @@
|
||||
../link.html
|
||||
@@ -1 +0,0 @@
|
||||
../link.html
|
||||
@@ -1 +0,0 @@
|
||||
../link.html
|
||||
@@ -142,7 +142,8 @@
|
||||
class="hidden xl:block h-screen pt-[66px] bg-white dark:bg-gradient-radial-mobile dark:lg:bg-gradient-radial">
|
||||
<div class="container m-auto h-full flex items-center justify-between px-5">
|
||||
<div class="flex flex-col items-start justify-center w-full">
|
||||
<h1 class="text-[38px] leading-[43px] font-bold max-w-[500px] mb-[30px] primary-header-contact">This is a one-time link of the SimpleX network user</h1>
|
||||
<h1 class="text-[38px] leading-[43px] font-bold max-w-[500px] mb-[30px] primary-header-contact">You received a
|
||||
1-time link to connect on SimpleX Chat</h1>
|
||||
<h2
|
||||
class="text-[20px] leading-[28px] text-[#606C71] dark:text-white font-bold max-w-[475px] mb-[80px] secondary-header-contact">
|
||||
Scan the QR code with the SimpleX Chat app on your phone or tablet.</h2>
|
||||
@@ -183,8 +184,10 @@
|
||||
class="block xl:hidden pt-[106px] py-[90px] bg-white dark:bg-gradient-radial-mobile dark:lg:bg-gradient-radial">
|
||||
<div class="container m-auto px-5">
|
||||
<div class="flex flex-col items-center">
|
||||
<h1 class="text-[28px] font-bold text-center max-w-[602px] mb-[40px] primary-header-contact">This is a one-time link of the SimpleX network user</h1>
|
||||
<p class="text-[20px] leading-[28px] text-grey-black dark:text-white font-medium mb-[30px]">To make a connection:</p>
|
||||
<h1 class="text-[28px] font-bold text-center max-w-[602px] mb-[40px] primary-header-contact">You received a
|
||||
1-time link to connect on SimpleX Chat</h1>
|
||||
<p class="text-[20px] leading-[28px] text-grey-black dark:text-white font-medium mb-[30px]">To make a
|
||||
connection:</p>
|
||||
<div
|
||||
class="flex flex-col justify-center items-center p-4 w-full max-w-[468px] min-h-[131px] rounded-[30px] border-[1px] border-[#A8B0B4] dark:border-white border-opacity-60 mb-6 relative">
|
||||
<p class="text-xl font-medium text-grey-black dark:text-white mb-4">Install SimpleX app</p>
|
||||
@@ -503,15 +506,13 @@
|
||||
const url = window.location.href
|
||||
const messageElements = document.getElementsByClassName('primary-header-contact')
|
||||
|
||||
for (let element of messageElements) {
|
||||
if (url.includes('/g') || url.includes('&data=%7B%22groupLinkId%22%3A')) {
|
||||
element.innerHTML = 'This is a public group address on SimpleX network'
|
||||
} else if (url.includes('/a') || url.includes('/contact')) {
|
||||
element.innerHTML = 'This is a public address of the SimpleX network user'
|
||||
} else if (url.includes('/i') || url.includes('/invitation')) {
|
||||
element.innerHTML = 'This is a one-time link of the SimpleX network user'
|
||||
} else if (url.includes('/c')) {
|
||||
element.innerHTML = 'This is a public channel address on SimpleX network'
|
||||
if (url.includes('/invitation')) {
|
||||
for (let element of messageElements) {
|
||||
element.textContent = 'You received a 1-time link to connect on SimpleX Chat'
|
||||
}
|
||||
} else {
|
||||
for (let element of messageElements) {
|
||||
element.textContent = 'You received an address to connect on SimpleX Chat'
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
||||
@@ -20,18 +20,7 @@
|
||||
parsedURI.pathname = "/" + action
|
||||
connURI = parsedURI.toString()
|
||||
console.log("connection URI: ", connURI)
|
||||
const hash = parsedURI.hash
|
||||
const hostname = parsedURI.hostname
|
||||
let appURI = "simplex:" + parsedURI.pathname
|
||||
appURI += action.length > 1 // not short link
|
||||
? hash
|
||||
: !hash.includes("?") // otherwise add server hostname
|
||||
? hash + "?h=" + hostname // no parameters
|
||||
: !hash.includes("?h=") && !hash.includes("&h=")
|
||||
? hash + "&h=" + hostname // no "h" parameter
|
||||
: hash.replace(/([?&])h=([^&]+)/, `$1h=${hostname},$2`) // add as the first hostname to "h" parameter
|
||||
mobileConnURIanchor.href = appURI
|
||||
console.log("app URI: ", appURI)
|
||||
mobileConnURIanchor.href = "simplex:" + parsedURI.pathname + parsedURI.hash
|
||||
connURIel.innerText = "/c " + connURI
|
||||
for (const connQRCode of connQRCodes) {
|
||||
try {
|
||||
|
||||
@@ -14,8 +14,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.Socket (getPeerName)
|
||||
import Network.Wai (Application, Request (..))
|
||||
import Network.Wai.Application.Static (StaticSettings (..))
|
||||
import Network.Wai (Application)
|
||||
import qualified Network.Wai.Application.Static as S
|
||||
import qualified Network.Wai.Handler.Warp as W
|
||||
import qualified Network.Wai.Handler.Warp.Internal as WI
|
||||
@@ -32,13 +31,12 @@ import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath
|
||||
import UnliftIO.Concurrent (forkFinally)
|
||||
import UnliftIO.Exception (bracket, finally)
|
||||
import qualified WaiAppStatic.Types as WAT
|
||||
|
||||
serveStaticFiles :: EmbeddedWebParams -> IO ()
|
||||
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do
|
||||
forM_ webHttpPort $ \port -> flip forkFinally (\e -> logError $ "HTTP server crashed: " <> tshow e) $ do
|
||||
logInfo $ "Serving static site on port " <> tshow port
|
||||
W.runSettings (mkSettings port) app
|
||||
W.runSettings (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath)
|
||||
forM_ webHttpsParams $ \WebHttpsParams {port, cert, key} -> flip forkFinally (\e -> logError $ "HTTPS server crashed: " <> tshow e) $ do
|
||||
logInfo $ "Serving static site on port " <> tshow port <> " (TLS)"
|
||||
WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
|
||||
@@ -74,44 +72,23 @@ warpSettings :: W.Settings
|
||||
warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
|
||||
|
||||
staticFiles :: FilePath -> Application
|
||||
staticFiles root = S.staticApp settings . changeWellKnownPath
|
||||
staticFiles root = S.staticApp settings
|
||||
where
|
||||
settings = defSettings {ssListing = Nothing, ssGetMimeType = getMimeType}
|
||||
defSettings = S.defaultFileServerSettings root
|
||||
getMimeType f
|
||||
| WAT.fromPiece (WAT.fileName f) == "apple-app-site-association" = pure "application/json"
|
||||
| otherwise = (ssGetMimeType defSettings) f
|
||||
changeWellKnownPath req = case pathInfo req of
|
||||
".well-known" : rest ->
|
||||
req
|
||||
{ pathInfo = "well-known" : rest,
|
||||
rawPathInfo = "/well-known/" <> B.drop pfxLen (rawPathInfo req)
|
||||
}
|
||||
_ -> req
|
||||
pfxLen = B.length "/.well-known/"
|
||||
settings = (S.defaultFileServerSettings root)
|
||||
{ S.ssListing = Nothing
|
||||
}
|
||||
|
||||
generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
|
||||
generateSite si onionHost sitePath = do
|
||||
createDirectoryIfMissing True sitePath
|
||||
B.writeFile (sitePath </> "index.html") $ serverInformation si onionHost
|
||||
copyDir "media" E.mediaContent
|
||||
-- `.well-known` path is re-written in changeWellKnownPath,
|
||||
-- staticApp does not allow hidden folders.
|
||||
copyDir "well-known" E.wellKnown
|
||||
createLinkPage "contact"
|
||||
createLinkPage "invitation"
|
||||
createLinkPage "a"
|
||||
createLinkPage "c"
|
||||
createLinkPage "g"
|
||||
createLinkPage "i"
|
||||
createDirectoryIfMissing True $ sitePath </> "media"
|
||||
forM_ E.mediaContent $ \(path, bs) -> B.writeFile (sitePath </> "media" </> path) bs
|
||||
createDirectoryIfMissing True $ sitePath </> "contact"
|
||||
B.writeFile (sitePath </> "contact" </> "index.html") E.linkHtml
|
||||
createDirectoryIfMissing True $ sitePath </> "invitation"
|
||||
B.writeFile (sitePath </> "invitation" </> "index.html") E.linkHtml
|
||||
logInfo $ "Generated static site contents at " <> tshow sitePath
|
||||
where
|
||||
copyDir dir content = do
|
||||
createDirectoryIfMissing True $ sitePath </> dir
|
||||
forM_ content $ \(path, s) -> B.writeFile (sitePath </> dir </> path) s
|
||||
createLinkPage path = do
|
||||
createDirectoryIfMissing True $ sitePath </> path
|
||||
B.writeFile (sitePath </> path </> "index.html") E.linkHtml
|
||||
|
||||
serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
|
||||
serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
|
||||
|
||||
@@ -13,6 +13,3 @@ linkHtml = $(embedFile "apps/smp-server/static/link.html")
|
||||
|
||||
mediaContent :: [(FilePath, ByteString)]
|
||||
mediaContent = $(embedDir "apps/smp-server/static/media/")
|
||||
|
||||
wellKnown :: [(FilePath, ByteString)]
|
||||
wellKnown = $(embedDir "apps/smp-server/static/.well-known/")
|
||||
|
||||
@@ -4,7 +4,6 @@ packages: .
|
||||
-- packages: . ../http2
|
||||
-- packages: . ../network-transport
|
||||
|
||||
-- uncomment two sections below to run tests with coverage
|
||||
-- package *
|
||||
-- coverage: True
|
||||
-- library-coverage: True
|
||||
|
||||
@@ -43,9 +43,9 @@ Additional suggestion to reduce probability of queue_state.log and queue_rec.log
|
||||
- check the last byte of the file and log EOL if it is not EOL. Probably cleanest approach, but with a small performance cost.
|
||||
|
||||
If queue folder is a reference to the queue, it may have one of these files:
|
||||
- notifier.id
|
||||
- sender.id
|
||||
- link.id
|
||||
- notifier.ref
|
||||
- sender.ref
|
||||
- link.ref
|
||||
|
||||
These files would contain a one line with the recipient ID of the queue. These files would never change, they can only be deleted when queue is deleted or when notifier/link is deleted.
|
||||
|
||||
|
||||
@@ -1,290 +0,0 @@
|
||||
# Protocol changes for creating and connecting to SMP queues
|
||||
|
||||
## Problems
|
||||
|
||||
This change is related to these problems:
|
||||
- differentiating queue retention time,
|
||||
- supporting MITM-resistant short connection links,
|
||||
|
||||
This RFC is based on the previous discussions about short links, blob storage and notifications ([1](./2024-06-21-short-links.md), [2](./2024-09-09-smp-blobs.md), [3](./2024-11-25-queue-blobs-2.md), [4](./2024-09-25-ios-notifications-2.md)).
|
||||
|
||||
SMP protocol supports two types of queues - queues to send messages (messaging queues) and queues to send invitations to connect (contact queues). While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
|
||||
|
||||
Simply designating queue types would allow to use this information to decide for how long to retain queues, and potentially extending it:
|
||||
- unsecured 1-time invitation queues with sndSecure (support of securing by sender) - e.g., 3 months.
|
||||
- contact address queues without sndSecure - e.g., 3 years without activity.
|
||||
- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and super-peer addresses for the group.
|
||||
|
||||
## Design objectives
|
||||
|
||||
We want to achieve these objectives for short links and associated queue data:
|
||||
1. no possibility to provide incorrect SenderId inside link data (e.g. from another queue).
|
||||
2. link data cannot be accessed by the server unless it has the link.
|
||||
3. prevent MITM attack by the server, including the server that obtained the link.
|
||||
4. prevent changing of connection request by the user (to prevent MITM via break-in attack in the originating client).
|
||||
5. for one-time links, prevent accessing link data by link observers who did not compromise the server.
|
||||
6. allow changing the user-defined part of link data.
|
||||
7. avoid changing the link when user-defined part of link data changes, while preventing MITM attack by the server on user-defined part, even if it has the link.
|
||||
8. retain the quality that it is impossible to check the existence of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
|
||||
|
||||
To achieve these objectives the queue data will include fixed (immutable) and user-defined (mutable) parts.
|
||||
|
||||
Fixed part would include:
|
||||
- full connection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
|
||||
- public signature key to verify mutable part of link data.
|
||||
|
||||
Signed mutable part would include:
|
||||
- any links to chat relays that should be contacted instead of this queue (not in this RFC), to allow delegating group connections and contact request connections to prevent spam, hiding online presence, etc.
|
||||
- and user-defined data - user profile or group profile, chat preferences, welcome message, etc.
|
||||
|
||||
The link itself should include both the key and auth tag from the encryption of immutable part. Accessing one-time link data should require providing sender key and signing the command (`LKEY`).
|
||||
|
||||
## Solution
|
||||
|
||||
Current NEW and NKEY commands:
|
||||
|
||||
```haskell
|
||||
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
|
||||
|
||||
-- | Queue IDs and keys, returned in IDS response
|
||||
data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId,
|
||||
sndId :: SenderId,
|
||||
rcvPublicDhKey :: RcvPublicDhKey,
|
||||
sndSecure :: SenderCanSecure
|
||||
}
|
||||
```
|
||||
|
||||
Proposed NEW command replaces SenderCanSecure with QueueMode, adds link data, and combines NKEY command:
|
||||
|
||||
```haskell
|
||||
NEW :: NewQueueRequest -> Command Recipient
|
||||
|
||||
data NewQueueReq = NewQueueReq
|
||||
{ rcvAuthKey :: RcvPublicAuthKey,
|
||||
rcvDhKey :: RcvPublicDhKey,
|
||||
auth_ :: Maybe BasicAuth,
|
||||
subMode :: SubscriptionMode,
|
||||
queueReqData :: Maybe QueueReqData,
|
||||
}
|
||||
|
||||
-- QRMessaging implies that sender can secure the queue.
|
||||
-- LinkId is not used with QRMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used.
|
||||
-- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists.
|
||||
data QueueReqData
|
||||
= QRMessaging (Maybe (SenderId, QueueLinkData))
|
||||
| QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
|
||||
|
||||
-- SenderId should be computed client-side as the first 24 bytes of sha3-384(correlation_id),
|
||||
-- The server must verify it and reject if it is not.
|
||||
-- It allows to include sender ID inside encrypted associated link data as part of full connection URI without requesting it from the server, but prevents checking if a given sender ID exists (queue creation would fail for a duplicate sender ID), as sha3-384 derivation is not reversible.
|
||||
type QueueLinkData = (EncFixedLinkData, EncUserDataBytes)
|
||||
|
||||
type EncFixedLinkData = ByteString
|
||||
|
||||
type EncUserDataBytes = ByteString
|
||||
|
||||
-- We need to use binary encoding for ConnectionRequestUri to reduce its size
|
||||
-- The clients would reject changed immutable data and
|
||||
-- ConnectionRequestUri where server or SenderId of the queue do not match.
|
||||
data FixedLinkData c = FixedLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
rootKey :: C.PublicKeyEd25519,
|
||||
connReq :: ConnectionRequestUri c
|
||||
}
|
||||
|
||||
data ConnLinkData c where
|
||||
InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
|
||||
ContactLinkData ::
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
-- direct connection via connReq in fixed data is allowed.
|
||||
direct :: Bool,
|
||||
-- additional owner keys to sign changes of mutable data.
|
||||
owners :: [OwnerAuth],
|
||||
-- alternative addresses of chat relays that receive requests for this contact address.
|
||||
relays :: [ConnShortLink 'CMContact],
|
||||
userData :: UserLinkData
|
||||
} -> ConnLinkData 'CMContact
|
||||
|
||||
newtype UserLinkData = UserLinkData ByteString
|
||||
|
||||
-- | Updated queue IDs and keys, returned in IDS response
|
||||
data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId, -- server-generated
|
||||
sndId :: SenderId, -- server-generated
|
||||
rcvPublicDhKey :: RcvPublicDhKey,
|
||||
sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied?
|
||||
linkId :: Maybe LinkId -- server-generated
|
||||
}
|
||||
```
|
||||
|
||||
In addition to that we add the command allowing to update and also to retrieve and secure the queue and get link data in one request, to have only one request:
|
||||
|
||||
```haskell
|
||||
-- This command allows to set all data or to update mutable part of contact address queue.
|
||||
-- This command should fail on queues that support sndSecure and also on new queues created with QRMessaging.
|
||||
-- This should fail if LinkId or immutable part of data is changed with the update, but will succeed if only mutable part is updated, so it can be retried.
|
||||
-- Entity ID is RecipientId.
|
||||
-- The response to this command is `OK`.
|
||||
LSET :: LinkId -> QueueLinkData -> Command Recipient
|
||||
|
||||
-- Delete should link and associated data
|
||||
-- Entity ID is RecipientId
|
||||
LDEL :: Command Recipient
|
||||
|
||||
-- To be used with 1-time links.
|
||||
-- Sender's key provided on the first request prevents observers from undetectably accessing 1-time link data.
|
||||
-- If queue mode is QRContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY.
|
||||
-- Once queue is secured, the key must be the same in subsequent requests - to allow retries in case of network failures, and to prevent passive attacks.
|
||||
-- The difference with securing queues is that queues allow sending unsecured messages to queues that allow sndSecure (for backwards compatibility), and 1-time links will NOT allow retrieving link data without securing the queue at the same time, preventing undetected access by observers.
|
||||
-- Entity ID is LinkId
|
||||
LKEY :: SndPublicAuthKey -> Command Sender
|
||||
|
||||
-- If queue mode is QRMessaging the command will fail.
|
||||
-- Entity ID is LinkId
|
||||
LGET :: Command Sender
|
||||
|
||||
-- Response to LGET and LSET
|
||||
-- Entity ID is the same as in the command
|
||||
LNK :: SenderId -> QueueLinkData -> BrokerMsg
|
||||
```
|
||||
|
||||
To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existence, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID.
|
||||
|
||||
To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` (and for contact queue, also `link_id`, which would be random as it is derived from hash of fixed link data that includes a random signature key) should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used.
|
||||
|
||||
Alternative solutions that would allow retries that were considered and rejected:
|
||||
- additional request to save queue data, after `sender_id` is returned by the server. The scenarios that require short links are interactive - creating user addresses and 1-time invitations - so making two requests instead of one would make the UX worse.
|
||||
- include empty sender_id in the immutable data and have it replaced by the accepting party with `sender_id` received in `LINK` response - both a weird design, and might create possibility for some attacks via server, especially for contact addresses.
|
||||
- making NEW commands idempotent. Doing it would require generating all IDs client-side, not only `sender_id`. It increases complexity, and it is not really necessary as the only scenarios when retries are needed are async NEW commands, that do not require short links. For future short links of chat relays the retries are much less likely, as chat relays will have good network connections.
|
||||
|
||||
## Algorithm to prepare and to interpret queue link data.
|
||||
|
||||
For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existence checks (oracle attack).
|
||||
|
||||
This scheme results in 32 byte binary size for contact addresses and 56 bytes for 1-time invitation links.
|
||||
|
||||
For fixed link data.
|
||||
|
||||
1. Generate random `nonce` (also used as a correlation ID for server command) and signature key (public `rootKey` included in fixed data).
|
||||
2. Compute sender ID from `nonce` as the first 24 bytes of sha3-384 of `nonce`.
|
||||
3. Generate other keys for queue address, including queue e2e encryption keys and double ratchet connection e2e encryption keys.
|
||||
4. Construct the full connection address to be included in fixed data.
|
||||
5. `link_key = SHA3-256(fixed_data)` - used as part of the link, and to derive the key to encrypt content.
|
||||
6. HKDF:
|
||||
1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
|
||||
2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated.
|
||||
7. Encrypt: `(ct1, tag1) = secret_box(fixed_data, key, nonce1)`, where `nonce1` is a random nonce
|
||||
5. Store: `(nonce1, ct1, tag1)` stored as fixed link data.
|
||||
|
||||
For mutable user data:
|
||||
|
||||
1. Random `nonce2` and the same key are used.
|
||||
2. Sign `user_data` with key included in `fixed_data`.
|
||||
3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`.
|
||||
4. Store: `(nonce2, ct2, tag2)`
|
||||
|
||||
Link recipient:
|
||||
|
||||
1. Receives `link_key` in the link, for 1-time invitations also `link_id`.
|
||||
2. HKDF:
|
||||
1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
|
||||
2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`.
|
||||
3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`:
|
||||
1) contact address: `LGET` command, that allows retrieving link data multiple times.
|
||||
2) 1-time invitation: `LKEY` command, that non-optionally secures the queue, and only allows repeated link data retrievals if the same sender's key is provided and signs the transmission. This prevents link data retrieval by link observers.
|
||||
4. Decrypt: `(signature1, fixed_data) = decrypt (nonce1, ct1, tag1)`.
|
||||
5. Verify: `SHA3-256(fixed_data) == link_key`, abort if not.
|
||||
6. Decrypt: `(signature2, used_data) = decrypt(nonce2, ct2, tag2)`.
|
||||
7. Verify signatures using key in the fixed data, abort if they don't match.
|
||||
|
||||
While using content hash as encryption key is unconventional, it is not completely unusual - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `fixed_data` contains mostly random keys.
|
||||
|
||||
## Threat model
|
||||
|
||||
**Compromised SMP server**
|
||||
|
||||
can:
|
||||
- delete link data.
|
||||
- hide link data selectively for some or for all requests.
|
||||
|
||||
cannot:
|
||||
- undetectably replace link data, even if it has the link (objective 3).
|
||||
- access unencrypted link data, whether it was or was not accessed by the accepting party, provided it has no link (objective 2).
|
||||
- observe IP addresses of the users accessing link data, if private routing is used.
|
||||
|
||||
**Passive observer who observed short link**:
|
||||
|
||||
can:
|
||||
- access original unencrypted link data for contact address links.
|
||||
|
||||
cannot:
|
||||
- undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5).
|
||||
- undetectably check the existence of messaging queue or 1-time link (objective 8).
|
||||
- replace or delete the link data.
|
||||
|
||||
**Queue owner who did not compromise the server**:
|
||||
|
||||
cannot:
|
||||
- redirect connecting user to another queue, on the same or on another server (objective 1).
|
||||
- replace connection request in the link (objective 4).
|
||||
|
||||
## Correlation of design objectives with design elements
|
||||
|
||||
1. The presence of `SenderId` in `LNK` response from the server.
|
||||
2. Encryption of link data with crypto_box.
|
||||
3. Deriving encryption key from the hash of fixed data prevents it being modified by the server - any change would be detected and rejected by the client, as the hash of fixed data won't match the link. Signature verification with the key from fixed data, and signing of mutable data prevents server modification of mutable data.
|
||||
4. No server command to change fixed data once it's set. Also, changing fixed data would require changing the link.
|
||||
5. 1-time link data can only be accessed with `LKEY` command, that while allows retries to mitigate network failures, will require the same key for retries.
|
||||
6. `LSET` command.
|
||||
7. The link is derived from fixed data only, so it does not change when mutable link data changes. Mutable part is signed preventing server MITM attacks.
|
||||
8. SenderId is derived from request correlation ID, so it cannot be arbitrary defined to check existence of some known queue. LinkId for 1-time invitation is generated server-side, so it cannot be provided by the client when creating the queues to check if these IDs are used.
|
||||
|
||||
## Syntax for short links
|
||||
|
||||
The syntax:
|
||||
|
||||
```abnf
|
||||
shortConnectionLink = uriAuthority "/" linkUri [ "?" param *( "&" param ) ]
|
||||
uriAuthority = %s"https://" smpServerHost / "simplex:" ; using simplex: scheme requires including host in the parameter hostParam
|
||||
smpServerHost = <hostname> ; RFC1123, RFC5891
|
||||
linkUri = %s"i#" oneTimeLink / contactType "#" contactLink
|
||||
contactType = %s"a" / %s"g" / %s"c" ; contact / group / channel address, respectively
|
||||
oneTimeLink = <base64url(linkId)> "/" <base64url(linkKey)> ; 56 bytes / 75 base64 encoded characters
|
||||
contactLink = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
|
||||
; linkId - 192 bits/24 bytes
|
||||
; linkKey - 256 bits/32 bytes
|
||||
|
||||
param = hostsParam / portParam / certHashParam
|
||||
hostsParam = %s"h=" host *("," host) ; additional hostnames, e.g. onion
|
||||
portParam = %s"p=" 1*DIGIT ; server port
|
||||
certHashParam = %s"c=" <base64url(server offline certificate fingerprint)>
|
||||
```
|
||||
|
||||
To have shorter links fingerprint and additional server hostnames do not need to be specified for pre-configured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint.
|
||||
|
||||
Example one-time link for preset server (104 characters):
|
||||
|
||||
```
|
||||
https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij01/23456789abcdefghij0123456789abcdefghij01234
|
||||
```
|
||||
|
||||
Example contact link for preset server (71 characters):
|
||||
|
||||
```
|
||||
https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
Example contact link for user-defined server (with fingerprint, but without onion hostname - 117 characters):
|
||||
|
||||
```
|
||||
https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU
|
||||
```
|
||||
|
||||
Example contact link for user-defined server (with fingerprint ant onion hostname - 182 characters):
|
||||
|
||||
```
|
||||
https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU&h=beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion
|
||||
```
|
||||
|
||||
For the links to work in the browser the servers must provide server pages.
|
||||
@@ -1,93 +0,0 @@
|
||||
# New notifications protocol
|
||||
|
||||
## Problem
|
||||
|
||||
iOS notifications have these problems:
|
||||
- iOS notification service crashes exceeding memory limit. This is being addressed by changes in GHC RTS.
|
||||
- there is a large number of connections, because each member in a group requires individual connection. This will improve with chat relays when each group would require 2-3 connections.
|
||||
- some notification may be not shown if notification with reply/mention is skipped, and instead some other message is delivered, which may be muted. This would not improve without some changes, as notifications may be skipped anyway.
|
||||
- client devices delay communication with ntf server because it is done in background, and by that time the app may be suspended.
|
||||
- notification server represents a bottleneck, as it has to be owned by the app vendor, and the current design when ntf server subscribes to notifications scales very badly.
|
||||
|
||||
This RFC is based on the previous [RFC related to notifications](./2024-09-25-ios-notifications-2.md).
|
||||
|
||||
## Solution
|
||||
|
||||
As notification server has to know client token and currently it associates subscriptions with this token anyway, we are not gaining any privacy and security by using per-subscription keys - both authorization and encryption keys of notification subscription can be dropped.
|
||||
|
||||
We still need to store the list of queue IDs associated with the token on the notification server, but we do not need any per-queue keys on the notification server, and we don't need subscriptions - it's effectively a simple set of IDs, with no other information.
|
||||
|
||||
In this case, when queue is created the client would supply notifier ID - it has to be derived from correlation ID, to prevent existense check (see previous RFC). As we also supply sender ID, instead of deriving it as sha3-192 of correlation ID, they both can be derived as sha3-384 and split to two IDs - 24 bytes each.
|
||||
|
||||
The notification server will maintain a rotating list of server keys with the latest key communicated to the client every time the token is registered and checked. The keys would expire after, say, 1 week or 1 month, and removed from notification server on expiration.
|
||||
|
||||
The packet containing association between notifier queue ID and token will be crypto_box encrypted using key agreement between identified notification server master key and an ephemeral per packet (effectively, per-queue) client-key.
|
||||
|
||||
Deleting the queue may also include encrypted packet that would verify that the client deleted the queue.
|
||||
|
||||
Instead of notification server subscribing to the notifications creating a lot of traffic for the queues without messages, the SMP server would push notifications via NTF server connection (whether via NTF or via SMP protocol). This could be used as a mechanism to migrate existing queues when with the next subscription the notification server would communicate it's address to SMP server and this association would be stored together with the queue.
|
||||
|
||||
## Protocol design
|
||||
|
||||
Additional/changed SMP commands:
|
||||
|
||||
```haskell
|
||||
-- register notification server
|
||||
-- should be signed with server key
|
||||
NSRV :: NtfServerCreds -> Command NtfServer
|
||||
|
||||
-- response
|
||||
NSID :: NtfServerId -> BrokerMsg
|
||||
|
||||
-- to communicate which server is responsible for the queue
|
||||
-- should be signed with queue key
|
||||
NSUB :: Maybe NtfServerId -> Command Notifier
|
||||
|
||||
-- subscribe to notificaions from all queues associated with the server
|
||||
-- should be signed with server key
|
||||
-- entity ID - NtfServerId
|
||||
NSSUB :: Command NtfServer
|
||||
|
||||
data NtfServerCreds = NtfServerCreds
|
||||
{ server :: NtfServer,
|
||||
-- NTF server certificate chain that should match fingerpring in address
|
||||
cert :: X.CertificateChain,
|
||||
-- server autorizatio key to sign server subscription requests
|
||||
authKey :: X.SignedExact X.PubKey
|
||||
}
|
||||
|
||||
-- entity ID is recipient ID
|
||||
NSKEY :: NtfSubscription -> Command Recipient
|
||||
|
||||
data NtfSubscription = NtfSubscription
|
||||
-- key to encrypt notifications e2e with the client
|
||||
{ ntfPubDbKey :: RcvNtfPublicDhKey,
|
||||
ntfServer :: NtfServer,
|
||||
-- should be linked to correlation ID to prevent existense check
|
||||
-- the ID sent to notification server could be its hash?
|
||||
ntfId :: NotifierId,
|
||||
encNtfTokenAssoc :: EncDataBytes
|
||||
}
|
||||
|
||||
-- before the encryption - equivalent to NSUB command, but without key to authorize requests to specific queue
|
||||
data NtfTokenAssoc = NtfTokenAssoc
|
||||
{ signature :: SignatureEd25519,
|
||||
tknId :: NtfTokenId,
|
||||
ntfQueue :: SMPQueueNtf
|
||||
}
|
||||
```
|
||||
|
||||
SMP server will need to maintain the list of Ntf servers and their credentials, and when NSSUB arrives to make only one subscription. When message arrives it would deliver notification to the correct connection via queue / ntf server association.
|
||||
|
||||
Ntf server needs to maintain three indices to the same data:
|
||||
- `(smpServer, queueId) -> tokenId` - to deliver notification to the correct token
|
||||
- `tokenId -> [smpServer -> [queueId]]` - to remove all queues when token is removed, and to store/update these associations effficiently - store log may have one compact line per token (after compacting), or per token/server combination.
|
||||
- `[smpServer]` - array of SMP servers to subscribe to.
|
||||
|
||||
## Mention notifications
|
||||
|
||||
Currently we are marking messages with T (true) for messages that require notifications and F (false) for messages that don't require. Sender does not know whether the recipient has notifications disabled, enabled or in mentions-only mode.
|
||||
|
||||
The proposal is to:
|
||||
- add additional values to this metadata, e.g. 2 (priority) and 3 (high priority) (and T/F could be sent as 0/1 respectively) - that is, to deliver notifications even if notifications are generally disabled (they can still be further filtered by the client).
|
||||
- instead of deleting notification credentials when notifications are disabled - which is costly - communicate to SMP server the change of notificaion priority level, e.g. the client could set minimal notification priority to deliver notifications, where 0 would mean disabling it completely, 1 enable for all, 2 for priority 2+, 3 for priority 3. The downside here is that it could be used for timing correlation of queues in the group, but it already can be used on bulk deletions of ntf credentials for these queues and when sending messages.
|
||||
@@ -1,159 +0,0 @@
|
||||
# Using short links as group links
|
||||
|
||||
## Problem
|
||||
|
||||
To use the short links for groups these problems has to be / can be solved:
|
||||
1. recognizing link as a group link.
|
||||
2. permanent link with the ability to change chat relays.
|
||||
3. binding owners signatures to the link.
|
||||
4. allowing to add/remove owners, both to share ownership and for reliability in case of one owner losing keys/access.
|
||||
|
||||
While current short links solve problems 1-3 (via contact type, and via extension of user data in the link), the problem 4 is solved only partially.
|
||||
|
||||
We could include the current list of root owners in the user data, and we could send any history of ownership changes from this baseline as a short blockchain on joining the group, we still requrie one master owner to retain access to the queue associated with the group.
|
||||
|
||||
## Possible solution approaches
|
||||
|
||||
1. "Kick this can down the road" - ignore this problem until there is a namespace, and a group name can be associated with multiple queues.
|
||||
|
||||
Pros: simple and reasonable, and it suggests postponing multisig for owners too. The users can still see the list of owners and their keys in user data of the link, and receive admin roster signed by owners on joining.
|
||||
|
||||
Cons: if this "master owner" loses the access to the device, no further changes to group profile will be possible.
|
||||
|
||||
2. The queue access can be shared by sharing the key and recipient IDs with all owners.
|
||||
|
||||
The problems:
|
||||
- preventing MITM attack between owners (this protect exists for other solutions too).
|
||||
- protecting these credentials from chat relays. So somehow there should be direct key agreement between members allowing to send e2e encrypted message inaccessible to chat relays.
|
||||
|
||||
Pros: simpler than alternatives, and still provides protection against losing the key.
|
||||
Cons:
|
||||
- quite clunky, and requires the new primitive anyway (e2e encryption).
|
||||
- no multisig
|
||||
|
||||
This could possibly be evolved into the requirement to have a direct connection with other owners, and verifying the security code before they have access to group.
|
||||
|
||||
3. Allow "joint management" of SMP queues.
|
||||
|
||||
SMP servers can support multiple recipients for contact queues:\
|
||||
- subscription would be possible to the "subscriber recipient".
|
||||
- all other changes (update data, change subscriber recipient, add or remove recipients) would require multiple recipient signatures on SMP command in line with n-of-m multisig rules, that the command sender would have to collect out-of-band (from SMP protocol point of view).
|
||||
|
||||
Pros: allows joint ownership, and protects from losing access to master owner device.
|
||||
Cons:
|
||||
- complicates queue abstraction with approach that is not needed for most queues.
|
||||
- still retains the server as a single point of failure.
|
||||
|
||||
4. Introduce "group" as a new type of entity managed by SMP servers.
|
||||
|
||||
SMP servers would provide a separate set of commands for managing group records that would include in an encrypted container:
|
||||
- the group profile
|
||||
- the list of chat relay links
|
||||
- the list of owner member IDs with their public keys
|
||||
- multisig rules
|
||||
- alternative group entity locations
|
||||
- possibly, a globally unique group identity (as the hash of the initial/seed group data).
|
||||
|
||||
While the server domain would be used as the hostname in group link, it may contain alternative hosts (not just hostnames of the same server), both in the link and in the group record data.
|
||||
|
||||
Pros: separates additional complexity to where it is needed, allowing reliability and redundancy for group ownership.
|
||||
Cons: complexity, coupling between SMP and chat protocol.
|
||||
|
||||
## Design for channel/group as a separate queue mode
|
||||
|
||||
Option 1.
|
||||
|
||||
A queue mode "channel" when owners are represented by their individual queues (either a separate mode, or a submode of "channel", or just normal contact address queues). In this case sending message to channel queue would broadcast message to queue owners, without exposing even the number of owners.
|
||||
|
||||
Pros:
|
||||
- allows chat relays to send messages to all owners (e.g., channel can be secured with the list of snd keys, one per relay).
|
||||
- quite easy to evolve from the current design.
|
||||
- extensible.
|
||||
Cons:
|
||||
- close to "solution in search of a problem".
|
||||
- does not require data model changes - channel queue would simply have a list of owner "recipient IDs", and each owner queue would also point to channel.
|
||||
|
||||
Option 2.
|
||||
|
||||
Also a separate queue mode "channel", but instead of having a linked owner queues, it would simply maintain a list of owner keys to maintain the data. In this case, messages cannot be sent to this "queue" at all.
|
||||
|
||||
Pros:
|
||||
- simpler design.
|
||||
- we could allow sending messages to it too, with the "main" owner receiving them. This could be negotiated in the protocol.
|
||||
- it may be easier to migrate the current groups, as the admin link would be this queue (although for public groups in directory it would have to be recreated anyway).
|
||||
- Possibly, when queue is created there should be a flag whether it should accept unsigned messages - then contact addresses would be created with unsigned messages ON, messages queues, once SKEY is universally supported, with unsigned messages OFF, and channel queues with unsigned messages OFF too for new public queues.
|
||||
Cons:
|
||||
- if no messages are accepted, this is not even a queue.
|
||||
- no way to directly contact owners (maybe it is not a downside, as for relays there would be a communication channel anyway as part of the group).
|
||||
|
||||
Option 2 looks more simple and attractive, implementing server broadcast for SMP seems unnecessary, as while it could have been used for simple groups, it does not solve such problems as spam and pre-moderation anyway - it requires a higher level protocol.
|
||||
|
||||
The command to update owner keys would be `RKEY` with the list of keys, and we can make `NEW` accept multiple keys too, although the use case here is less clear.
|
||||
|
||||
## Multiple owners managing queue data.
|
||||
|
||||
Option 1: Use the same keys in SMP as when signing queue data.
|
||||
|
||||
Option 2: Use different keys.
|
||||
|
||||
The value here could be that the server could validate these signatures too, and also maintain the chain of key changes. While tempting, it is probably unnecessary, and this chain of ownership is better to be maintained on chat relay level, as there are no size constraints on the size of this chain. Also, it is better for metadata privacy to not couple transport and chat protocol keys.
|
||||
|
||||
We still need to bind the mutable data updates to the "genesis" signature key (the one included in the immutable data).
|
||||
|
||||
The proposed design:
|
||||
|
||||
- when mutable data is signed by genesis key, then it is bound, and no changes is needed.
|
||||
- mutable data may be signed by the key of the new owner, in which case mutable part itself must contain the binding. We could also use ring signature to sign the mutable data, concealing which owner signed the data - that would increase the signature size from 64 bytes to `32 * (n + 1)` bytes.
|
||||
|
||||
Current mutable data:
|
||||
|
||||
```haskell
|
||||
data UserLinkData = UserLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
userData :: ConnInfo
|
||||
}
|
||||
```
|
||||
|
||||
Proposed mutable data:
|
||||
|
||||
```haskell
|
||||
data UserLinkData = UserLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
owners :: [OwnerInfo]
|
||||
userData :: ConnInfo
|
||||
}
|
||||
|
||||
type OwnerId = ByteString
|
||||
|
||||
data OwnerInfo = OwnerInfo
|
||||
{ ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId
|
||||
ownerKey :: PublicKeyEd25519,
|
||||
-- owner signature of sender ID,
|
||||
-- confirms that the owner agreed with being the owner,
|
||||
-- prevents a member being added as an owner without consent.
|
||||
ownerSig :: SignatureEd25519,
|
||||
-- owner authorization, sig(ownerId || ownerKey, prevKey), where prevKey is either a "genesis key" or some other key previously signed by the genesis key.
|
||||
authOwnerId :: OwnerId, -- null for "genesis"
|
||||
authOwnerSig :: SignatureEd25519
|
||||
}
|
||||
```
|
||||
|
||||
The size of the OwnerInfo record encoding is:
|
||||
- ownerId: 1 + 12
|
||||
- ownerKey: 1 + 32
|
||||
- ownerSig: 1 + 64
|
||||
- ownerAuthId: 1 + 12
|
||||
- ownerAuthSig: 1 + 64
|
||||
|
||||
~189 bytes, so we should practically limit the number of owners to say 8 - 1 original + 7 addiitonal. Original creator could use a different key as a "genesis" key, to conceal creator identity from other members, and it needs to include the record with memberId anyway.
|
||||
|
||||
The structure is simplified, and it does not allow arbitrary ownership changes. Its purpose is not to comprehensively manage ownership changes - while it is possible with a generic blockchain, it seems not appropriate at this stage, - but rather to ensure access continuity and that the server cannot modify the data (although nothing prevents the server from removing the data completely or from serving the previous version of the data).
|
||||
|
||||
For example it would only allow any given owner to remove subsequenty added owners, preserving the group link and identity, but it won't allow removing owners that signed this owner authorization. So owners are not equal, with the creator having the highest rank and being able to remove all additional owners, and owners authorise by creator can remove all other owners but themselves and creator, and so on - they have to maintain the chain that authorized themselves, at least. We could explicitely include owner rank into OwnerInfo, or we could require that they are sorted by rank, or the rank can be simply derived from signatures.
|
||||
|
||||
When additional owners want to be added to the group, they would have to provide any of the current owners:
|
||||
- the key for SMP commands authorization - this will be passed to SMP server together with other keys. There could be either RKEY to pass all keys (some risk to miss some, or of race conditions), or RADD/RGET/RDEL to add and remove recipient keys, which has no risk of race conditions.
|
||||
- the signature of the immutable data by their member key included in their profile.
|
||||
- the current owner would then include their member key into the queue data, and update it with LSET command. In any case there should be some simple consensus protocol between owners for owner changes, and it has to be maintained as a blockchain by owners and by chat relays, as otherwise it may lead to race conditions with LSET command.
|
||||
|
||||
Potentially, there could be one command to update keys and link data, so that they are consistent.
|
||||
@@ -1,142 +0,0 @@
|
||||
# Service certificates for high volume servers and services connecting to SMP servers
|
||||
|
||||
## Problem
|
||||
|
||||
The absense of user and client identification benefits privacy, but it requires separately authorizing subscription for each messaging queue, that doesn't scale when a high volume server or service acts as a client for SMP server even for the current traffic and network size.
|
||||
|
||||
These servers/services include:
|
||||
- operators' chat relays (aka super-peers),
|
||||
- notification servers,
|
||||
- high-traffic service chat bots,
|
||||
- high-traffic business support clients.
|
||||
|
||||
The future chat relays would reduce the number of subscriptions required for the usual clients, by replacing connections with each group member to 1-3 connections with chat relays per group/community, it would shift the burden to the chat relays, that are also clients.
|
||||
|
||||
Self-hosted chat relays may want to retain privacy, so they will not use client certificates, but this privacy is not needed (and counter-productive) for the chat relays provided by network operators.
|
||||
|
||||
Even today, directory service subscribing to all queues may take 15-20 minutes, which is experienced as downtime by the end users.
|
||||
|
||||
Notification servers also acting as clients to messaging servers also take 15-20 minutes to subscribe to all notifications, during which time notifications are not delivered.
|
||||
|
||||
Not only these subscription take a lot of time, they also consume a large amount of memory both in the clients and in the servers, as association between clients and queues is currently session-scoped and not persisted anywhere (and it should not be, because end-users' clients do need privacy).
|
||||
|
||||
## Solution
|
||||
|
||||
High volume "clients" (operators' chat relays, directory service, SimpleX Chat team support client, SimpleX Status bot, etc.) that don't need privacy will identify themselves to the messaging servers at a point of connection by providing client sertificate, both in TLS handshake and in SMP handshake (the same certificate must be provided).
|
||||
|
||||
All the new queues and subscriptions made in this session will be creating a permanent association of the messaging queue with the client, and on subsequent reconnections the client can "subscribe" to all their queues with a single client subscription command.
|
||||
|
||||
This will save a lot of time subscribing and resubscribing on server and client restarts, servers' bandwidth, servers' traffic spikes, and memory of both clients and servers.
|
||||
|
||||
## Protocol
|
||||
|
||||
An ephemeral per-session signature key signed by long-term client certificate is used for client authorization – this session signature key will be passed in SMP handshake.
|
||||
|
||||
To transition existing queues, the subscription command will have to be double-signed - by the queue key, and then by client key.
|
||||
|
||||
When server receives such "hand-over" subscription it would create a permanent association between the client certificate and the queue, and on subsequent re-connections the client can subscribe to all the existing queues still associated with the client with one command.
|
||||
|
||||
The server will respond to the client with the number of queues it was subscribed to - it would both inform the client that it has to re-connect in case of interruption, and can be used for client and server statistics.
|
||||
|
||||
When client creates a new queue, it would also sign the request with both keys, per-queue and client's. Other queue operations (e.g., deletion, or changing associated queue data for short links) would still require two signatures, both the queue key and the client key.
|
||||
|
||||
The open question is whether there is any value in allowing to remove the association between the client and the queue. Probably not, as threat model should assume that the server would retain this information, and the use-case for users controlling their servers is narrow.
|
||||
|
||||
## Protocol connection handshake
|
||||
|
||||
Currently, the types for handshakes are:
|
||||
|
||||
```haskell
|
||||
data ServerHandshake = ServerHandshake
|
||||
{ smpVersionRange :: VersionRangeSMP,
|
||||
sessionId :: SessionId,
|
||||
-- pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
-- todo C.PublicKeyX25519
|
||||
authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
|
||||
}
|
||||
|
||||
data ClientHandshake = ClientHandshake
|
||||
{ -- | agreed SMP server protocol version
|
||||
smpVersion :: VersionSMP,
|
||||
-- | server identity - CA certificate fingerprint
|
||||
keyHash :: C.KeyHash,
|
||||
-- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
|
||||
authPubKey :: Maybe C.PublicKeyX25519,
|
||||
-- | Whether connecting client is a proxy server (send from SMP v12).
|
||||
-- This property, if True, disables additional transport encrytion inside TLS.
|
||||
-- (Proxy server connection already has additional encryption, so this layer is not needed there).
|
||||
proxyServer :: Bool
|
||||
}
|
||||
```
|
||||
|
||||
`ServerHandshake` already contains `authPubKey` with the server certificate chain and the signed key for connection encryption and creating a shared secret for denable authorization (with client entity key) and session encryption layer.
|
||||
|
||||
`ClientHandshake` contains only ephemeral `authPubKey` to compute a shared secret for session encryption layer, so we need an additional field for an optional client certificate:
|
||||
|
||||
```haskell
|
||||
serviceCertKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
|
||||
```
|
||||
|
||||
Certificate here defines client identity. The actual key to be used to sign commands is session-scoped, and is signed by the certificate key. In case of notification server it MUST be the same certificate that is used for server TLS connections.
|
||||
|
||||
For operators' clients we may optionally include operators' certificate in the chain, and that would allow servers to identify operators if either wants to. This would improve end-user security, as not only the server would validate that its certificate matches the address, but it would also validate that it is operated by SimpleX Chat or by Flux, preventing any server impersonation (e.g., via DNS manipulations) - the client could then report that the files are hosted on SimpleX Chat servers, but then can stop and show additional warning in case certificate does not match the domain - same as the browsers do with CA stores in the client.
|
||||
|
||||
## Protocol transmissions
|
||||
|
||||
Each transport block can contain one or several protocol transmissions.
|
||||
|
||||
Each transmission has this structure:
|
||||
|
||||
```abnf
|
||||
transmission = authenticator authorized
|
||||
; authenticator - Ed25519 signature for recipients or X25519 authenticator for senders, to provide repudiation.
|
||||
; authenticator authorizes the rest of the transmission.
|
||||
authorized = sessId corrId entityId command.
|
||||
; sessId is tls-unique channel binding, its presense in the transmission prevents replay attacks.
|
||||
```
|
||||
|
||||
The proposed change would replace authenticator with exactly one or two authenticators, where the first one will remain resource-level authorization (queue key), and the optional second one will be client authorization with the client key.
|
||||
|
||||
```abnf
|
||||
authenticator = queue_authenticator ("0" / "1" service_authenticator)
|
||||
; "0" and "1" characters (digit characters, not x00 or x01) are conventionally used for Maybe types in the protocol.
|
||||
```
|
||||
|
||||
In case service_authenticator is present, queue_authenticator should authorize over `fingerprint authorized` (concatenation of service identity certificate fingerprint and the rest of the transmission).
|
||||
|
||||
All queues created with client key will have to be double-authorized with both the queue key and the client key - both the client and the server would have to maintain this knowledge, whether the queue is associated with the client or not.
|
||||
|
||||
Asymmetric retries have to be supported - the first request creating this association may succeed on the server and timeout on the client.
|
||||
|
||||
## Subscription
|
||||
|
||||
To subscribe to all associated queues the client has to send a single command authorized with the client key passed in handshake.
|
||||
|
||||
The command and response:
|
||||
|
||||
```haskell
|
||||
SUBS :: Command Recipient -- to enable all client subscriptions, empty entity ID in the transmission, signed by client key - it must be the same as was used in handover subscription signature.
|
||||
NSUBS :: Command Recipient -- notification subscription
|
||||
SOK :: Maybe ServiceId -- new subscription response
|
||||
SOKS :: Int64 -> BrokerMsg -- response from the server, includes the number of subscribed queues
|
||||
ENDS :: Int64 -> BrokerMsg -- when another session subscribes with the same certificate
|
||||
```
|
||||
|
||||
Open questions:
|
||||
- What should used as an entity ID for `SUBS` transmission - certificate fingerprint or an empty string?
|
||||
- Should there be a command to get the list of all associated queues? It is likely to be useful for debugging?
|
||||
- What should happen when `SUB` is sent for a single already associated queue? What if it is signed with the correct session key, but that is different from existing association? The current approach is that once associated, this associaiton would require authorization for single subscriptions, with the same certificate as already associated.
|
||||
|
||||
## Ephemeral client-session association
|
||||
|
||||
This was considered to reduce costs for the usual clients to re-subscribe. Currently it's a big problem, because of groups, and with transition to chat relays it won't be.
|
||||
|
||||
For some very busy end-user clients it may help.
|
||||
|
||||
Given that server has access to an ephemeral association between recipient client session and queues anyway (even with clients connecting via Tor, unless per-connection transport isolation is used), introducing `sessionPubKey` to allow resubscription to the previously subscribed queues may reduce the traffic. This won't change threat model as the server would only keep this association in memory, and not persist it. Clients on another hand may safely persist this association for fast resubscription on client restarts.
|
||||
|
||||
This is not planned for the forseable future, as migrating to chat relays would solve most of the problem.
|
||||
|
||||
Assuming an average active user has 20 contacts and 20 groups, and they would need ~3 subscriptions for each (for redundancy), so about 120 subscription to reconnect. The single 16kb transport block allows to send ~136 subscriptions. Which means that ephemeral sessions would create no value for clients at all, unless they are super active.
|
||||
|
||||
Further, improving transport efficiency for super-active non-identified clients may help network abuse, so ephemeral sessions may have negative value.
|
||||
+142
-485
@@ -1,8 +1,13 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
# Make sure that PATH variable contains /usr/local/bin
|
||||
PATH="/usr/local/bin:$PATH"
|
||||
# Links to scripts/configs
|
||||
scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
|
||||
scripts_systemd_smp="$scripts/smp-server.service"
|
||||
scripts_systemd_xftp="$scripts/xftp-server.service"
|
||||
scripts_update="$scripts/simplex-servers-update"
|
||||
scripts_uninstall="$scripts/simplex-servers-uninstall"
|
||||
scripts_stopscript="$scripts/simplex-servers-stopscript"
|
||||
|
||||
# Default installation paths
|
||||
path_bin="/usr/local/bin"
|
||||
@@ -17,9 +22,7 @@ path_systemd_smp="$path_systemd/smp-server.service"
|
||||
path_systemd_xftp="$path_systemd/xftp-server.service"
|
||||
|
||||
# Temporary paths
|
||||
path_tmp_bin="/tmp/simplex-servers"
|
||||
path_tmp_bin_smp="$path_tmp_bin/smp-server"
|
||||
path_tmp_bin_xftp="$path_tmp_bin/xftp-server"
|
||||
path_tmp_bin="$(mktemp -d)"
|
||||
path_tmp_bin_update="$path_tmp_bin/simplex-servers-update"
|
||||
path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall"
|
||||
path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
|
||||
@@ -34,549 +37,203 @@ BLU='\033[1;36m'
|
||||
YLW='\033[1;33m'
|
||||
RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
BLD='\033[1m'
|
||||
UNDRL='\033[4m'
|
||||
|
||||
NL='
|
||||
'
|
||||
|
||||
# Set VER globally and only once
|
||||
VER="${VER:-latest}"
|
||||
|
||||
# Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
|
||||
|
||||
######################
|
||||
### Misc functions ###
|
||||
######################
|
||||
os_test() {
|
||||
. /etc/os-release
|
||||
|
||||
# Checks "sanity" of downloaded thing, e.g. if it's really a script or binary
|
||||
check_sanity() {
|
||||
path="$1"
|
||||
criteria="$2"
|
||||
case "$VERSION_ID" in
|
||||
20.04|22.04) : ;;
|
||||
24.04) VERSION_ID='22.04' ;;
|
||||
*) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
|
||||
esac
|
||||
|
||||
case "$criteria" in
|
||||
string:*)
|
||||
pattern="$(printf '%s' "$criteria" | awk '{print $2}')"
|
||||
|
||||
if grep -q "$pattern" "$path"; then
|
||||
sane=0
|
||||
else
|
||||
sane=1
|
||||
fi
|
||||
;;
|
||||
file:*)
|
||||
pattern="$(printf '%s' "$criteria" | awk '{print $2}')"
|
||||
version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
|
||||
arch="$(uname -p)"
|
||||
|
||||
if file "$path" | grep -q "$pattern"; then
|
||||
sane=0
|
||||
else
|
||||
sane=1
|
||||
fi
|
||||
;;
|
||||
*) printf 'Unknown criteria.\n'; sane=1 ;;
|
||||
esac
|
||||
case "$arch" in
|
||||
x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
|
||||
*) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
|
||||
esac
|
||||
|
||||
unset path string
|
||||
|
||||
return "$sane"
|
||||
bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
|
||||
}
|
||||
|
||||
# Checks if old thing and new thing is different
|
||||
change_check() {
|
||||
old="$1"
|
||||
new="$2"
|
||||
|
||||
if [ -x "$new" ] || [ -f "$new" ]; then
|
||||
type="$(file $new)"
|
||||
else
|
||||
type='string'
|
||||
fi
|
||||
|
||||
case "$type" in
|
||||
*script*|*text*)
|
||||
if diff -q "$old" "$new" > /dev/null 2>&1; then
|
||||
changed=1
|
||||
else
|
||||
changed=0
|
||||
fi
|
||||
;;
|
||||
string)
|
||||
if [ "$old" = "$new" ]; then
|
||||
changed=1
|
||||
else
|
||||
changed=0
|
||||
fi
|
||||
;;
|
||||
esac
|
||||
|
||||
return "$changed"
|
||||
}
|
||||
|
||||
##########################
|
||||
### Misc functions END ###
|
||||
##########################
|
||||
|
||||
#########################
|
||||
### Support functions ###
|
||||
#########################
|
||||
|
||||
# Sets local/remote versions and "apps" variables
|
||||
check_versions() {
|
||||
# Sets:
|
||||
# - ver
|
||||
# - bin_url
|
||||
# - remote_version
|
||||
# - local_version
|
||||
# - apps
|
||||
|
||||
case "$VER" in
|
||||
latest)
|
||||
remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest 2>/dev/null | grep -i "tag_name" | awk -F \" '{print $4}')"
|
||||
|
||||
if [ -z "$remote_version" ]; then
|
||||
printf "${RED}Something went wrong when ${YLW}resolving the lastest version${NC}: either you don't have connection to Github or you're rate-limited.\n"
|
||||
exit 1
|
||||
fi
|
||||
;;
|
||||
*)
|
||||
# Check if this version really exist
|
||||
ver_check="https://github.com/simplex-chat/simplexmq/releases/tag/${VER}"
|
||||
|
||||
if curl -o /dev/null --proto '=https' --tlsv1.2 -sf -L "${ver_check}"; then
|
||||
remote_version="${VER}"
|
||||
else
|
||||
printf "Provided version ${BLU}%s${NC} ${RED}doesn't exist${NC}! Switching to ${BLU}latest${NC}.\n" "${VER}"
|
||||
VER='latest'
|
||||
|
||||
# Re-execute check
|
||||
check_versions
|
||||
|
||||
# Everything has been done, so return from the function
|
||||
return 0
|
||||
fi
|
||||
;;
|
||||
esac
|
||||
|
||||
# Links to scripts/configs
|
||||
bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${remote_version}"
|
||||
scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/refs/tags/${remote_version}/scripts/main"
|
||||
scripts_url_systemd_smp="$scripts_url/smp-server.service"
|
||||
scripts_url_systemd_xftp="$scripts_url/xftp-server.service"
|
||||
scripts_url_update="$scripts_url/simplex-servers-update"
|
||||
scripts_url_uninstall="$scripts_url/simplex-servers-uninstall"
|
||||
scripts_url_stopscript="$scripts_url/simplex-servers-stopscript"
|
||||
|
||||
installed_test() {
|
||||
set +u
|
||||
for i in smp xftp; do
|
||||
# Only check local directory where binaries are installed by the script
|
||||
if command -v "/usr/local/bin/$i-server" >/dev/null; then
|
||||
apps="$i $apps"
|
||||
for i in $path_conf_etc/*; do
|
||||
if [ -d "$i" ]; then
|
||||
case "$i" in
|
||||
*simplex) apps="smp $apps" ;;
|
||||
*simplex-xftp) apps="xftp $apps" ;;
|
||||
esac
|
||||
fi
|
||||
done
|
||||
set -u
|
||||
|
||||
if [ -z "$apps" ]; then
|
||||
printf "${RED}No simplex servers installed! Aborting.${NC}\n"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
for server in $apps; do
|
||||
# Check if info file is present
|
||||
if [ -f "$path_conf_info/release" ]; then
|
||||
# If present, source it
|
||||
. "$path_conf_info/release" 2>/dev/null
|
||||
|
||||
# Check if line containing local version exists in file
|
||||
if grep -q "local_version_${server}" "$path_conf_info/release"; then
|
||||
# if exists, set the var
|
||||
eval "local_version=\$local_version_${server}"
|
||||
else
|
||||
# If it doesn't, append it to file
|
||||
printf "local_version_${server}=unset\n" >> "$path_conf_info/release"
|
||||
# And set it in script (so we don't have to re-source the file)
|
||||
eval "local_version_${server}=unset"
|
||||
fi
|
||||
else
|
||||
# If there isn't info file, populate it
|
||||
printf "local_version_${server}=unset\n" >> "$path_conf_info/release"
|
||||
fi
|
||||
done
|
||||
|
||||
# Return
|
||||
return 0
|
||||
}
|
||||
|
||||
# Checks the distro and sets the urls variables
|
||||
check_distro() {
|
||||
. /etc/os-release
|
||||
set_version() {
|
||||
ver="${VER:-latest}"
|
||||
|
||||
case "$VERSION_ID" in
|
||||
20.04|22.04) : ;;
|
||||
24.04) VERSION_ID='22.04' ;;
|
||||
*) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
|
||||
case "$ver" in
|
||||
latest)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
|
||||
;;
|
||||
*)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
|
||||
remote_version="${ver}"
|
||||
;;
|
||||
esac
|
||||
|
||||
version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
|
||||
arch="$(uname -p)"
|
||||
|
||||
case "$arch" in
|
||||
x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
|
||||
*) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
|
||||
esac
|
||||
|
||||
bin_url_smp="$bin_url/smp-server-ubuntu-${version}-${arch}"
|
||||
bin_url_xftp="$bin_url/xftp-server-ubuntu-${version}-${arch}"
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
# General checks that must be performed on the initial execution of script
|
||||
checks() {
|
||||
if [ "$(id -u)" -ne 0 ]; then
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n"
|
||||
exit 1
|
||||
update_scripts() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_tmp_bin_uninstall" && chmod +x "$path_tmp_bin_uninstall"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_tmp_bin_stopscript" && chmod +x "$path_tmp_bin_stopscript"
|
||||
|
||||
if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_uninstall"
|
||||
else
|
||||
printf -- "- Updating uninstall script..."
|
||||
mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
check_versions
|
||||
check_distro
|
||||
if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_stopscript"
|
||||
else
|
||||
printf -- "- Updating stopscript script..."
|
||||
mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
mkdir -p $path_conf_info $path_tmp_bin
|
||||
|
||||
return 0
|
||||
if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_update"
|
||||
else
|
||||
printf -- "- Updating update script..."
|
||||
mv "$path_tmp_bin_update" "$path_bin_update"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
printf -- "- Re-executing Update script with latest updates..."
|
||||
exec sh "$path_bin_update" "continue"
|
||||
fi
|
||||
}
|
||||
|
||||
#############################
|
||||
### Support functions END ###
|
||||
#############################
|
||||
|
||||
######################
|
||||
### Main functions ###
|
||||
######################
|
||||
|
||||
# Downloads thing to directory and checks its sanity
|
||||
download_thing() {
|
||||
thing="$1"
|
||||
path="$2"
|
||||
check_pattern="$3"
|
||||
err_msg="$4"
|
||||
|
||||
if ! curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path"; then
|
||||
printf "${RED}Something went wrong when downloading ${YLW}%s${NC}: either you don't have connection to Github or you're rate-limited.\n" "$err_msg"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
type="$(file "$path")"
|
||||
|
||||
case "$type" in
|
||||
*script*|*executable*) chmod +x "$path" ;;
|
||||
esac
|
||||
|
||||
if ! check_sanity "$path" "$check_pattern"; then
|
||||
printf "${RED}Something went wrong with downloaded ${YLW}%s${NC}: file is corrupted.\n" "$err_msg"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
# Downloads all necessary files to temp dir and set update messages for the menu
|
||||
download_all() {
|
||||
download_thing "$scripts_url_update" "$path_tmp_bin_update" 'string: /usr/bin/env' 'Update script'
|
||||
if change_check "$path_tmp_bin_update" "$path_bin_update"; then
|
||||
msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-update${NC}"
|
||||
msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}update"
|
||||
fi
|
||||
|
||||
download_thing "$scripts_url_stopscript" "$path_tmp_bin_stopscript" 'string: /usr/bin/env' 'Stop script'
|
||||
if change_check "$path_tmp_bin_stopscript" "$path_bin_stopscript"; then
|
||||
msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-stopscript${NC}"
|
||||
msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}stop"
|
||||
fi
|
||||
|
||||
download_thing "$scripts_url_uninstall" "$path_tmp_bin_uninstall" 'string: /usr/bin/env' 'Uninstall script'
|
||||
if change_check "$path_tmp_bin_uninstall" "$path_bin_uninstall"; then
|
||||
msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-uninstall${NC}"
|
||||
msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}uninstall"
|
||||
fi
|
||||
|
||||
for i in $apps; do
|
||||
service="${i}-server"
|
||||
eval "scripts_url_systemd_final=\$scripts_url_systemd_${i}"
|
||||
eval "path_tmp_systemd_final=\$path_tmp_systemd_${i}"
|
||||
eval "path_systemd_final=\$path_systemd_${i}"
|
||||
update_systemd() {
|
||||
service="${1}-server"
|
||||
eval "scripts_systemd=\$scripts_systemd_${1}"
|
||||
eval "path_systemd=\$path_systemd_${1}"
|
||||
eval "path_tmp_systemd=\$path_tmp_systemd_${1}"
|
||||
|
||||
download_thing "$scripts_url_systemd_final" "$path_tmp_systemd_final" 'string: [Unit]' "$service systemd service"
|
||||
if change_check "$path_tmp_systemd_final" "$path_systemd_final"; then
|
||||
msg_services="${msg_services+$msg_services, }${YLW}$service.service${NC}"
|
||||
msg_services_raw="${msg_services_raw+$msg_services_raw/}$service"
|
||||
fi
|
||||
done
|
||||
|
||||
for i in $apps; do
|
||||
service="${i}-server"
|
||||
eval "local_version=\$local_version_${i}"
|
||||
|
||||
if change_check "$local_version" "$remote_version"; then
|
||||
msg_bins="${msg_bins+$msg_bins$NL} - ${YLW}$service${NC}: from ${BLU}$local_version${NC} to ${BLU}$remote_version${NC}"
|
||||
msg_bins_alt="${msg_bins_alt+$msg_bins_alt, }${YLW}$service${NC}"
|
||||
msg_bins_raw="${msg_bins_raw+$msg_bins_raw/}$service"
|
||||
fi
|
||||
done
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
# Updates systemd and scripts. This function depends om variables from "download_all"
|
||||
update_misc() {
|
||||
OLD_IFS="$IFS"
|
||||
|
||||
IFS='/'
|
||||
for script in ${msg_scripts_raw:-}; do
|
||||
case "$script" in
|
||||
update)
|
||||
printf -- "- Updating update script..."
|
||||
mv "$path_tmp_bin_update" "$path_bin_update"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
printf -- "- Re-executing Update script..."
|
||||
exec env UPDATE_SCRIPT_DONE=1 VER="$remote_version" "$path_bin_update" "${selection}"
|
||||
;;
|
||||
stop)
|
||||
printf -- "- Updating stopscript script..."
|
||||
mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
;;
|
||||
uninstall)
|
||||
printf -- "- Updating uninstall script..."
|
||||
mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
;;
|
||||
esac
|
||||
done
|
||||
|
||||
for service in ${msg_services_raw:-}; do
|
||||
app="${service%%-*}"
|
||||
eval "path_systemd=\$path_systemd_${app}"
|
||||
eval "path_tmp_systemd=\$path_tmp_systemd_${app}"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_tmp_systemd"
|
||||
|
||||
if diff -q "$path_systemd" "$path_tmp_systemd" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}%s service is up-to-date${NC}.\n" "$service"
|
||||
rm "$path_tmp_systemd"
|
||||
else
|
||||
printf -- "- Updating %s service..." "$service"
|
||||
mv "$path_tmp_systemd" "$path_systemd"
|
||||
systemctl daemon-reload
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
done
|
||||
fi
|
||||
|
||||
IFS="$OLD_IFS"
|
||||
return 0
|
||||
unset service scripts_systemd path_systemd path_tmp_systemd
|
||||
}
|
||||
|
||||
# Updates binaries. This function depends on variables from "download_all"
|
||||
update_bins() {
|
||||
OLD_IFS="$IFS"
|
||||
service="${1}-server"
|
||||
eval "bin=\$bin_${1}"
|
||||
eval "path_bin=\$path_bin_${1}"
|
||||
|
||||
IFS='/'
|
||||
for service in ${msg_bins_raw:-}; do
|
||||
app="${service%%-*}"
|
||||
eval "local_version=\$local_version_${app}"
|
||||
eval "bin_url_final=\$bin_url_${app}"
|
||||
eval "path_tmp_bin_final=\$path_tmp_bin_${app}"
|
||||
eval "path_bin_final=\$path_bin_${app}"
|
||||
set_ver() {
|
||||
local_version='unset'
|
||||
sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release"
|
||||
}
|
||||
|
||||
# If systemd service is active
|
||||
if [ -f "$path_conf_info/release" ]; then
|
||||
. "$path_conf_info/release" 2>/dev/null
|
||||
|
||||
set +u
|
||||
eval "local_version=\$local_version_${1}"
|
||||
set -u
|
||||
|
||||
if [ -z "${local_version}" ]; then
|
||||
set_ver "$1"
|
||||
fi
|
||||
else
|
||||
printf 'local_version_xftp=\nlocal_version_smp=\n' > "$path_conf_info/release"
|
||||
set_ver "$1"
|
||||
fi
|
||||
|
||||
if [ "$local_version" != "$remote_version" ]; then
|
||||
if systemctl is-active --quiet "$service"; then
|
||||
printf -- "- Stopping %s service..." "$service"
|
||||
systemctl stop "$service"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version"
|
||||
download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
|
||||
mv "$path_tmp_bin_final" "$path_bin_final"
|
||||
printf -- "- Updating %s to %s..." "$service" "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Starting %s service..." "$service"
|
||||
systemctl start "$service"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
else
|
||||
# If systemd service is NOT active
|
||||
printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version"
|
||||
download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
|
||||
mv "$path_tmp_bin_final" "$path_bin_final"
|
||||
printf -- "- Updating %s to %s..." "$service" "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
# Don't forget to set version
|
||||
sed -i -- "s|local_version_${app}=.*|local_version_${app}='${remote_version}'|" "$path_conf_info/release"
|
||||
done
|
||||
|
||||
IFS="$OLD_IFS"
|
||||
return 0
|
||||
}
|
||||
|
||||
# Just download binaries
|
||||
download_bins() {
|
||||
OLD_IFS="$IFS"
|
||||
|
||||
IFS='/'
|
||||
for service in ${msg_bins_raw:-}; do
|
||||
app="${service%%-*}"
|
||||
eval "local_version=\$local_version_${app}"
|
||||
eval "bin_url_final=\$bin_url_${app}"
|
||||
eval "path_tmp_bin_final=\$path_tmp_bin_${app}"
|
||||
eval "path_bin_final=\$path_bin_${app}"
|
||||
|
||||
printf -- "- Downloading ${YLW}%s${NC} binary..." "$service"
|
||||
download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
done
|
||||
|
||||
IFS="$OLD_IFS"
|
||||
return 0
|
||||
}
|
||||
|
||||
menu_init_help() {
|
||||
menu_help="Update script for SimpleX servers and scripts.${NL}${NL}"
|
||||
menu_help="${menu_help}${BLD}${UNDRL}Usage:${NC} [<VARIABLE>] ${BLD}simplex-servers-update${NC}${NL} [<VARIABLE>] ${BLD}simplex-servers-update${NC} [<SUBCOMMAND>]${NL}${NL}"
|
||||
menu_help="${menu_help}${BLD}${UNDRL}Subcommands:${NC}${NL}"
|
||||
menu_help_sub=" ${BLD}[a]ll${NC} Update everything without confirmation${NL}"
|
||||
menu_help_sub="${menu_help_sub} ${BLD}[b]inaries${NC} Update binaries only without confirmation${NL}"
|
||||
menu_help_sub="${menu_help_sub} ${BLD}[d]ownload${NC} Download everything without updating${NL}"
|
||||
menu_help_sub="${menu_help_sub} ${BLD}[h]elp${NC} Print this message${NL}${NL}"
|
||||
menu_help="${menu_help}${menu_help_sub}"
|
||||
menu_help="${menu_help}${BLD}${UNDRL}Variables:${NC}${NL}"
|
||||
menu_help="${menu_help} ${BLD}VER=v3.2.1-beta.0${NC} Update binaries to specified version${NL}"
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
menu_init() {
|
||||
menu_end="${RED}x${NC}) Exit${NL}${NL}Selection: "
|
||||
menu_option_download="${GRN}d${NC}) Download files only${NL}"
|
||||
|
||||
if [ -n "${msg_scripts:-}" ]; then
|
||||
menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}} - script(s): ${msg_scripts}"
|
||||
else
|
||||
printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service"
|
||||
fi
|
||||
|
||||
if [ -n "${msg_services:-}" ]; then
|
||||
menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}} - systemd service file(s): ${msg_services}"
|
||||
fi
|
||||
set_ver "$1"
|
||||
|
||||
menu_option_all="${GRN}a${NC}) Update all: ${BLU}(recommended)${NC}${NL}${menu_option_misc_raw+${menu_option_misc_raw}${NL}}${msg_bins+${msg_bins}${NL}}"
|
||||
|
||||
if [ -n "${msg_bins:-}" ]; then
|
||||
menu_option_bins="${GRN}b${NC}) Update server binaries: ${msg_bins_alt}${NL}"
|
||||
fi
|
||||
|
||||
# Abort early if there's neither update binaries, nor update scripts options
|
||||
if [ -z "${menu_option_bins:-}" ] && [ -z "${menu_option_misc_raw:-}" ]; then
|
||||
printf "${YLW}Everything is up-to-date${NC}.\n"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
menu="${menu_option_all}${menu_option_bins:-}${menu_option_download}${menu_end}"
|
||||
|
||||
return 0
|
||||
unset service bin path_bin local_version
|
||||
}
|
||||
|
||||
options_parse() {
|
||||
selection="$1"
|
||||
|
||||
case "$selection" in
|
||||
a|all)
|
||||
check=0
|
||||
if [ -z "${menu_option_misc_raw:-}" ] && [ -z "${menu_option_bins:-}" ]; then
|
||||
printf "${YLW}Everything is up-to-date${NC}.\n"
|
||||
else
|
||||
if [ -n "${menu_option_misc_raw:-}" ]; then
|
||||
update_misc
|
||||
fi
|
||||
if [ -n "${menu_option_bins:-}" ]; then
|
||||
update_bins
|
||||
fi
|
||||
fi
|
||||
;;
|
||||
b|binaries)
|
||||
check=0
|
||||
if [ -n "${menu_option_bins:-}" ]; then
|
||||
update_bins
|
||||
else
|
||||
printf "${YLW}Binaries is up-to-date${NC}.\n"
|
||||
fi
|
||||
;;
|
||||
d|download)
|
||||
check=0
|
||||
if [ -n "${menu_option_bins:-}" ]; then
|
||||
download_bins
|
||||
fi
|
||||
checks() {
|
||||
if [ "$(id -u)" -ne 0 ]; then
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
printf "\n${YLW}Scripts${NC}/${YLW}services${NC}/${YLW}binaries${NC} has been downloaded to ${BLU}%s${NC}\n" "$path_tmp_bin"
|
||||
;;
|
||||
x)
|
||||
check=0
|
||||
;;
|
||||
*)
|
||||
check=1
|
||||
;;
|
||||
esac
|
||||
set_version
|
||||
os_test
|
||||
installed_test
|
||||
|
||||
return "$check"
|
||||
mkdir -p $path_conf_info
|
||||
}
|
||||
|
||||
##########################
|
||||
### Main functions END ###
|
||||
##########################
|
||||
|
||||
############
|
||||
### Init ###
|
||||
############
|
||||
|
||||
main() {
|
||||
# Early hook to print Done after script re-execution
|
||||
if [ -n "${UPDATE_SCRIPT_DONE:-}" ]; then
|
||||
checks
|
||||
|
||||
set +u
|
||||
if [ "$1" != "continue" ]; then
|
||||
set -u
|
||||
printf "Updating scripts...\n"
|
||||
update_scripts
|
||||
else
|
||||
set -u
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
# Early help menu
|
||||
menu_init_help
|
||||
|
||||
case "${1:-}" in
|
||||
h|help)
|
||||
printf '%b' "$menu_help"
|
||||
exit 0
|
||||
;;
|
||||
esac
|
||||
|
||||
checks
|
||||
download_all
|
||||
menu_init
|
||||
|
||||
onetime=0
|
||||
while true; do
|
||||
if [ "$onetime" = 0 ]; then
|
||||
onetime=1
|
||||
|
||||
if [ -n "${1:-}" ]; then
|
||||
selection="$1"
|
||||
else
|
||||
printf '%b' "$menu"
|
||||
read selection
|
||||
fi
|
||||
else
|
||||
read selection
|
||||
fi
|
||||
|
||||
if options_parse "$selection"; then
|
||||
break
|
||||
else
|
||||
# Rerender whole menu if the first non-interactive option was bogus
|
||||
if [ -n "${1:-}" ]; then
|
||||
onetime=0
|
||||
shift 1
|
||||
else
|
||||
# Erase last line
|
||||
printf '\e[A\e[K'
|
||||
# Only rerended selection
|
||||
printf 'Selection: '
|
||||
fi
|
||||
fi
|
||||
printf "Updating systemd services...\n"
|
||||
for i in $apps; do
|
||||
update_systemd "$i"
|
||||
done
|
||||
|
||||
printf "Updating simplex servers...\n"
|
||||
for i in $apps; do
|
||||
update_bins "$i"
|
||||
done
|
||||
|
||||
rm -rf "$path_tmp_bin"
|
||||
}
|
||||
|
||||
main "$@"
|
||||
|
||||
@@ -1,139 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
TAG="$1"
|
||||
|
||||
tempdir="$(mktemp -d)"
|
||||
init_dir="$PWD"
|
||||
|
||||
repo_name="simplexmq"
|
||||
repo="https://github.com/simplex-chat/${repo_name}"
|
||||
export DOCKER_BUILDKIT=1
|
||||
|
||||
cleanup() {
|
||||
docker exec -t builder sh -c 'rm -rf ./dist-newstyle' 2>/dev/null || :
|
||||
rm -rf -- "$tempdir"
|
||||
docker rm --force builder 2>/dev/null || :
|
||||
docker image rm local 2>/dev/null || :
|
||||
cd "$init_dir"
|
||||
}
|
||||
trap 'cleanup' EXIT INT
|
||||
|
||||
mkdir -p "$init_dir/$TAG-$repo_name/from-source" "$init_dir/$TAG-$repo_name/prebuilt"
|
||||
|
||||
git -C "$tempdir" clone "$repo.git" &&\
|
||||
cd "$tempdir/${repo_name}" &&\
|
||||
git checkout "$TAG"
|
||||
|
||||
for os in 22.04 24.04; do
|
||||
os_url="$(printf '%s' "$os" | tr '.' '_')"
|
||||
|
||||
# Build image
|
||||
docker build \
|
||||
--no-cache \
|
||||
--build-arg TAG=${os} \
|
||||
--build-arg GHC=9.6.3 \
|
||||
-f "$tempdir/simplexmq/Dockerfile.build" \
|
||||
-t local \
|
||||
.
|
||||
|
||||
# Run container in background
|
||||
docker run -t -d \
|
||||
--name builder \
|
||||
-v "$tempdir/${repo_name}:/project" \
|
||||
local
|
||||
|
||||
# PostgreSQL build (only smp-server)
|
||||
docker exec \
|
||||
-t \
|
||||
builder \
|
||||
sh -c 'cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
|
||||
|
||||
# Copy smp-server postgresql binary and prepare it
|
||||
docker cp \
|
||||
builder:/out/smp-server \
|
||||
"$init_dir/$TAG-$repo_name/from-source/smp-server-postgres-ubuntu-${os_url}-x86-64"
|
||||
|
||||
# Download prebuilt postgresql binary
|
||||
curl -L \
|
||||
--output-dir "$init_dir/$TAG-$repo_name/prebuilt/" \
|
||||
-O \
|
||||
"$repo/releases/download/${TAG}/smp-server-postgres-ubuntu-${os_url}-x86-64"
|
||||
|
||||
# Regular build (all)
|
||||
apps='smp-server xftp-server ntf-server xftp'
|
||||
|
||||
docker exec \
|
||||
-t \
|
||||
-e apps="$apps" \
|
||||
builder \
|
||||
sh -c 'cabal build --jobs=$(nproc) && mkdir -p /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && strip "$bin" && chmod +x "$bin" && mv "$bin" /out/; done'
|
||||
|
||||
# Copy regular binaries
|
||||
docker cp \
|
||||
builder:/out \
|
||||
out-${os}
|
||||
|
||||
# Prepare regular binaries and download the prebuilt ones
|
||||
for app in $apps; do
|
||||
curl -L \
|
||||
--output-dir "$init_dir/$TAG-$repo_name/prebuilt/" \
|
||||
-O \
|
||||
"$repo/releases/download/${TAG}/${app}-ubuntu-${os_url}-x86-64"
|
||||
|
||||
mv "./out-${os}/$app" "$init_dir/$TAG-$repo_name/from-source/${app}-ubuntu-${os_url}-x86-64"
|
||||
done
|
||||
|
||||
# Important! Remove dist-newstyle for the next interation
|
||||
docker exec \
|
||||
-t \
|
||||
builder \
|
||||
sh -c 'rm -rf ./dist-newstyle'
|
||||
|
||||
# Also restore git to previous state
|
||||
git reset --hard && git clean -dfx
|
||||
|
||||
# Stop containers, delete images
|
||||
docker stop builder
|
||||
docker rm --force builder
|
||||
docker image rm local
|
||||
done
|
||||
|
||||
# Cleanup
|
||||
rm -rf -- "$tempdir"
|
||||
cd "$init_dir"
|
||||
|
||||
# Final stage: compare hashes
|
||||
|
||||
# Path to binaries
|
||||
path_bin="$init_dir/$TAG-$repo_name"
|
||||
|
||||
# Assume everything is okay for now
|
||||
bad=0
|
||||
|
||||
# Check hashes for all binaries
|
||||
for file in "$path_bin"/from-source/*; do
|
||||
# Extract binary name
|
||||
app="$(basename $file)"
|
||||
|
||||
# Compute hash for compiled binary
|
||||
compiled=$(sha256sum "$path_bin/from-source/$app" | awk '{print $1}')
|
||||
# Compute hash for prebuilt binary
|
||||
prebuilt=$(sha256sum "$path_bin/prebuilt/$app" | awk '{print $1}')
|
||||
|
||||
# Compare
|
||||
if [ "$compiled" != "$prebuilt" ]; then
|
||||
# If hashes doesn't match, set bad...
|
||||
bad=1
|
||||
|
||||
# ... and print affected binary
|
||||
printf "%s - sha256sum hash doesn't match\n" "$app"
|
||||
fi
|
||||
done
|
||||
|
||||
# If everything is still okay, compute checksums file
|
||||
if [ "$bad" = 0 ]; then
|
||||
sha256sum "$path_bin"/from-source/* | sed -e "s|$PWD/||g" -e 's|from-source/||g' -e "s|-$repo_name||g" > "$path_bin/_sha256sums"
|
||||
|
||||
printf 'Checksums computed - %s\n' "$path_bin/_sha256sums"
|
||||
fi
|
||||
+36
-89
@@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: simplexmq
|
||||
version: 6.4.1.0
|
||||
version: 6.3.0.3
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -72,11 +72,6 @@ flag client_postgres
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
flag server_postgres
|
||||
description: Build server with support of PostgreSQL.
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Simplex.FileTransfer.Agent
|
||||
@@ -105,8 +100,6 @@ library
|
||||
Simplex.Messaging.Agent.Store.DB
|
||||
Simplex.Messaging.Agent.Store.Interface
|
||||
Simplex.Messaging.Agent.Store.Migrations
|
||||
Simplex.Messaging.Agent.Store.Migrations.App
|
||||
Simplex.Messaging.Agent.Store.Postgres.Options
|
||||
Simplex.Messaging.Agent.Store.Shared
|
||||
Simplex.Messaging.Agent.TRcvQueues
|
||||
Simplex.Messaging.Client
|
||||
@@ -121,7 +114,6 @@ library
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
|
||||
Simplex.Messaging.Crypto.ShortLink
|
||||
Simplex.Messaging.Encoding
|
||||
Simplex.Messaging.Encoding.String
|
||||
Simplex.Messaging.Notifications.Client
|
||||
@@ -131,11 +123,9 @@ library
|
||||
Simplex.Messaging.Parsers
|
||||
Simplex.Messaging.Protocol
|
||||
Simplex.Messaging.Server.Expiration
|
||||
Simplex.Messaging.Server.QueueStore.Postgres.Config
|
||||
Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
Simplex.Messaging.ServiceScheme
|
||||
Simplex.Messaging.Session
|
||||
Simplex.Messaging.Agent.Store.Entity
|
||||
Simplex.Messaging.TMap
|
||||
Simplex.Messaging.Transport
|
||||
Simplex.Messaging.Transport.Buffer
|
||||
@@ -147,7 +137,6 @@ library
|
||||
Simplex.Messaging.Transport.HTTP2.Server
|
||||
Simplex.Messaging.Transport.KeepAlive
|
||||
Simplex.Messaging.Transport.Server
|
||||
Simplex.Messaging.Transport.Shared
|
||||
Simplex.Messaging.Util
|
||||
Simplex.Messaging.Version
|
||||
Simplex.Messaging.Version.Internal
|
||||
@@ -158,18 +147,20 @@ library
|
||||
Simplex.RemoteControl.Types
|
||||
if flag(client_postgres)
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.App
|
||||
Simplex.Messaging.Agent.Store.Postgres
|
||||
Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
|
||||
if !flag(client_library)
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.Postgres.Util
|
||||
else
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.SQLite
|
||||
Simplex.Messaging.Agent.Store.SQLite.Common
|
||||
Simplex.Messaging.Agent.Store.SQLite.DB
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.App
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
|
||||
@@ -207,16 +198,6 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
|
||||
if flag(client_postgres) || flag(server_postgres)
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.Postgres
|
||||
Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations
|
||||
Simplex.Messaging.Agent.Store.Postgres.Util
|
||||
if !flag(client_library)
|
||||
exposed-modules:
|
||||
Simplex.FileTransfer.Client.Main
|
||||
@@ -227,45 +208,33 @@ library
|
||||
Simplex.FileTransfer.Server.Stats
|
||||
Simplex.FileTransfer.Server.Store
|
||||
Simplex.FileTransfer.Server.StoreLog
|
||||
Simplex.Messaging.Notifications.Server
|
||||
Simplex.Messaging.Notifications.Server.Control
|
||||
Simplex.Messaging.Notifications.Server.Env
|
||||
Simplex.Messaging.Notifications.Server.Main
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
Simplex.Messaging.Notifications.Server.StoreLog
|
||||
Simplex.Messaging.Server
|
||||
Simplex.Messaging.Server.CLI
|
||||
Simplex.Messaging.Server.Control
|
||||
Simplex.Messaging.Server.Env.STM
|
||||
Simplex.Messaging.Server.Information
|
||||
Simplex.Messaging.Server.Main
|
||||
Simplex.Messaging.Server.Main.Init
|
||||
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.NtfStore
|
||||
Simplex.Messaging.Server.Prometheus
|
||||
Simplex.Messaging.Server.QueueStore
|
||||
Simplex.Messaging.Server.QueueStore.STM
|
||||
Simplex.Messaging.Server.QueueStore.Types
|
||||
Simplex.Messaging.Server.Stats
|
||||
Simplex.Messaging.Server.StoreLog
|
||||
Simplex.Messaging.Server.StoreLog.ReadWrite
|
||||
Simplex.Messaging.Server.StoreLog.Types
|
||||
Simplex.Messaging.Transport.WebSockets
|
||||
if flag(server_postgres)
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Notifications.Server
|
||||
Simplex.Messaging.Notifications.Server.Control
|
||||
Simplex.Messaging.Notifications.Server.Env
|
||||
Simplex.Messaging.Notifications.Server.Main
|
||||
Simplex.Messaging.Notifications.Server.Prometheus
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
Simplex.Messaging.Notifications.Server.Store.Migrations
|
||||
Simplex.Messaging.Notifications.Server.Store.Postgres
|
||||
Simplex.Messaging.Notifications.Server.Store.Types
|
||||
Simplex.Messaging.Notifications.Server.StoreLog
|
||||
Simplex.Messaging.Server.QueueStore.Postgres
|
||||
Simplex.Messaging.Server.QueueStore.Postgres.Migrations
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
@@ -302,6 +271,7 @@ library
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
@@ -310,11 +280,13 @@ library
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, socks ==0.6.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.9.0 && <1.10
|
||||
@@ -330,26 +302,18 @@ library
|
||||
build-depends:
|
||||
case-insensitive ==1.2.*
|
||||
, hashable ==1.4.*
|
||||
, ini ==0.4.1
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, temporary ==1.3.*
|
||||
, unix ==2.8.*
|
||||
, websockets ==0.12.*
|
||||
if flag(client_postgres) || flag(server_postgres)
|
||||
if flag(client_postgres)
|
||||
build-depends:
|
||||
postgresql-libpq >=0.10.0.0
|
||||
, postgresql-simple ==0.7.*
|
||||
, raw-strings-qq ==1.1.*
|
||||
if flag(client_postgres)
|
||||
cpp-options: -DdbPostgres
|
||||
else
|
||||
build-depends:
|
||||
direct-sqlcipher ==2.3.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
if flag(server_postgres)
|
||||
cpp-options: -DdbServerPostgres
|
||||
build-depends:
|
||||
hex-text ==0.1.*
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
@@ -362,10 +326,6 @@ library
|
||||
executable ntf-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
if flag(server_postgres)
|
||||
cpp-options: -DdbServerPostgres
|
||||
else
|
||||
buildable: False
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
@@ -383,8 +343,6 @@ executable ntf-server
|
||||
executable smp-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
if flag(server_postgres)
|
||||
cpp-options: -DdbServerPostgres
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Static
|
||||
@@ -458,8 +416,8 @@ test-suite simplexmq-test
|
||||
AgentTests.EqInstances
|
||||
AgentTests.FunctionalAPITests
|
||||
AgentTests.MigrationTests
|
||||
AgentTests.NotificationTests
|
||||
AgentTests.ServerChoice
|
||||
AgentTests.ShortLinkTests
|
||||
CLITests
|
||||
CoreTests.BatchingTests
|
||||
CoreTests.CryptoFileTests
|
||||
@@ -473,6 +431,9 @@ test-suite simplexmq-test
|
||||
CoreTests.UtilTests
|
||||
CoreTests.VersionRangeTests
|
||||
FileDescriptionTests
|
||||
Fixtures
|
||||
NtfClient
|
||||
NtfServerTests
|
||||
RemoteControl
|
||||
ServerTests
|
||||
SMPAgentClient
|
||||
@@ -486,25 +447,15 @@ test-suite simplexmq-test
|
||||
Static
|
||||
Static.Embedded
|
||||
Paths_simplexmq
|
||||
if flag(client_postgres)
|
||||
other-modules:
|
||||
Fixtures
|
||||
else
|
||||
if !flag(client_postgres)
|
||||
other-modules:
|
||||
AgentTests.SchemaDump
|
||||
AgentTests.SQLiteTests
|
||||
if flag(server_postgres)
|
||||
other-modules:
|
||||
AgentTests.NotificationTests
|
||||
NtfClient
|
||||
NtfServerTests
|
||||
PostgresSchemaDump
|
||||
hs-source-dirs:
|
||||
tests
|
||||
apps/smp-server/web
|
||||
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
|
||||
build-depends:
|
||||
base
|
||||
@@ -517,13 +468,13 @@ test-suite simplexmq-test
|
||||
, crypton-x509
|
||||
, crypton-x509-store
|
||||
, crypton-x509-validation
|
||||
, deepseq ==1.4.*
|
||||
, directory
|
||||
, file-embed
|
||||
, filepath
|
||||
, generic-random ==1.5.*
|
||||
, hashable
|
||||
, hspec ==2.11.*
|
||||
, hspec-core ==2.11.*
|
||||
, http-client
|
||||
, http-types
|
||||
, http2
|
||||
@@ -531,8 +482,10 @@ test-suite simplexmq-test
|
||||
, ini
|
||||
, iso8601-time
|
||||
, main-tester ==0.2.*
|
||||
, memory
|
||||
, mtl
|
||||
, network
|
||||
, process
|
||||
, QuickCheck ==2.14.*
|
||||
, random
|
||||
, silently ==1.2.*
|
||||
@@ -552,18 +505,12 @@ test-suite simplexmq-test
|
||||
, warp-tls
|
||||
, yaml
|
||||
default-language: Haskell2010
|
||||
if flag(server_postgres)
|
||||
cpp-options: -DdbServerPostgres
|
||||
if flag(client_postgres)
|
||||
build-depends:
|
||||
postgresql-libpq >=0.10.0.0
|
||||
, postgresql-simple ==0.7.*
|
||||
, raw-strings-qq ==1.1.*
|
||||
cpp-options: -DdbPostgres
|
||||
else
|
||||
build-depends:
|
||||
memory
|
||||
, sqlcipher-simple
|
||||
if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres)
|
||||
build-depends:
|
||||
deepseq ==1.4.*
|
||||
, process
|
||||
if flag(client_postgres) || flag(server_postgres)
|
||||
build-depends:
|
||||
postgresql-simple ==0.7.*
|
||||
sqlcipher-simple
|
||||
|
||||
@@ -36,10 +36,8 @@ import Simplex.FileTransfer.Protocol
|
||||
import Simplex.FileTransfer.Transport
|
||||
import Simplex.Messaging.Client
|
||||
( NetworkConfig (..),
|
||||
NetworkRequestMode (..),
|
||||
ProtocolClientError (..),
|
||||
TransportSession,
|
||||
netTimeoutInt,
|
||||
chooseTransportHost,
|
||||
defaultNetworkConfig,
|
||||
transportClientConfig,
|
||||
@@ -58,8 +56,8 @@ import Simplex.Messaging.Protocol
|
||||
SenderId,
|
||||
pattern NoEntity,
|
||||
)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
@@ -101,7 +99,7 @@ defaultXFTPClientConfig =
|
||||
XFTPClientConfig
|
||||
{ xftpNetworkConfig = defaultNetworkConfig,
|
||||
serverVRange = supportedFileServerVRange,
|
||||
clientALPN = Just alpnSupportedXFTPhandshakes
|
||||
clientALPN = Just supportedXFTPhandshakes
|
||||
}
|
||||
|
||||
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
|
||||
@@ -109,7 +107,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
|
||||
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
|
||||
ProtocolServer _ host port keyHash = srv
|
||||
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
|
||||
let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN
|
||||
let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
|
||||
http2Config = xftpHTTP2Config tcConfig config
|
||||
clientVar <- newTVarIO Nothing
|
||||
let usePort = if null port then "443" else port
|
||||
@@ -118,7 +116,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
|
||||
let HTTP2Client {sessionId, sessionALPN} = http2Client
|
||||
v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
|
||||
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
|
||||
thParams@THandleParams {thVersion} <- case sessionALPN of
|
||||
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
|
||||
@@ -134,8 +132,7 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
|
||||
(vr, sk) <- processServerHandshake shs
|
||||
let v = maxVersion vr
|
||||
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
|
||||
let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
|
||||
pure thParams0 {thAuth, thVersion = v, thServerVRange = vr}
|
||||
pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v, thServerVRange = vr}
|
||||
where
|
||||
getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
|
||||
getServerHandshake = do
|
||||
@@ -150,12 +147,12 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
|
||||
Nothing -> throwE $ PCETransportError TEVersion
|
||||
Just (Compatible vr) ->
|
||||
fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do
|
||||
let CertChainPubKey (X.CertificateChain cert) exact = serverAuth
|
||||
let (X.CertificateChain cert, exact) = serverAuth
|
||||
case cert of
|
||||
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
|
||||
_ -> throwError "bad certificate"
|
||||
pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
|
||||
C.x509ToPublic' pubKey
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
|
||||
sendClientHandshake chs = do
|
||||
chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
|
||||
@@ -180,7 +177,7 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
|
||||
defaultHTTP2ClientConfig
|
||||
{ bodyHeadSize = xftpBlockSize,
|
||||
suportedTLSParams = defaultSupportedParams,
|
||||
connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
|
||||
connTimeout = tcpConnectTimeout,
|
||||
transportConfig
|
||||
}
|
||||
|
||||
@@ -206,7 +203,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
|
||||
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
|
||||
when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK
|
||||
-- TODO validate that the file ID is the same as in the request?
|
||||
(_, _fId, respOrErr) <-liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
|
||||
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
|
||||
case respOrErr of
|
||||
Right r -> case protocolError r of
|
||||
Just e -> throwE $ PCEProtocolError e
|
||||
@@ -270,11 +267,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
|
||||
|
||||
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
|
||||
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
|
||||
maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
|
||||
maybe tcpTimeout (chunkTimeout cfg) chunkSize_
|
||||
|
||||
chunkTimeout :: XFTPClientConfig -> Word32 -> Int
|
||||
chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
|
||||
netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
|
||||
tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
|
||||
|
||||
deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
|
||||
deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
|
||||
|
||||
@@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
@@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
|
||||
waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
|
||||
waitForXFTPClient clientVar = do
|
||||
let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
|
||||
client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
|
||||
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
|
||||
liftEither $ case client_ of
|
||||
Just (Right c) -> Right c
|
||||
Just (Left e) -> Left e
|
||||
@@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
|
||||
where
|
||||
closeClient cVar = do
|
||||
let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
|
||||
netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
|
||||
tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
|
||||
Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
|
||||
_ -> pure ()
|
||||
|
||||
@@ -280,7 +280,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
|
||||
let chunkSpecs = prepareChunkSpecs encPath chunkSizes
|
||||
fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
|
||||
fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
|
||||
logDebug $ "encrypted file to " <> tshow encPath
|
||||
logInfo $ "encrypted file to " <> tshow encPath
|
||||
pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
|
||||
uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
|
||||
uploadFile g chunks uploadedChunks encSize = do
|
||||
@@ -293,14 +293,14 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
|
||||
-- TODO shuffle/unshuffle chunks
|
||||
-- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
|
||||
-- upload doesn't allow other requests within the same client until complete (but download does allow).
|
||||
logDebug $ "uploading " <> tshow (length chunks) <> " chunks..."
|
||||
logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
|
||||
(errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a)
|
||||
mapM_ throwE errs
|
||||
pure $ map snd (sortOn fst rs)
|
||||
where
|
||||
uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
|
||||
uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
|
||||
logDebug $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
|
||||
logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
|
||||
digest <- liftIO $ getChunkDigest chunkSpec
|
||||
@@ -308,7 +308,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
|
||||
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
|
||||
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
|
||||
withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
|
||||
logDebug $ "uploaded chunk " <> tshow chunkNo
|
||||
logInfo $ "uploaded chunk " <> tshow chunkNo
|
||||
uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
|
||||
let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
|
||||
liftIO $ do
|
||||
@@ -418,11 +418,11 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
|
||||
downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
|
||||
downloadFileChunk g a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
|
||||
let FileChunkReplica {server, replicaId, replicaKey} = replica
|
||||
logDebug $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
|
||||
logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
|
||||
chunkPath <- uniqueCombine encPath $ show chunkNo
|
||||
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
|
||||
withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
|
||||
logDebug $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
|
||||
logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
|
||||
downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
|
||||
let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
|
||||
liftIO $ do
|
||||
@@ -467,7 +467,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
|
||||
deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
|
||||
let FileChunkReplica {server, replicaId, replicaKey} = replica
|
||||
withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
|
||||
logDebug $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
|
||||
logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
|
||||
deleteFileChunk _ _ = throwE $ CLIError "chunk has no replicas"
|
||||
|
||||
cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
|
||||
|
||||
@@ -44,9 +44,8 @@ import Simplex.Messaging.Protocol
|
||||
EntityId (..),
|
||||
RecipientId,
|
||||
SenderId,
|
||||
RawTransmission,
|
||||
SentRawTransmission,
|
||||
SignedTransmissionOrError,
|
||||
SignedTransmission,
|
||||
SndPublicAuthKey,
|
||||
Transmission,
|
||||
TransmissionForAuth (..),
|
||||
@@ -54,8 +53,7 @@ import Simplex.Messaging.Protocol
|
||||
encodeTransmission,
|
||||
encodeTransmissionForAuth,
|
||||
messageTagP,
|
||||
tDecodeServer,
|
||||
tDecodeClient,
|
||||
tDecodeParseValidate,
|
||||
tEncodeBatch1,
|
||||
tParse,
|
||||
)
|
||||
@@ -146,15 +144,10 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
|
||||
type ProtoCommand FileResponse = FileCmd
|
||||
type ProtoType FileResponse = 'PXFTP
|
||||
protocolClientHandshake = xftpClientHandshakeStub
|
||||
{-# INLINE protocolClientHandshake #-}
|
||||
useServiceAuth _ = False
|
||||
{-# INLINE useServiceAuth #-}
|
||||
protocolPing = FileCmd SFRecipient PING
|
||||
{-# INLINE protocolPing #-}
|
||||
protocolError = \case
|
||||
FRErr e -> Just e
|
||||
_ -> Nothing
|
||||
{-# INLINE protocolError #-}
|
||||
|
||||
data FileCommand (p :: FileParty) where
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
|
||||
@@ -199,7 +192,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
|
||||
fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials auth (EntityId fileId) cmd = case cmd of
|
||||
checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
|
||||
-- FNEW must not have signature and chunk ID
|
||||
FNEW {}
|
||||
| isNothing auth -> Left $ CMD NO_AUTH
|
||||
@@ -233,8 +226,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
|
||||
fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials tAuth entId (FileCmd p c) = FileCmd p <$> checkCredentials tAuth entId c
|
||||
{-# INLINE checkCredentials #-}
|
||||
checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
|
||||
|
||||
instance Encoding FileInfo where
|
||||
smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest)
|
||||
@@ -312,7 +304,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
|
||||
PEBlock -> BLOCK
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials _ (EntityId entId) cmd = case cmd of
|
||||
checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
|
||||
FRSndIds {} -> noEntity
|
||||
-- ERR response does not always have entity ID
|
||||
FRErr _ -> Right cmd
|
||||
@@ -337,35 +329,25 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
|
||||
Just Refl -> Just c
|
||||
_ -> Nothing
|
||||
|
||||
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
|
||||
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) (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)
|
||||
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeTransmission thParams (corrId, fId, msg) = do
|
||||
let t = encodeTransmission thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 (Nothing, t)
|
||||
|
||||
-- this function uses batch syntax but puts only one transmission in the batch
|
||||
xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
|
||||
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 False t) xftpBlockSize
|
||||
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
|
||||
|
||||
xftpDecodeTServer :: THandleParams XFTPVersion 'TServer -> ByteString -> Either XFTPErrorType (SignedTransmissionOrError XFTPErrorType FileCmd)
|
||||
xftpDecodeTServer = xftpDecodeTransmission tDecodeServer
|
||||
{-# INLINE xftpDecodeTServer #-}
|
||||
|
||||
xftpDecodeTClient :: THandleParams XFTPVersion 'TClient -> ByteString -> Either XFTPErrorType (Transmission (Either XFTPErrorType FileResponse))
|
||||
xftpDecodeTClient = xftpDecodeTransmission tDecodeClient
|
||||
{-# INLINE xftpDecodeTClient #-}
|
||||
|
||||
xftpDecodeTransmission ::
|
||||
(THandleParams XFTPVersion p -> Either TransportError RawTransmission -> r) ->
|
||||
THandleParams XFTPVersion p ->
|
||||
ByteString ->
|
||||
Either XFTPErrorType r
|
||||
xftpDecodeTransmission tDecode thParams t = do
|
||||
xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
|
||||
xftpDecodeTransmission thParams t = do
|
||||
t' <- first (const BLOCK) $ C.unPad t
|
||||
case tParse thParams t' of
|
||||
t'' :| [] -> Right $ tDecode thParams t''
|
||||
t'' :| [] -> Right $ tDecodeParseValidate thParams t''
|
||||
_ -> Left BLOCK
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty)
|
||||
|
||||
@@ -26,12 +26,12 @@ import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Data.Word (Word32)
|
||||
@@ -53,15 +53,15 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
|
||||
import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
|
||||
import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
|
||||
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
|
||||
import Simplex.Messaging.Server.Control (CPClientRole (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
|
||||
@@ -92,17 +92,17 @@ data XFTPTransportRequest = XFTPTransportRequest
|
||||
runXFTPServer :: XFTPServerConfig -> IO ()
|
||||
runXFTPServer cfg = do
|
||||
started <- newEmptyTMVarIO
|
||||
runXFTPServerBlocking started cfg
|
||||
runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes
|
||||
|
||||
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
|
||||
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
|
||||
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO ()
|
||||
runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_)
|
||||
|
||||
data Handshake
|
||||
= HandshakeSent C.PrivateKeyX25519
|
||||
| HandshakeAccepted (THandleParams XFTPVersion 'TServer)
|
||||
|
||||
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
|
||||
xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do
|
||||
mapM_ (expireServerFiles Nothing) fileExpiration
|
||||
restoreServerStats
|
||||
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
|
||||
@@ -110,17 +110,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
runServer :: M ()
|
||||
runServer = do
|
||||
srvCreds@(chain, pk) <- asks tlsServerCreds
|
||||
signKey <- liftIO $ case C.x509ToPrivate' pk of
|
||||
signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
|
||||
Right pk' -> pure pk'
|
||||
Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
|
||||
Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
|
||||
env <- ask
|
||||
sessions <- liftIO TM.emptyIO
|
||||
let cleanup sessionId = atomically $ TM.delete sessionId sessions
|
||||
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
|
||||
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
|
||||
reqBody <- getHTTP2Body r xftpBlockSize
|
||||
let v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
|
||||
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
|
||||
flip runReaderT env $ case sessionALPN of
|
||||
Nothing -> processRequest req0
|
||||
@@ -142,7 +142,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
unless (B.null bodyHead) $ throwE HANDSHAKE
|
||||
(k, pk) <- atomically . C.generateKeyPair =<< asks random
|
||||
atomically $ TM.insert sessionId (HandshakeSent pk) sessions
|
||||
let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
|
||||
let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
|
||||
let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
|
||||
shs <- encodeXftp hs
|
||||
#ifdef slow_servers
|
||||
@@ -158,7 +158,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
unless (keyHash == kh) $ throwE HANDSHAKE
|
||||
case compatibleVRange' xftpServerVRange v of
|
||||
Just (Compatible vr) -> do
|
||||
let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
|
||||
let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
|
||||
thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
|
||||
atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
|
||||
#ifdef slow_servers
|
||||
@@ -181,7 +181,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
stopServer = do
|
||||
withFileLog closeStoreLog
|
||||
saveServerStats
|
||||
logNote "Server stopped"
|
||||
logInfo "Server stopped"
|
||||
|
||||
expireFilesThread_ :: XFTPServerConfig -> [M ()]
|
||||
expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
|
||||
@@ -221,22 +221,22 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0
|
||||
filesCount' <- readIORef filesCount
|
||||
filesSize' <- readIORef filesSize
|
||||
T.hPutStrLn h $
|
||||
T.intercalate
|
||||
hPutStrLn h $
|
||||
intercalate
|
||||
","
|
||||
[ T.pack $ iso8601Show $ utctDay fromTime',
|
||||
tshow filesCreated',
|
||||
tshow fileRecipients',
|
||||
tshow filesUploaded',
|
||||
tshow filesDeleted',
|
||||
[ iso8601Show $ utctDay fromTime',
|
||||
show filesCreated',
|
||||
show fileRecipients',
|
||||
show filesUploaded',
|
||||
show filesDeleted',
|
||||
dayCount files,
|
||||
weekCount files,
|
||||
monthCount files,
|
||||
tshow fileDownloads',
|
||||
tshow fileDownloadAcks',
|
||||
tshow filesCount',
|
||||
tshow filesSize',
|
||||
tshow filesExpired'
|
||||
show fileDownloads',
|
||||
show fileDownloadAcks',
|
||||
show filesCount',
|
||||
show filesSize',
|
||||
show filesExpired'
|
||||
]
|
||||
liftIO $ threadDelay' interval
|
||||
|
||||
@@ -277,9 +277,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
CPSkip -> False
|
||||
_ -> True
|
||||
processCP h role = \case
|
||||
CPAuth auth -> controlPortAuth h user admin role auth
|
||||
CPAuth auth -> atomically $ writeTVar role $! newRole cfg
|
||||
where
|
||||
XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} = cfg
|
||||
newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
|
||||
| Just auth == admin = CPRAdmin
|
||||
| Just auth == user = CPRUser
|
||||
| otherwise = CPRNone
|
||||
CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
|
||||
CPDelete fileId -> withUserRole $ unliftIO u $ do
|
||||
fs <- asks store
|
||||
@@ -314,20 +317,22 @@ data ServerFile = ServerFile
|
||||
processRequest :: XFTPTransportRequest -> M ()
|
||||
processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
|
||||
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
|
||||
| otherwise =
|
||||
case xftpDecodeTServer thParams bodyHead of
|
||||
Right (Right t@(_, _, (corrId, fId, _))) -> do
|
||||
let THandleParams {thAuth} = thParams
|
||||
verifyXFTPTransmission thAuth t >>= \case
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest body req
|
||||
VRFailed e -> send (FRErr e) Nothing
|
||||
| otherwise = do
|
||||
case xftpDecodeTransmission thParams bodyHead of
|
||||
Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
|
||||
case cmdOrErr of
|
||||
Right cmd -> do
|
||||
let THandleParams {thAuth} = thParams
|
||||
verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest body req
|
||||
VRFailed e -> send (FRErr e) Nothing
|
||||
Left e -> send (FRErr e) Nothing
|
||||
where
|
||||
send resp = sendXFTPResponse (corrId, fId, resp)
|
||||
Right (Left (corrId, fId, e)) -> sendXFTPResponse (corrId, fId, FRErr e) Nothing
|
||||
Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
|
||||
where
|
||||
sendXFTPResponse t' serverFile_ = do
|
||||
let t_ = xftpEncodeTransmission thParams t'
|
||||
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
|
||||
let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
|
||||
#ifdef slow_servers
|
||||
randomDelay
|
||||
#endif
|
||||
@@ -356,8 +361,8 @@ randomDelay = do
|
||||
|
||||
data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
|
||||
|
||||
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M VerificationResult
|
||||
verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
|
||||
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
|
||||
verifyXFTPTransmission auth_ tAuth authorized fId cmd =
|
||||
case cmd of
|
||||
FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
|
||||
FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
|
||||
@@ -376,9 +381,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
|
||||
EntityBlocked info -> VRFailed $ BLOCKED info
|
||||
EntityOff -> noFileAuth
|
||||
Left _ -> pure noFileAuth
|
||||
noFileAuth = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH
|
||||
noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH
|
||||
-- TODO verify with DH authorization
|
||||
req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
|
||||
req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH
|
||||
|
||||
processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
@@ -410,7 +415,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts
|
||||
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
|
||||
lift $ withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts EntityActive
|
||||
logAddFile sl sId file ts
|
||||
logAddRecipients sl sId rcps
|
||||
stats <- asks serverStats
|
||||
lift $ incFileStat filesCreated
|
||||
@@ -421,7 +426,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
|
||||
addFileRetry st file n ts =
|
||||
retryAdd n $ \sId -> runExceptT $ do
|
||||
ExceptT $ addFile st sId file ts EntityActive
|
||||
ExceptT $ addFile st sId file ts
|
||||
pure sId
|
||||
addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient)
|
||||
addRecipientRetry st n sId rpk =
|
||||
@@ -555,13 +560,13 @@ expireServerFiles itemDelay expCfg = do
|
||||
usedStart <- readTVarIO $ usedStorage st
|
||||
old <- liftIO $ expireBeforeEpoch expCfg
|
||||
files' <- readTVarIO (files st)
|
||||
logNote $ "Expiration check: " <> tshow (M.size files') <> " files"
|
||||
logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
|
||||
forM_ (M.keys files') $ \sId -> do
|
||||
mapM_ threadDelay itemDelay
|
||||
atomically (expiredFilePath st sId old)
|
||||
>>= mapM_ (maybeRemove $ delete st sId)
|
||||
usedEnd <- readTVarIO $ usedStorage st
|
||||
logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
|
||||
logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
|
||||
where
|
||||
mbs bs = tshow (bs `div` 1048576) <> "mb"
|
||||
maybeRemove del = maybe del (remove del)
|
||||
@@ -595,15 +600,15 @@ saveServerStats =
|
||||
>>= mapM_ (\f -> asks serverStats >>= liftIO . getFileServerStatsData >>= liftIO . saveStats f)
|
||||
where
|
||||
saveStats f stats = do
|
||||
logNote $ "saving server stats to file " <> T.pack f
|
||||
logInfo $ "saving server stats to file " <> T.pack f
|
||||
B.writeFile f $ strEncode stats
|
||||
logNote "server stats saved"
|
||||
logInfo "server stats saved"
|
||||
|
||||
restoreServerStats :: M ()
|
||||
restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
|
||||
where
|
||||
restoreStats f = whenM (doesFileExist f) $ do
|
||||
logNote $ "restoring server stats from file " <> T.pack f
|
||||
logInfo $ "restoring server stats from file " <> T.pack f
|
||||
liftIO (strDecode <$> B.readFile f) >>= \case
|
||||
Right d@FileServerStatsData {_filesCount = statsFilesCount, _filesSize = statsFilesSize} -> do
|
||||
s <- asks serverStats
|
||||
@@ -612,10 +617,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
|
||||
_filesSize <- readTVarIO usedStorage
|
||||
liftIO $ setFileServerStats s d {_filesCount, _filesSize}
|
||||
renameFile f $ f <> ".bak"
|
||||
logNote "server stats restored"
|
||||
logInfo "server stats restored"
|
||||
when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount
|
||||
when (statsFilesSize /= _filesSize) $ logWarn $ "Files size differs: stats: " <> tshow statsFilesSize <> ", store: " <> tshow _filesSize
|
||||
logNote $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
|
||||
logInfo $ "Restored " <> tshow (_filesSize `div` 1048576) <> " MBs in " <> tshow _filesCount <> " files"
|
||||
Left e -> do
|
||||
logNote $ "error restoring server stats: " <> T.pack e
|
||||
logInfo $ "error restoring server stats: " <> T.pack e
|
||||
liftIO exitFailure
|
||||
|
||||
@@ -103,8 +103,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede
|
||||
used <- countUsedStorage <$> readTVarIO (files store)
|
||||
atomically $ writeTVar (usedStorage store) used
|
||||
forM_ fileSizeQuota $ \quota -> do
|
||||
logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
|
||||
when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!"
|
||||
logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
|
||||
when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
|
||||
tlsServerCreds <- loadServerCredential xftpCredentials
|
||||
Fingerprint fp <- loadFingerprint xftpCredentials
|
||||
serverStats <- newFileServerStats =<< getCurrentTime
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -21,7 +20,7 @@ import Simplex.FileTransfer.Chunks
|
||||
import Simplex.FileTransfer.Description (FileSize (..))
|
||||
import Simplex.FileTransfer.Server (runXFTPServer)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
|
||||
import Simplex.FileTransfer.Transport (supportedFileServerVRange, alpnSupportedXFTPhandshakes)
|
||||
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
|
||||
@@ -29,7 +28,7 @@ import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
@@ -189,10 +188,9 @@ xftpServerCLI cfgPath logPath = do
|
||||
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
|
||||
transportConfig =
|
||||
mkTransportServerConfig
|
||||
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
|
||||
(Just alpnSupportedXFTPhandshakes)
|
||||
False,
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
},
|
||||
responseDelay = 0
|
||||
}
|
||||
|
||||
@@ -222,19 +220,14 @@ cliCommandP cfgPath logPath iniFile =
|
||||
)
|
||||
where
|
||||
initP :: Parser InitOptions
|
||||
initP = do
|
||||
enableStoreLog <-
|
||||
flag' False
|
||||
( long "disable-store-log"
|
||||
<> help "Disable store log for persistence (enabled by default)"
|
||||
initP =
|
||||
InitOptions
|
||||
<$> switch
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
<|> flag True True
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence (DEPRECATED, enabled by default)"
|
||||
)
|
||||
signAlgorithm <-
|
||||
option
|
||||
<*> option
|
||||
(maybeReader readMaybe)
|
||||
( long "sign-algorithm"
|
||||
<> short 'a'
|
||||
@@ -243,8 +236,7 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> showDefault
|
||||
<> metavar "ALG"
|
||||
)
|
||||
ip <-
|
||||
strOption
|
||||
<*> strOption
|
||||
( long "ip"
|
||||
<> help
|
||||
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
|
||||
@@ -252,26 +244,22 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> showDefault
|
||||
<> metavar "IP"
|
||||
)
|
||||
fqdn <-
|
||||
(optional . strOption)
|
||||
<*> (optional . strOption)
|
||||
( long "fqdn"
|
||||
<> short 'n'
|
||||
<> help "Server FQDN used as Common Name for TLS online certificate"
|
||||
<> showDefault
|
||||
<> metavar "FQDN"
|
||||
)
|
||||
filesPath <-
|
||||
strOption
|
||||
<*> strOption
|
||||
( long "path"
|
||||
<> short 'p'
|
||||
<> help "Path to the directory to store files"
|
||||
<> metavar "PATH"
|
||||
)
|
||||
fileSizeQuota <-
|
||||
strOption
|
||||
<*> strOption
|
||||
( long "quota"
|
||||
<> short 'q'
|
||||
<> help "File storage quota (e.g. 100gb)"
|
||||
<> metavar "QUOTA"
|
||||
)
|
||||
pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota}
|
||||
|
||||
@@ -70,18 +70,18 @@ newFileStore = do
|
||||
usedStorage <- newTVarIO 0
|
||||
pure FileStore {files, recipients, usedStorage}
|
||||
|
||||
addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM (Either XFTPErrorType ())
|
||||
addFile FileStore {files} sId fileInfo createdAt status =
|
||||
addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
|
||||
addFile FileStore {files} sId fileInfo createdAt =
|
||||
ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
|
||||
f <- newFileRec sId fileInfo createdAt status
|
||||
f <- newFileRec sId fileInfo createdAt
|
||||
TM.insert sId f files
|
||||
pure $ Right ()
|
||||
|
||||
newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM FileRec
|
||||
newFileRec senderId fileInfo createdAt status = do
|
||||
newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
|
||||
newFileRec senderId fileInfo createdAt = do
|
||||
recipientIds <- newTVar S.empty
|
||||
filePath <- newTVar Nothing
|
||||
fileStatus <- newTVar status
|
||||
fileStatus <- newTVar EntityActive
|
||||
pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
|
||||
|
||||
setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
|
||||
|
||||
@@ -19,13 +19,12 @@ module Simplex.FileTransfer.Server.StoreLog
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Composition ((.:), (.::))
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -34,13 +33,13 @@ import Simplex.FileTransfer.Protocol (FileInfo (..))
|
||||
import Simplex.FileTransfer.Server.Store
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..))
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import System.IO
|
||||
|
||||
data FileStoreLogRecord
|
||||
= AddFile SenderId FileInfo RoundedSystemTime ServerEntityStatus
|
||||
= AddFile SenderId FileInfo RoundedSystemTime
|
||||
| PutFile SenderId FilePath
|
||||
| AddRecipients SenderId (NonEmpty FileRecipient)
|
||||
| DeleteFile SenderId
|
||||
@@ -50,7 +49,7 @@ data FileStoreLogRecord
|
||||
|
||||
instance StrEncoding FileStoreLogRecord where
|
||||
strEncode = \case
|
||||
AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status)
|
||||
AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt)
|
||||
PutFile sId path -> strEncode (Str "FPUT", sId, path)
|
||||
AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
|
||||
DeleteFile sId -> strEncode (Str "FDEL", sId)
|
||||
@@ -58,7 +57,7 @@ instance StrEncoding FileStoreLogRecord where
|
||||
AckFile rId -> strEncode (Str "FACK", rId)
|
||||
strP =
|
||||
A.choice
|
||||
[ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)),
|
||||
[ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP),
|
||||
"FPUT " *> (PutFile <$> strP_ <*> strP),
|
||||
"FADD " *> (AddRecipients <$> strP_ <*> strP),
|
||||
"FDEL " *> (DeleteFile <$> strP),
|
||||
@@ -69,8 +68,8 @@ instance StrEncoding FileStoreLogRecord where
|
||||
logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
|
||||
logFileStoreRecord = writeStoreLogRecord
|
||||
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> IO ()
|
||||
logAddFile s = logFileStoreRecord s .:: AddFile
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
|
||||
logAddFile s = logFileStoreRecord s .:. AddFile
|
||||
|
||||
logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
|
||||
logPutFile s = logFileStoreRecord s .: PutFile
|
||||
@@ -100,7 +99,7 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
|
||||
Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
|
||||
_ -> pure ()
|
||||
addToStore = \case
|
||||
AddFile sId file createdAt status -> addFile st sId file createdAt status
|
||||
AddFile sId file createdAt -> addFile st sId file createdAt
|
||||
PutFile qId path -> setFilePath st qId path
|
||||
AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
|
||||
DeleteFile sId -> deleteFile st sId
|
||||
@@ -114,9 +113,8 @@ writeFileStore s FileStore {files, recipients} = do
|
||||
readTVarIO files >>= mapM_ (logFile allRcps)
|
||||
where
|
||||
logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
|
||||
logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do
|
||||
status <- readTVarIO fileStatus
|
||||
logAddFile s senderId fileInfo createdAt status
|
||||
logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do
|
||||
logAddFile s senderId fileInfo createdAt
|
||||
(rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
|
||||
mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
|
||||
mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs
|
||||
|
||||
@@ -13,7 +13,7 @@ module Simplex.FileTransfer.Transport
|
||||
authCmdsXFTPVersion,
|
||||
blockedFilesXFTPVersion,
|
||||
xftpClientHandshakeStub,
|
||||
alpnSupportedXFTPhandshakes,
|
||||
supportedXFTPhandshakes,
|
||||
XFTPClientHandshake (..),
|
||||
-- xftpClientHandshake,
|
||||
XFTPServerHandshake (..),
|
||||
@@ -42,7 +42,7 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bifunctor (bimap, first)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -50,6 +50,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Functor (($>))
|
||||
import Data.Word (Word16, Word32)
|
||||
import qualified Data.X509 as X
|
||||
import Network.HTTP2.Client (HTTP2Error)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
@@ -57,7 +58,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
import Simplex.Messaging.Util (bshow, tshow)
|
||||
import Simplex.Messaging.Version
|
||||
@@ -101,17 +102,17 @@ supportedFileServerVRange :: VersionRangeXFTP
|
||||
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
|
||||
|
||||
-- XFTP protocol does not use this handshake method
|
||||
xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
|
||||
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion
|
||||
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
|
||||
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
|
||||
|
||||
alpnSupportedXFTPhandshakes :: [ALPN]
|
||||
alpnSupportedXFTPhandshakes = ["xftp/1"]
|
||||
supportedXFTPhandshakes :: [ALPN]
|
||||
supportedXFTPhandshakes = ["xftp/1"]
|
||||
|
||||
data XFTPServerHandshake = XFTPServerHandshake
|
||||
{ xftpVersionRange :: VersionRangeXFTP,
|
||||
sessionId :: SessionId,
|
||||
-- | pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
authPubKey :: CertChainPubKey
|
||||
authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey)
|
||||
}
|
||||
|
||||
data XFTPClientHandshake = XFTPClientHandshake
|
||||
@@ -131,12 +132,15 @@ instance Encoding XFTPClientHandshake where
|
||||
|
||||
instance Encoding XFTPServerHandshake where
|
||||
smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
|
||||
smpEncode (xftpVersionRange, sessionId, authPubKey)
|
||||
smpEncode (xftpVersionRange, sessionId, auth)
|
||||
where
|
||||
auth = bimap C.encodeCertChain C.SignedObject authPubKey
|
||||
smpP = do
|
||||
(xftpVersionRange, sessionId) <- smpP
|
||||
authPubKey <- smpP
|
||||
cert <- C.certChainP
|
||||
C.SignedObject key <- smpP
|
||||
Tail _compat <- smpP
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey}
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)}
|
||||
|
||||
sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
|
||||
sendEncFile h send = go
|
||||
|
||||
@@ -22,7 +22,7 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import System.FilePath ((</>))
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
|
||||
type RcvFileId = ByteString -- Agent entity ID
|
||||
|
||||
|
||||
+367
-724
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -96,8 +96,7 @@ data InitialAgentServers = InitialAgentServers
|
||||
{ smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
|
||||
ntf :: [NtfServer],
|
||||
xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
|
||||
netCfg :: NetworkConfig,
|
||||
presetDomains :: [HostName]
|
||||
netCfg :: NetworkConfig
|
||||
}
|
||||
|
||||
data ServerCfg p = ServerCfg
|
||||
|
||||
@@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Lock
|
||||
withLock',
|
||||
withGetLock,
|
||||
withGetLocks,
|
||||
getPutLock,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -16,12 +15,11 @@ import Control.Monad.IO.Unlift
|
||||
import Data.Functor (($>))
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import UnliftIO.Async (forConcurrently)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
type Lock = TMVar Text
|
||||
type Lock = TMVar String
|
||||
|
||||
createLock :: STM Lock
|
||||
createLock = newEmptyTMVar
|
||||
@@ -31,24 +29,24 @@ createLockIO :: IO Lock
|
||||
createLockIO = newEmptyTMVarIO
|
||||
{-# INLINE createLockIO #-}
|
||||
|
||||
withLock :: MonadUnliftIO m => Lock -> Text -> ExceptT e m a -> ExceptT e m a
|
||||
withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
|
||||
withLock lock name = ExceptT . withLock' lock name . runExceptT
|
||||
{-# INLINE withLock #-}
|
||||
|
||||
withLock' :: MonadUnliftIO m => Lock -> Text -> m a -> m a
|
||||
withLock' :: MonadUnliftIO m => Lock -> String -> m a -> m a
|
||||
withLock' lock name =
|
||||
E.bracket_
|
||||
(atomically $ putTMVar lock name)
|
||||
(void . atomically $ takeTMVar lock)
|
||||
|
||||
withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> Text -> m a -> m a
|
||||
withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> String -> m a -> m a
|
||||
withGetLock getLock key name a =
|
||||
E.bracket
|
||||
(atomically $ getPutLock getLock key name)
|
||||
(atomically . takeTMVar)
|
||||
(const a)
|
||||
|
||||
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> Text -> m a -> m a
|
||||
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a
|
||||
withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
|
||||
where
|
||||
holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
|
||||
@@ -56,5 +54,5 @@ withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
|
||||
|
||||
-- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
|
||||
-- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.
|
||||
getPutLock :: (k -> STM Lock) -> k -> Text -> STM Lock
|
||||
getPutLock :: (k -> STM Lock) -> k -> String -> STM Lock
|
||||
getPutLock getLock key name = getLock key >>= \l -> putTMVar l name $> l
|
||||
|
||||
@@ -14,7 +14,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
|
||||
nsUpdateToken,
|
||||
nsRemoveNtfToken,
|
||||
sendNtfSubCommand,
|
||||
hasInstantNotifications,
|
||||
instantNotifications,
|
||||
deleteToken,
|
||||
closeNtfSupervisor,
|
||||
@@ -46,13 +45,12 @@ import Simplex.Messaging.Agent.Stats
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.AgentStore
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, whenM)
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
|
||||
import System.Random (randomR)
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
@@ -527,19 +525,15 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
|
||||
nsRemoveNtfToken :: NtfSupervisor -> STM ()
|
||||
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
|
||||
|
||||
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
|
||||
sendNtfSubCommand ns cmd =
|
||||
whenM (hasInstantNotifications ns) $ atomically $ writeTBQueue (ntfSubQ ns) cmd
|
||||
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
|
||||
sendNtfSubCommand ns cmd = do
|
||||
tkn <- readTVar (ntfTkn ns)
|
||||
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
|
||||
|
||||
hasInstantNotifications :: NtfSupervisor -> IO Bool
|
||||
hasInstantNotifications ns = do
|
||||
tkn <- readTVarIO $ ntfTkn ns
|
||||
pure $ maybe False instantNotifications tkn
|
||||
|
||||
instantNotifications :: NtfToken -> Bool
|
||||
instantNotifications NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} = True
|
||||
instantNotifications _ = False
|
||||
{-# INLINE instantNotifications #-}
|
||||
instantNotifications :: Maybe NtfToken -> Bool
|
||||
instantNotifications = \case
|
||||
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
|
||||
_ -> False
|
||||
|
||||
deleteToken :: AgentClient -> NtfToken -> AM ()
|
||||
deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
|
||||
@@ -578,7 +572,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
|
||||
notifyInternalError' c (show e)
|
||||
processTknToDelete :: NtfTokenToDelete -> AM ()
|
||||
processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
|
||||
agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
|
||||
agentNtfDeleteToken c srv ntfPrivKey tknId
|
||||
withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
|
||||
|
||||
closeNtfSupervisor :: NtfSupervisor -> IO ()
|
||||
|
||||
@@ -1,10 +1,8 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -21,7 +19,6 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
-- |
|
||||
-- Module : Simplex.Messaging.Agent.Protocol
|
||||
@@ -103,35 +100,17 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnectionMode (..),
|
||||
SConnectionMode (..),
|
||||
AConnectionMode (..),
|
||||
cmInvitation,
|
||||
cmContact,
|
||||
ConnectionModeI (..),
|
||||
ConnectionRequestUri (..),
|
||||
AConnectionRequestUri (..),
|
||||
ConnReqUriData (..),
|
||||
CRClientData,
|
||||
ServiceScheme,
|
||||
FixedLinkData (..),
|
||||
ConnLinkData (..),
|
||||
UserLinkData (..),
|
||||
OwnerAuth (..),
|
||||
OwnerId,
|
||||
ConnectionLink (..),
|
||||
AConnectionLink (..),
|
||||
ConnShortLink (..),
|
||||
AConnShortLink (..),
|
||||
CreatedConnLink (..),
|
||||
ACreatedConnLink (..),
|
||||
ContactConnType (..),
|
||||
ShortLinkScheme (..),
|
||||
LinkKey (..),
|
||||
StoredClientService (..),
|
||||
ClientService,
|
||||
ClientServiceId,
|
||||
sameConnReqContact,
|
||||
sameShortLinkContact,
|
||||
simplexChat,
|
||||
connReqUriP',
|
||||
simplexConnReqUri,
|
||||
simplexShortLink,
|
||||
AgentErrorType (..),
|
||||
CommandErrorType (..),
|
||||
ConnectionErrorType (..),
|
||||
@@ -151,7 +130,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
AgentMsgId,
|
||||
NotificationsMode (..),
|
||||
NotificationInfo (..),
|
||||
ConnMsgReq (..),
|
||||
|
||||
-- * Encode/decode
|
||||
serializeCommand,
|
||||
@@ -162,29 +140,18 @@ module Simplex.Messaging.Agent.Protocol
|
||||
serializeQueueStatus,
|
||||
queueStatusT,
|
||||
agentMessageType,
|
||||
aMessageType,
|
||||
extraSMPServerHosts,
|
||||
updateSMPServerHosts,
|
||||
shortenShortLink,
|
||||
restoreShortLink,
|
||||
linkUserData,
|
||||
linkUserData',
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?))
|
||||
import qualified Data.Aeson as J'
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (toLower, toUpper)
|
||||
import Data.Foldable (find)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
@@ -194,20 +161,18 @@ import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Typeable ()
|
||||
import Data.Word (Word16, Word32)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType)
|
||||
import Simplex.FileTransfer.Types (FileErrorType)
|
||||
import Simplex.Messaging.Agent.QueryString
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
import Simplex.Messaging.Client (ProxyClientError)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet
|
||||
@@ -232,7 +197,6 @@ import Simplex.Messaging.Protocol
|
||||
MsgId,
|
||||
NMsgMeta,
|
||||
ProtocolServer (..),
|
||||
QueueMode (..),
|
||||
SMPClientVersion,
|
||||
SMPServer,
|
||||
SMPServerWithAuth,
|
||||
@@ -248,8 +212,6 @@ import Simplex.Messaging.Protocol
|
||||
sameSrvAddr,
|
||||
sndAuthKeySMPClientVersion,
|
||||
srvHostnamesSMPClientVersion,
|
||||
shortLinksSMPClientVersion,
|
||||
senderCanSecure,
|
||||
pattern ProtoServerWithAuth,
|
||||
pattern SMPServer,
|
||||
)
|
||||
@@ -269,7 +231,6 @@ import UnliftIO.Exception (Exception)
|
||||
-- 4 - delivery receipts (7/13/2023)
|
||||
-- 5 - post-quantum double ratchet (3/14/2024)
|
||||
-- 6 - secure reply queues with provided keys (6/14/2024)
|
||||
-- 7 - initialize ratchet on processing confirmation (7/18/2024)
|
||||
|
||||
data SMPAgentVersion
|
||||
|
||||
@@ -376,7 +337,7 @@ type SndQueueSecured = Bool
|
||||
|
||||
-- | Parameterized type for SMP agent events
|
||||
data AEvent (e :: AEntity) where
|
||||
INV :: AConnectionRequestUri -> Maybe ClientServiceId -> AEvent AEConn
|
||||
INV :: AConnectionRequestUri -> AEvent AEConn
|
||||
CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
|
||||
REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender
|
||||
INFO :: PQSupport -> ConnInfo -> AEvent AEConn
|
||||
@@ -402,7 +363,7 @@ data AEvent (e :: AEntity) where
|
||||
DEL_USER :: Int64 -> AEvent AENone
|
||||
STAT :: ConnectionStats -> AEvent AEConn
|
||||
OK :: AEvent AEConn
|
||||
JOINED :: SndQueueSecured -> Maybe ClientServiceId -> AEvent AEConn
|
||||
JOINED :: SndQueueSecured -> AEvent AEConn
|
||||
ERR :: AgentErrorType -> AEvent AEConn
|
||||
ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
|
||||
SUSPENDED :: AEvent AENone
|
||||
@@ -502,7 +463,7 @@ aCommandTag = \case
|
||||
|
||||
aEventTag :: AEvent e -> AEventTag e
|
||||
aEventTag = \case
|
||||
INV {} -> INV_
|
||||
INV _ -> INV_
|
||||
CONF {} -> CONF_
|
||||
REQ {} -> REQ_
|
||||
INFO {} -> INFO_
|
||||
@@ -528,7 +489,7 @@ aEventTag = \case
|
||||
DEL_USER _ -> DEL_USER_
|
||||
STAT _ -> STAT_
|
||||
OK -> OK_
|
||||
JOINED {} -> JOINED_
|
||||
JOINED _ -> JOINED_
|
||||
ERR _ -> ERR_
|
||||
ERRS _ -> ERRS_
|
||||
SUSPENDED -> SUSPENDED_
|
||||
@@ -688,21 +649,11 @@ instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseA
|
||||
|
||||
data NotificationInfo = NotificationInfo
|
||||
{ ntfConnId :: ConnId,
|
||||
ntfDbQueueId :: Int64,
|
||||
ntfTs :: SystemTime,
|
||||
-- Nothing means that the message failed to decrypt or to decode,
|
||||
-- we can still show event notification
|
||||
ntfMsgMeta :: Maybe NMsgMeta
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ConnMsgReq = ConnMsgReq
|
||||
{ msgConnId :: ConnId,
|
||||
msgDbQueueId :: Int64,
|
||||
msgTs :: Maybe UTCTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ConnectionMode = CMInvitation | CMContact
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -724,17 +675,21 @@ data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m)
|
||||
instance Eq AConnectionMode where
|
||||
ACM m == ACM m' = isJust $ testEquality m m'
|
||||
|
||||
cmInvitation :: AConnectionMode
|
||||
cmInvitation = ACM SCMInvitation
|
||||
|
||||
cmContact :: AConnectionMode
|
||||
cmContact = ACM SCMContact
|
||||
|
||||
deriving instance Show AConnectionMode
|
||||
|
||||
connMode :: SConnectionMode m -> ConnectionMode
|
||||
connMode SCMInvitation = CMInvitation
|
||||
connMode SCMContact = CMContact
|
||||
{-# INLINE connMode #-}
|
||||
|
||||
connMode' :: ConnectionMode -> AConnectionMode
|
||||
connMode' CMInvitation = ACM SCMInvitation
|
||||
connMode' CMContact = ACM SCMContact
|
||||
{-# INLINE connMode' #-}
|
||||
connMode' CMInvitation = cmInvitation
|
||||
connMode' CMContact = cmContact
|
||||
|
||||
class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m
|
||||
|
||||
@@ -900,7 +855,20 @@ agentMessageType = \case
|
||||
AgentConnInfo _ -> AM_CONN_INFO
|
||||
AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
|
||||
AgentRatchetInfo _ -> AM_RATCHET_INFO
|
||||
AgentMessage _ aMsg -> aMessageType aMsg
|
||||
AgentMessage _ aMsg -> case aMsg of
|
||||
-- HELLO is used both in v1 and in v2, but differently.
|
||||
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
|
||||
-- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
|
||||
-- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
|
||||
HELLO -> AM_HELLO_
|
||||
A_MSG _ -> AM_A_MSG_
|
||||
A_RCVD {} -> AM_A_RCVD_
|
||||
A_QCONT _ -> AM_QCONT_
|
||||
QADD _ -> AM_QADD_
|
||||
QKEY _ -> AM_QKEY_
|
||||
QUSE _ -> AM_QUSE_
|
||||
QTEST _ -> AM_QTEST_
|
||||
EREADY _ -> AM_EREADY_
|
||||
|
||||
data APrivHeader = APrivHeader
|
||||
{ -- | sequential ID assigned by the sending agent
|
||||
@@ -978,22 +946,6 @@ data AMessage
|
||||
EREADY AgentMsgId
|
||||
deriving (Show)
|
||||
|
||||
aMessageType :: AMessage -> AgentMessageType
|
||||
aMessageType = \case
|
||||
-- HELLO is used both in v1 and in v2, but differently.
|
||||
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
|
||||
-- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
|
||||
-- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
|
||||
HELLO -> AM_HELLO_
|
||||
A_MSG _ -> AM_A_MSG_
|
||||
A_RCVD {} -> AM_A_RCVD_
|
||||
A_QCONT _ -> AM_QCONT_
|
||||
QADD _ -> AM_QADD_
|
||||
QKEY _ -> AM_QKEY_
|
||||
QUSE _ -> AM_QUSE_
|
||||
QTEST _ -> AM_QTEST_
|
||||
EREADY _ -> AM_EREADY_
|
||||
|
||||
-- | this type is used to send as part of the protocol between different clients
|
||||
-- TODO possibly, rename fields and types referring to external and internal IDs to make them different
|
||||
data AMessageReceipt = AMessageReceipt
|
||||
@@ -1058,10 +1010,6 @@ instance Encoding AMessage where
|
||||
QTEST_ -> QTEST <$> smpP
|
||||
EREADY_ -> EREADY <$> smpP
|
||||
|
||||
instance ToField AMessage where toField = toField . Binary . smpEncode
|
||||
|
||||
instance FromField AMessage where fromField = blobFieldDecoder smpDecode
|
||||
|
||||
instance Encoding AMessageReceipt where
|
||||
smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} =
|
||||
smpEncode (agentMsgId, msgHash, Large rcptInfo)
|
||||
@@ -1086,36 +1034,6 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
|
||||
<> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
|
||||
strP = connReqUriP' (Just SSSimplex)
|
||||
|
||||
instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where
|
||||
smpEncode = \case
|
||||
CRInvitationUri crData e2eParams -> smpEncode (CMInvitation, crData, e2eParams)
|
||||
CRContactUri crData -> smpEncode (CMContact, crData)
|
||||
smpP = (\(ACR _ cr) -> checkConnMode cr) <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance Encoding AConnectionRequestUri where
|
||||
smpEncode (ACR _ cr) = smpEncode cr
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
CMInvitation -> ACR SCMInvitation <$> (CRInvitationUri <$> smpP <*> smpP)
|
||||
CMContact -> ACR SCMContact . CRContactUri <$> smpP
|
||||
|
||||
instance Encoding ConnReqUriData where
|
||||
smpEncode ConnReqUriData {crAgentVRange, crSmpQueues, crClientData} =
|
||||
smpEncode (crAgentVRange, crSmpQueues, Large . encodeUtf8 <$> crClientData)
|
||||
smpP = do
|
||||
(crAgentVRange, smpQueues, clientData) <- smpP
|
||||
-- This patch to compensate for the fact that queueMode QMContact won't be included in queue encoding,
|
||||
-- until min SMP client version is >= 3 (sndAuthKeySMPClientVersion).
|
||||
-- This is possible because SMP encoding of ConnReqUriData was not used prior to SMP client version 4.
|
||||
let crSmpQueues = L.map patchQueueMode smpQueues
|
||||
pure ConnReqUriData {crScheme = SSSimplex, crAgentVRange, crSmpQueues, crClientData = safeDecodeUtf8 . unLarge <$> clientData}
|
||||
where
|
||||
patchQueueMode q@SMPQueueUri {queueAddress = a} = case a of
|
||||
SMPQueueAddress {queueMode = Nothing} -> q {queueAddress = a {queueMode = Just QMContact}} :: SMPQueueUri
|
||||
_ -> q
|
||||
|
||||
connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m)
|
||||
connReqUriP' overrideScheme = do
|
||||
ACR m cr <- connReqUriP overrideScheme
|
||||
@@ -1153,39 +1071,15 @@ connReqUriP overrideScheme = do
|
||||
|
||||
instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
|
||||
parseJSON = strParseJSON "ConnectionRequestUri"
|
||||
{-# INLINE parseJSON #-}
|
||||
|
||||
instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where
|
||||
toJSON = strToJSON
|
||||
{-# INLINE toJSON #-}
|
||||
toEncoding = strToJEncoding
|
||||
{-# INLINE toEncoding #-}
|
||||
|
||||
instance FromJSON AConnectionRequestUri where
|
||||
parseJSON = strParseJSON "ConnectionRequestUri"
|
||||
{-# INLINE parseJSON #-}
|
||||
|
||||
instance ToJSON AConnectionRequestUri where
|
||||
toJSON = strToJSON
|
||||
{-# INLINE toJSON #-}
|
||||
toEncoding = strToJEncoding
|
||||
{-# INLINE toEncoding #-}
|
||||
|
||||
instance ConnectionModeI m => FromJSON (ConnShortLink m) where
|
||||
parseJSON = strParseJSON "ConnShortLink"
|
||||
{-# INLINE parseJSON #-}
|
||||
|
||||
instance ConnectionModeI m => ToJSON (ConnShortLink m) where
|
||||
toJSON = strToJSON
|
||||
{-# INLINE toJSON #-}
|
||||
toEncoding = strToJEncoding
|
||||
{-# INLINE toEncoding #-}
|
||||
|
||||
instance FromJSON AConnShortLink where
|
||||
parseJSON = strParseJSON "AConnShortLink"
|
||||
{-# INLINE parseJSON #-}
|
||||
|
||||
instance ToJSON AConnShortLink where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
@@ -1203,26 +1097,6 @@ instance StrEncoding AConnectionMode where
|
||||
strEncode (ACM cMode) = strEncode $ connMode cMode
|
||||
strP = connMode' <$> strP
|
||||
|
||||
instance Encoding ConnectionMode where
|
||||
smpEncode = \case
|
||||
CMInvitation -> "I"
|
||||
CMContact -> "C"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'I' -> pure CMInvitation
|
||||
'C' -> pure CMContact
|
||||
_ -> fail "bad connection mode"
|
||||
|
||||
instance ToJSON ConnectionMode where
|
||||
toJSON = J'.String . T.toLower . decodeLatin1 . strEncode
|
||||
{-# INLINE toJSON #-}
|
||||
toEncoding = JE.text . T.toLower . decodeLatin1 . strEncode
|
||||
{-# INLINE toEncoding #-}
|
||||
|
||||
instance FromJSON ConnectionMode where
|
||||
parseJSON = J'.withText "ConnectionMode" $ either fail pure . parseAll strP . encodeUtf8 . T.toUpper
|
||||
{-# INLINE parseJSON #-}
|
||||
|
||||
connModeT :: Text -> Maybe ConnectionMode
|
||||
connModeT = \case
|
||||
"INV" -> Just CMInvitation
|
||||
@@ -1270,20 +1144,16 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress ::
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding SMPQueueInfo where
|
||||
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode})
|
||||
| clientVersion >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode
|
||||
| clientVersion >= sndAuthKeySMPClientVersion && sndSecure = addrEnc <> smpEncode sndSecure
|
||||
| clientVersion > initialSMPClientVersion = addrEnc
|
||||
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure})
|
||||
| clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure)
|
||||
| clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
|
||||
| otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
|
||||
where
|
||||
addrEnc = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
|
||||
sndSecure = senderCanSecure queueMode
|
||||
smpP = do
|
||||
clientVersion <- smpP
|
||||
smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP
|
||||
(senderId, dhPublicKey) <- smpP
|
||||
queueMode <- queueModeP
|
||||
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
|
||||
sndSecure <- fromMaybe False <$> optional smpP
|
||||
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
|
||||
|
||||
-- This instance seems contrived and there was a temptation to split a common part of both types.
|
||||
-- But this is created to allow backward and forward compatibility where SMPQueueUri
|
||||
@@ -1310,7 +1180,7 @@ data SMPQueueAddress = SMPQueueAddress
|
||||
{ smpServer :: SMPServer,
|
||||
senderId :: SMP.SenderId,
|
||||
dhPublicKey :: C.PublicKeyX25519,
|
||||
queueMode :: Maybe QueueMode
|
||||
sndSecure :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -1337,60 +1207,42 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'
|
||||
{-# INLINE sameQAddress #-}
|
||||
|
||||
instance StrEncoding SMPQueueUri where
|
||||
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, queueMode})
|
||||
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, sndSecure})
|
||||
| minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
|
||||
| otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
|
||||
where
|
||||
query = strEncode . QSP QEscape
|
||||
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> queueModeParam <> sndSecureParam
|
||||
where
|
||||
queueModeParam = case queueMode of
|
||||
Just QMMessaging -> [("q", "m")]
|
||||
Just QMContact -> [("q", "c")]
|
||||
Nothing -> []
|
||||
sndSecureParam = [("k", "s") | senderCanSecure queueMode && minVersion vr < shortLinksSMPClientVersion]
|
||||
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> [("k", "s") | sndSecure]
|
||||
srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)]
|
||||
hs = L.tail $ host srv
|
||||
strP = do
|
||||
srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
|
||||
senderId <- strP <* optional (A.char '/') <* A.char '#'
|
||||
(vr, hs, dhPublicKey, queueMode) <- versioned <|> unversioned
|
||||
(vr, hs, dhPublicKey, sndSecure) <- versioned <|> unversioned
|
||||
let srv' = srv {host = h :| host <> hs}
|
||||
smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv'
|
||||
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
|
||||
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
|
||||
where
|
||||
unversioned = (versionToRange initialSMPClientVersion,[],,Nothing) <$> strP <* A.endOfInput
|
||||
unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput
|
||||
versioned = do
|
||||
dhKey_ <- optional strP
|
||||
query <- optional (A.char '/') *> A.char '?' *> strP
|
||||
vr <- queryParam "v" query
|
||||
dhKey <- maybe (queryParam "dh" query) pure dhKey_
|
||||
hs_ <- queryParam_ "srv" query
|
||||
let queueMode = case queryParamStr "q" query of
|
||||
Just "m" -> Just QMMessaging
|
||||
Just "c" -> Just QMContact
|
||||
_ | queryParamStr "k" query == Just "s" -> Just QMMessaging
|
||||
_ -> Nothing
|
||||
pure (vr, maybe [] thList_ hs_, dhKey, queueMode)
|
||||
let sndSecure = queryParamStr "k" query == Just "s"
|
||||
pure (vr, maybe [] thList_ hs_, dhKey, sndSecure)
|
||||
|
||||
instance Encoding SMPQueueUri where
|
||||
smpEncode (SMPQueueUri clientVRange@(VersionRange minV maxV) SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode})
|
||||
-- The condition is for minVersion as earlier clients won't be able to support it.
|
||||
-- The alternative would be to encode both queueMode and sndSecure
|
||||
| minV >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode
|
||||
-- Earlier versions won't be able to ignore sndSecure, so we don't include it when it is False
|
||||
| minV >= sndAuthKeySMPClientVersion || (maxV >= sndAuthKeySMPClientVersion && sndSecure) = addrEnc <> smpEncode sndSecure
|
||||
| otherwise = addrEnc
|
||||
where
|
||||
addrEnc = smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
|
||||
sndSecure = senderCanSecure queueMode
|
||||
smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure})
|
||||
| maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure =
|
||||
smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure)
|
||||
| otherwise =
|
||||
smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
|
||||
smpP = do
|
||||
(clientVRange, smpServer, senderId, dhPublicKey) <- smpP
|
||||
queueMode <- queueModeP
|
||||
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
|
||||
|
||||
queueModeP :: Parser (Maybe QueueMode)
|
||||
queueModeP = Just <$> smpP <|> optional ((\case True -> QMMessaging; _ -> QMContact) <$> smpP)
|
||||
sndSecure <- fromMaybe False <$> optional smpP
|
||||
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
|
||||
|
||||
data ConnectionRequestUri (m :: ConnectionMode) where
|
||||
CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
|
||||
@@ -1398,11 +1250,6 @@ data ConnectionRequestUri (m :: ConnectionMode) where
|
||||
-- they are passed in AgentInvitation message
|
||||
CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact
|
||||
|
||||
simplexConnReqUri :: ConnectionRequestUri m -> ConnectionRequestUri m
|
||||
simplexConnReqUri = \case
|
||||
CRInvitationUri crData e2eParams -> CRInvitationUri crData {crScheme = SSSimplex} e2eParams
|
||||
CRContactUri crData -> CRContactUri crData {crScheme = SSSimplex}
|
||||
|
||||
deriving instance Eq (ConnectionRequestUri m)
|
||||
|
||||
deriving instance Show (ConnectionRequestUri m)
|
||||
@@ -1416,245 +1263,12 @@ instance Eq AConnectionRequestUri where
|
||||
|
||||
deriving instance Show AConnectionRequestUri
|
||||
|
||||
data ShortLinkScheme = SLSSimplex | SLSServer deriving (Eq, Show)
|
||||
|
||||
data ConnShortLink (m :: ConnectionMode) where
|
||||
CSLInvitation :: ShortLinkScheme -> SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation
|
||||
CSLContact :: ShortLinkScheme -> ContactConnType -> SMPServer -> LinkKey -> ConnShortLink 'CMContact
|
||||
|
||||
deriving instance Eq (ConnShortLink m)
|
||||
|
||||
deriving instance Show (ConnShortLink m)
|
||||
|
||||
simplexShortLink :: ConnShortLink m -> ConnShortLink m
|
||||
simplexShortLink = \case
|
||||
CSLInvitation _ srv lnkId k -> CSLInvitation SLSSimplex srv lnkId k
|
||||
CSLContact _ ct srv k -> CSLContact SLSSimplex ct srv k
|
||||
|
||||
newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (FromField, StrEncoding)
|
||||
|
||||
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
|
||||
|
||||
instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode
|
||||
|
||||
instance (Typeable c, ConnectionModeI c) => FromField (ConnectionLink c) where fromField = blobFieldDecoder strDecode
|
||||
|
||||
instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField . Binary . strEncode
|
||||
|
||||
instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
|
||||
|
||||
data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
|
||||
|
||||
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
|
||||
|
||||
instance Eq AConnShortLink where
|
||||
ACSL m sl == ACSL m' sl' = case testEquality m m' of
|
||||
Just Refl -> sl == sl'
|
||||
Nothing -> False
|
||||
|
||||
deriving instance Show AConnShortLink
|
||||
|
||||
instance ToField AConnShortLink where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode
|
||||
|
||||
data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connShortLink :: Maybe (ConnShortLink m)}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ACreatedConnLink = forall m. ConnectionModeI m => ACCL (SConnectionMode m) (CreatedConnLink m)
|
||||
|
||||
instance Eq ACreatedConnLink where
|
||||
ACCL m l == ACCL m' l' = case testEquality m m' of
|
||||
Just Refl -> l == l'
|
||||
_ -> False
|
||||
|
||||
deriving instance Show ACreatedConnLink
|
||||
|
||||
data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m)
|
||||
|
||||
instance Eq AConnectionLink where
|
||||
ACL m cl == ACL m' cl' = case testEquality m m' of
|
||||
Just Refl -> cl == cl'
|
||||
_ -> False
|
||||
|
||||
deriving instance Show AConnectionLink
|
||||
|
||||
instance ConnectionModeI m => StrEncoding (ConnectionLink m) where
|
||||
strEncode = \case
|
||||
CLFull cr -> strEncode cr
|
||||
CLShort sl -> strEncode sl
|
||||
strP = (\(ACL _ cl) -> checkConnMode cl) <$?> strP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding AConnectionLink where
|
||||
strEncode (ACL _ cl) = strEncode cl
|
||||
{-# INLINE strEncode #-}
|
||||
strP =
|
||||
(\(ACR m cr) -> ACL m (CLFull cr)) <$> strP
|
||||
<|> (\(ACSL m sl) -> ACL m (CLShort sl)) <$> strP
|
||||
|
||||
instance ConnectionModeI m => ToJSON (ConnectionLink m) where
|
||||
toEncoding = strToJEncoding
|
||||
toJSON = strToJSON
|
||||
|
||||
instance ConnectionModeI m => FromJSON (ConnectionLink m) where
|
||||
parseJSON = strParseJSON "ConnectionLink"
|
||||
|
||||
instance ToJSON AConnectionLink where
|
||||
toEncoding = strToJEncoding
|
||||
toJSON = strToJSON
|
||||
|
||||
instance FromJSON AConnectionLink where
|
||||
parseJSON = strParseJSON "AConnectionLink"
|
||||
|
||||
instance ConnectionModeI m => StrEncoding (ConnShortLink m) where
|
||||
strEncode = \case
|
||||
CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k
|
||||
CSLContact sch ct srv (LinkKey k) -> slEncode sch srv (toLower $ ctTypeChar ct) "" k
|
||||
where
|
||||
slEncode sch (SMPServer (h :| hs) port (C.KeyHash kh)) linkType lnkId k =
|
||||
B.concat [authority, "/", B.singleton linkType, "#", lnkIdStr, B64.encodeUnpadded k, queryStr]
|
||||
where
|
||||
(authority, paramHosts) = case sch of
|
||||
SLSSimplex -> ("simplex:", h : hs)
|
||||
SLSServer -> ("https://" <> strEncode h, hs)
|
||||
lnkIdStr = if B.null lnkId then "" else B64.encodeUnpadded lnkId <> "/"
|
||||
queryStr = if B.null query then "" else "?" <> query
|
||||
query =
|
||||
strEncode . QSP QEscape $
|
||||
[("h", strEncode (TransportHosts_ paramHosts)) | not (null paramHosts)]
|
||||
<> [("p", B.pack port) | not (null port)]
|
||||
<> [("c", B64.encodeUnpadded kh) | not (B.null kh)]
|
||||
strP = (\(ACSL _ l) -> checkConnMode l) <$?> strP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding AConnShortLink where
|
||||
strEncode (ACSL _ l) = strEncode l
|
||||
{-# INLINE strEncode #-}
|
||||
strP = do
|
||||
(sch, h_) <- authorityP <* A.char '/'
|
||||
ct_ <- contactTypeP <* optional (A.char '/') <* A.char '#'
|
||||
case ct_ of
|
||||
Nothing -> do
|
||||
lnkId <- strP <* A.char '/'
|
||||
k <- strP
|
||||
srv <- serverQueryP h_
|
||||
pure $ ACSL SCMInvitation $ CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k)
|
||||
Just ct -> do
|
||||
k <- strP
|
||||
srv <- serverQueryP h_
|
||||
pure $ ACSL SCMContact $ CSLContact sch ct srv (LinkKey k)
|
||||
where
|
||||
authorityP =
|
||||
"simplex:" $> (SLSSimplex, Nothing)
|
||||
<|> "https://" *> ((SLSServer,) . Just <$> strP)
|
||||
<|> fail "bad short link scheme"
|
||||
contactTypeP = do
|
||||
Just <$> (A.anyChar >>= ctTypeP . toUpper)
|
||||
<|> A.char 'i' $> Nothing
|
||||
<|> fail "unknown short link type"
|
||||
serverQueryP h_ =
|
||||
optional (A.char '?' *> strP) >>= \case
|
||||
Nothing -> maybe noServer (pure . SMPServerOnlyHost) h_
|
||||
Just query -> do
|
||||
hs <- maybe noServer pure . L.nonEmpty . maybe id (:) h_ . maybe [] thList_ =<< queryParam_ "h" query
|
||||
p <- maybe "" show <$> queryParam_ @Word16 "p" query
|
||||
kh <- fromMaybe (C.KeyHash "") <$> queryParam_ "c" query
|
||||
pure $ SMPServer hs p kh
|
||||
noServer = fail "short link without server"
|
||||
|
||||
instance ConnectionModeI m => Encoding (ConnShortLink m) where
|
||||
smpEncode = \case
|
||||
CSLInvitation _ srv lnkId (LinkKey k) -> smpEncode (CMInvitation, srv, lnkId, k)
|
||||
CSLContact _ ct srv (LinkKey k) -> smpEncode (CMContact, ctTypeChar ct, srv, k)
|
||||
smpP = (\(ACSL _ l) -> checkConnMode l) <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance Encoding AConnShortLink where
|
||||
smpEncode (ACSL _ l) = smpEncode l
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
CMInvitation -> do
|
||||
(srv, lnkId, k) <- smpP
|
||||
pure $ ACSL SCMInvitation $ CSLInvitation SLSServer srv lnkId (LinkKey k)
|
||||
CMContact -> do
|
||||
ct <- ctTypeP =<< A.anyChar
|
||||
(srv, k) <- smpP
|
||||
pure $ ACSL SCMContact $ CSLContact SLSServer ct srv (LinkKey k)
|
||||
|
||||
ctTypeP :: Char -> Parser ContactConnType
|
||||
ctTypeP = \case
|
||||
'A' -> pure CCTContact
|
||||
'C' -> pure CCTChannel
|
||||
'G' -> pure CCTGroup
|
||||
_ -> fail "unknown contact address type"
|
||||
{-# INLINE ctTypeP #-}
|
||||
|
||||
ctTypeChar :: ContactConnType -> Char
|
||||
ctTypeChar = \case
|
||||
CCTContact -> 'A'
|
||||
CCTChannel -> 'C'
|
||||
CCTGroup -> 'G'
|
||||
{-# INLINE ctTypeChar #-}
|
||||
|
||||
-- the servers passed to this function should be all preset servers, not servers configured by the user.
|
||||
shortenShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m
|
||||
shortenShortLink presetSrvs = \case
|
||||
CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (shortServer srv) lnkId linkKey
|
||||
CSLContact sch ct srv linkKey -> CSLContact sch ct (shortServer srv) linkKey
|
||||
where
|
||||
shortServer srv@(SMPServer hs@(h :| _) p kh) =
|
||||
if isPresetServer then SMPServerOnlyHost h else srv
|
||||
where
|
||||
isPresetServer = case findPresetServer srv presetSrvs of
|
||||
Just (SMPServer hs' p' kh') ->
|
||||
all (`elem` hs') hs
|
||||
&& (p == p' || (null p' && (p == "443" || p == "5223")))
|
||||
&& kh == kh'
|
||||
Nothing -> False
|
||||
|
||||
-- explicit bidirectional is used for ghc 8.10.7 compatibility, [h]/[] patterns are not reversible.
|
||||
pattern SMPServerOnlyHost :: TransportHost -> SMPServer
|
||||
pattern SMPServerOnlyHost h <- SMPServer [h] "" (C.KeyHash "")
|
||||
where
|
||||
SMPServerOnlyHost h = SMPServer [h] "" (C.KeyHash "")
|
||||
|
||||
-- the servers passed to this function should be all preset servers, not servers configured by the user.
|
||||
restoreShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m
|
||||
restoreShortLink presetSrvs = \case
|
||||
CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (fullServer srv) lnkId linkKey
|
||||
CSLContact sch ct srv linkKey -> CSLContact sch ct (fullServer srv) linkKey
|
||||
where
|
||||
fullServer = \case
|
||||
s@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs
|
||||
s -> s
|
||||
|
||||
findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer
|
||||
findPresetServer ProtocolServer {host = h :| _} = find (\ProtocolServer {host = h' :| _} -> h == h')
|
||||
{-# INLINE findPresetServer #-}
|
||||
|
||||
sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
|
||||
sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
|
||||
L.length qs == L.length qs' && all same (L.zip qs qs')
|
||||
where
|
||||
same (q, q') = sameQAddress (qAddress q) (qAddress q')
|
||||
|
||||
sameShortLinkContact :: ConnShortLink 'CMContact -> ConnShortLink 'CMContact -> Bool
|
||||
sameShortLinkContact (CSLContact _ ct srv k) (CSLContact _ ct' srv' k') =
|
||||
ct == ct' && sameSrvAddr srv srv' && k == k'
|
||||
|
||||
checkConnMode :: forall t m m'. (ConnectionModeI m, ConnectionModeI m') => t m' -> Either String (t m)
|
||||
checkConnMode c = case testEquality (sConnectionMode @m) (sConnectionMode @m') of
|
||||
Just Refl -> Right c
|
||||
Nothing -> Left "bad connection mode"
|
||||
{-# INLINE checkConnMode #-}
|
||||
|
||||
data ConnReqUriData = ConnReqUriData
|
||||
{ crScheme :: ServiceScheme,
|
||||
crAgentVRange :: VersionRangeSMPA,
|
||||
@@ -1665,109 +1279,6 @@ data ConnReqUriData = ConnReqUriData
|
||||
|
||||
type CRClientData = Text
|
||||
|
||||
data FixedLinkData c = FixedLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
rootKey :: C.PublicKeyEd25519,
|
||||
connReq :: ConnectionRequestUri c
|
||||
}
|
||||
|
||||
data ConnLinkData c where
|
||||
InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
|
||||
ContactLinkData ::
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
-- direct connection via connReq in fixed data is allowed.
|
||||
direct :: Bool,
|
||||
-- additional owner keys to sign changes of mutable data.
|
||||
owners :: [OwnerAuth],
|
||||
-- alternative addresses of chat relays that receive requests for this contact address.
|
||||
relays :: [ConnShortLink 'CMContact],
|
||||
userData :: UserLinkData
|
||||
} -> ConnLinkData 'CMContact
|
||||
|
||||
newtype UserLinkData = UserLinkData ByteString
|
||||
|
||||
data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m)
|
||||
|
||||
linkUserData :: ConnLinkData c -> UserLinkData
|
||||
linkUserData = \case
|
||||
InvitationLinkData _ d -> d
|
||||
ContactLinkData {userData} -> userData
|
||||
{-# INLINE linkUserData #-}
|
||||
|
||||
linkUserData' :: ConnLinkData c -> ByteString
|
||||
linkUserData' d = let UserLinkData s = linkUserData d in s
|
||||
{-# INLINE linkUserData' #-}
|
||||
|
||||
type OwnerId = ByteString
|
||||
|
||||
data OwnerAuth = OwnerAuth
|
||||
{ ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId
|
||||
ownerKey :: C.PublicKeyEd25519,
|
||||
-- sender ID signed with ownerKey,
|
||||
-- confirms that the owner accepts being the owner.
|
||||
-- sender ID is used here as it is immutable for the queue, link data can be removed.
|
||||
ownerSig :: C.Signature 'C.Ed25519,
|
||||
-- null for root key authorization
|
||||
authOwnerId :: OwnerId,
|
||||
-- owner authorization, sig(ownerId || ownerKey, key(authOwnerId)),
|
||||
-- where authOwnerId is either null for a root key or some other owner authorized by root key, etc.
|
||||
-- Owner validation should detect and reject loops.
|
||||
authOwnerSig :: C.Signature 'C.Ed25519
|
||||
}
|
||||
|
||||
instance Encoding OwnerAuth where
|
||||
smpEncode OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} =
|
||||
smpEncode (ownerId, ownerKey, C.signatureBytes ownerSig, authOwnerId, C.signatureBytes authOwnerSig)
|
||||
smpP = do
|
||||
(ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig) <- smpP
|
||||
pure OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig}
|
||||
|
||||
instance ConnectionModeI c => Encoding (FixedLinkData c) where
|
||||
smpEncode FixedLinkData {agentVRange, rootKey, connReq} =
|
||||
smpEncode (agentVRange, rootKey, connReq)
|
||||
smpP = do
|
||||
(agentVRange, rootKey, connReq) <- smpP
|
||||
pure FixedLinkData {agentVRange, rootKey, connReq}
|
||||
|
||||
instance ConnectionModeI c => Encoding (ConnLinkData c) where
|
||||
smpEncode = \case
|
||||
InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData)
|
||||
ContactLinkData {agentVRange, direct, owners, relays, userData} ->
|
||||
B.concat [smpEncode (CMContact, agentVRange, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
|
||||
smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance Encoding AConnLinkData where
|
||||
smpEncode (ACLD _ d) = smpEncode d
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
CMInvitation -> do
|
||||
(vr, userData) <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
|
||||
pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
|
||||
CMContact -> do
|
||||
(agentVRange, direct) <- smpP
|
||||
owners <- smpListP
|
||||
relays <- smpListP
|
||||
userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
|
||||
pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData}
|
||||
|
||||
instance Encoding UserLinkData where
|
||||
smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s)
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = UserLinkData <$> ((A.char '\255' *> (unLarge <$> smpP)) <|> smpP)
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
data StoredClientService (s :: DBStored) = ClientService
|
||||
{ dbServiceId :: DBEntityId' s,
|
||||
serviceId :: SMP.ServiceId
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type ClientService = StoredClientService 'DBStored
|
||||
|
||||
type ClientServiceId = DBEntityId
|
||||
|
||||
-- | SMP queue status.
|
||||
data QueueStatus
|
||||
= -- | queue is created
|
||||
@@ -1837,7 +1348,7 @@ data AgentErrorType
|
||||
= -- | command or response error
|
||||
CMD {cmdErr :: CommandErrorType, errContext :: String}
|
||||
| -- | connection errors
|
||||
CONN {connErr :: ConnectionErrorType, errContext :: String}
|
||||
CONN {connErr :: ConnectionErrorType}
|
||||
| -- | user not found in database
|
||||
NO_USER
|
||||
| -- | SMP protocol errors forwarded to agent clients
|
||||
@@ -1900,8 +1411,6 @@ data SMPAgentError
|
||||
A_PROHIBITED {prohibitedErr :: String}
|
||||
| -- | incompatible version of SMP client, agent or encryption protocols
|
||||
A_VERSION
|
||||
| -- | failed signature, hash or senderId verification of retrieved link data
|
||||
A_LINK {linkErr :: String}
|
||||
| -- | cannot decrypt message
|
||||
A_CRYPTO {cryptoErr :: AgentCryptoError}
|
||||
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
|
||||
@@ -1971,7 +1480,7 @@ commandP binaryP =
|
||||
s :: Parser a -> Parser a
|
||||
s p = A.space *> p
|
||||
pqIKP :: Parser InitialKeys
|
||||
pqIKP = strP_ <|> pure (IKLinkPQ PQSupportOff)
|
||||
pqIKP = strP_ <|> pure (IKNoPQ PQSupportOff)
|
||||
pqSupP :: Parser PQSupport
|
||||
pqSupP = strP_ <|> pure PQSupportOff
|
||||
|
||||
@@ -2014,22 +1523,3 @@ $(J.deriveJSON (sumTypeJSON id) ''AgentErrorType)
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "QD") ''QueueDirection)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "SP") ''SwitchPhase)
|
||||
|
||||
instance ConnectionModeI m => FromJSON (CreatedConnLink m) where
|
||||
parseJSON = $(J.mkParseJSON defaultJSON ''CreatedConnLink)
|
||||
|
||||
instance ConnectionModeI m => ToJSON (CreatedConnLink m) where
|
||||
toEncoding = $(J.mkToEncoding defaultJSON ''CreatedConnLink)
|
||||
toJSON = $(J.mkToJSON defaultJSON ''CreatedConnLink)
|
||||
|
||||
instance FromJSON ACreatedConnLink where
|
||||
parseJSON (Object v) = do
|
||||
ACR m cReq <- v .: "connFullLink"
|
||||
shortLink <- v .:? "connShortLink"
|
||||
pure $ ACCL m $ CCLink cReq shortLink
|
||||
parseJSON invalid =
|
||||
JT.prependFailure "bad ACreatedConnLink, " (JT.typeMismatch "Object" invalid)
|
||||
|
||||
instance ToJSON ACreatedConnLink where
|
||||
toEncoding (ACCL _ ccLink) = toEncoding ccLink
|
||||
toJSON (ACCL _ ccLink) = toJSON ccLink
|
||||
|
||||
@@ -11,8 +11,8 @@ import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Simplex.Messaging.Agent.Protocol (UserId)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
|
||||
import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer)
|
||||
import Simplex.Messaging.Util (decodeJSON, encodeJSON)
|
||||
import UnliftIO.STM
|
||||
|
||||
@@ -30,11 +30,11 @@ import Data.Type.Equality
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval (RI2State)
|
||||
import Simplex.Messaging.Agent.Store.Common
|
||||
import Simplex.Messaging.Agent.Store.Interface (createDBStore)
|
||||
import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
|
||||
import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore)
|
||||
import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
( MsgBody,
|
||||
@@ -43,28 +43,39 @@ import Simplex.Messaging.Protocol
|
||||
NotifierId,
|
||||
NtfPrivateAuthKey,
|
||||
NtfPublicAuthKey,
|
||||
QueueMode,
|
||||
RcvDhSecret,
|
||||
RcvNtfDhSecret,
|
||||
RcvPrivateAuthKey,
|
||||
SenderCanSecure,
|
||||
SndPrivateAuthKey,
|
||||
SndPublicAuthKey,
|
||||
VersionSMPC,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
|
||||
createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
|
||||
createStore dbOpts = createDBStore dbOpts appMigrations
|
||||
createStore dbOpts = createDBStore dbOpts Migrations.app
|
||||
|
||||
-- * Queue types
|
||||
|
||||
type RcvQueue = StoredRcvQueue 'DBStored
|
||||
data QueueStored = QSStored | QSNew
|
||||
|
||||
type NewRcvQueue = StoredRcvQueue 'DBNew
|
||||
data SQueueStored (q :: QueueStored) where
|
||||
SQSStored :: SQueueStored 'QSStored
|
||||
SQSNew :: SQueueStored 'QSNew
|
||||
|
||||
data DBQueueId (q :: QueueStored) where
|
||||
DBQueueId :: Int64 -> DBQueueId 'QSStored
|
||||
DBNewQueue :: DBQueueId 'QSNew
|
||||
|
||||
deriving instance Show (DBQueueId q)
|
||||
|
||||
type RcvQueue = StoredRcvQueue 'QSStored
|
||||
|
||||
type NewRcvQueue = StoredRcvQueue 'QSNew
|
||||
|
||||
-- | A receive queue. SMP queue through which the agent receives messages from a sender.
|
||||
data StoredRcvQueue (q :: DBStored) = RcvQueue
|
||||
data StoredRcvQueue (q :: QueueStored) = RcvQueue
|
||||
{ userId :: UserId,
|
||||
connId :: ConnId,
|
||||
server :: SMPServer,
|
||||
@@ -81,15 +92,11 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
|
||||
-- | sender queue ID
|
||||
sndId :: SMP.SenderId,
|
||||
-- | sender can secure the queue
|
||||
queueMode :: Maybe QueueMode,
|
||||
-- | short link ID and credentials
|
||||
shortLink :: Maybe ShortLinkCreds,
|
||||
-- | associated client service
|
||||
clientService :: Maybe (StoredClientService q),
|
||||
sndSecure :: SenderCanSecure,
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
dbQueueId :: DBEntityId' q,
|
||||
dbQueueId :: DBQueueId q,
|
||||
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
|
||||
primary :: Bool,
|
||||
-- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
|
||||
@@ -103,26 +110,10 @@ data StoredRcvQueue (q :: DBStored) = RcvQueue
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ShortLinkCreds = ShortLinkCreds
|
||||
{ shortLinkId :: SMP.LinkId,
|
||||
shortLinkKey :: LinkKey,
|
||||
linkPrivSigKey :: C.PrivateKeyEd25519,
|
||||
linkEncFixedData :: SMP.EncFixedDataBytes
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
clientServiceId :: RcvQueue -> Maybe ClientServiceId
|
||||
clientServiceId = fmap dbServiceId . clientService
|
||||
{-# INLINE clientServiceId #-}
|
||||
|
||||
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
|
||||
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
|
||||
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
|
||||
|
||||
rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
|
||||
rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
|
||||
SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
|
||||
|
||||
canAbortRcvSwitch :: RcvQueue -> Bool
|
||||
canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
|
||||
where
|
||||
@@ -146,32 +137,19 @@ data ClientNtfCreds = ClientNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- This record is stored in inv_short_links table.
|
||||
-- It is needed only for 1-time invitation links because of "secure-on-read" property of link data,
|
||||
-- that prevents undetected access to link data from link observers.
|
||||
data InvShortLink = InvShortLink
|
||||
{ server :: SMPServer,
|
||||
linkId :: SMP.LinkId,
|
||||
linkKey :: LinkKey,
|
||||
sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries
|
||||
sndPublicKey :: SndPublicAuthKey,
|
||||
sndId :: Maybe SMP.SenderId
|
||||
}
|
||||
deriving (Show)
|
||||
type SndQueue = StoredSndQueue 'QSStored
|
||||
|
||||
type SndQueue = StoredSndQueue 'DBStored
|
||||
|
||||
type NewSndQueue = StoredSndQueue 'DBNew
|
||||
type NewSndQueue = StoredSndQueue 'QSNew
|
||||
|
||||
-- | A send queue. SMP queue through which the agent sends messages to a recipient.
|
||||
data StoredSndQueue (q :: DBStored) = SndQueue
|
||||
data StoredSndQueue (q :: QueueStored) = SndQueue
|
||||
{ userId :: UserId,
|
||||
connId :: ConnId,
|
||||
server :: SMPServer,
|
||||
-- | sender queue ID
|
||||
sndId :: SMP.SenderId,
|
||||
-- | sender can secure the queue
|
||||
queueMode :: Maybe QueueMode,
|
||||
sndSecure :: SenderCanSecure,
|
||||
-- | key pair used by the sender to authorize transmissions
|
||||
-- TODO combine keys to key pair so that types match
|
||||
sndPublicKey :: SndPublicAuthKey,
|
||||
@@ -183,7 +161,7 @@ data StoredSndQueue (q :: DBStored) = SndQueue
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
dbQueueId :: DBEntityId' q,
|
||||
dbQueueId :: DBQueueId q,
|
||||
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
|
||||
primary :: Bool,
|
||||
-- | ID of the queue this one is replacing
|
||||
@@ -256,7 +234,7 @@ instance SMPQueueRec RcvQueue where
|
||||
{-# INLINE qUserId #-}
|
||||
qConnId RcvQueue {connId} = connId
|
||||
{-# INLINE qConnId #-}
|
||||
dbQId RcvQueue {dbQueueId = DBEntityId qId} = qId
|
||||
dbQId RcvQueue {dbQueueId = DBQueueId qId} = qId
|
||||
{-# INLINE dbQId #-}
|
||||
dbReplaceQId RcvQueue {dbReplaceQueueId} = dbReplaceQueueId
|
||||
{-# INLINE dbReplaceQId #-}
|
||||
@@ -266,7 +244,7 @@ instance SMPQueueRec SndQueue where
|
||||
{-# INLINE qUserId #-}
|
||||
qConnId SndQueue {connId} = connId
|
||||
{-# INLINE qConnId #-}
|
||||
dbQId SndQueue {dbQueueId = DBEntityId qId} = qId
|
||||
dbQId SndQueue {dbQueueId = DBQueueId qId} = qId
|
||||
{-# INLINE dbQId #-}
|
||||
dbReplaceQId SndQueue {dbReplaceQueueId} = dbReplaceQueueId
|
||||
{-# INLINE dbReplaceQId #-}
|
||||
@@ -515,7 +493,7 @@ data NewInvitation = NewInvitation
|
||||
|
||||
data Invitation = Invitation
|
||||
{ invitationId :: InvitationId,
|
||||
contactConnId_ :: Maybe ConnId,
|
||||
contactConnId :: ConnId,
|
||||
connReq :: ConnectionRequestUri 'CMInvitation,
|
||||
recipientConnInfo :: ConnInfo,
|
||||
ownConnInfo :: Maybe ConnInfo,
|
||||
@@ -565,17 +543,9 @@ data SndMsgData = SndMsgData
|
||||
msgBody :: MsgBody,
|
||||
pqEncryption :: PQEncryption,
|
||||
internalHash :: MsgHash,
|
||||
prevMsgHash :: MsgHash,
|
||||
sndMsgPrepData_ :: Maybe SndMsgPrepData
|
||||
prevMsgHash :: MsgHash
|
||||
}
|
||||
|
||||
data SndMsgPrepData = SndMsgPrepData
|
||||
{ encryptKey :: MsgEncryptKeyX448,
|
||||
paddedLen :: Int,
|
||||
sndMsgBodyId :: Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data SndMsg = SndMsg
|
||||
{ internalId :: InternalId,
|
||||
internalSndId :: InternalSndId,
|
||||
@@ -591,17 +561,7 @@ data PendingMsgData = PendingMsgData
|
||||
msgBody :: MsgBody,
|
||||
pqEncryption :: PQEncryption,
|
||||
msgRetryState :: Maybe RI2State,
|
||||
internalTs :: InternalTs,
|
||||
internalSndId :: InternalSndId,
|
||||
prevMsgHash :: PrevSndMsgHash,
|
||||
pendingMsgPrepData_ :: Maybe PendingMsgPrepData
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data PendingMsgPrepData = PendingMsgPrepData
|
||||
{ encryptKey :: MsgEncryptKeyX448,
|
||||
paddedLen :: Int,
|
||||
sndMsgBody :: AMessage
|
||||
internalTs :: InternalTs
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -666,7 +626,7 @@ data StoreError
|
||||
SESndQueueExists
|
||||
| -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.
|
||||
-- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.
|
||||
SEBadConnType String ConnType
|
||||
SEBadConnType ConnType
|
||||
| -- | Confirmation not found.
|
||||
SEConfirmationNotFound
|
||||
| -- | Invitation not found
|
||||
|
||||
@@ -58,7 +58,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
getRcvQueueById,
|
||||
getSndQueueById,
|
||||
deleteConn,
|
||||
deleteConnRecord,
|
||||
upgradeRcvConnToDuplex,
|
||||
upgradeSndConnToDuplex,
|
||||
addConnRcvQueue,
|
||||
@@ -89,18 +88,10 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
acceptInvitation,
|
||||
unacceptInvitation,
|
||||
deleteInvitation,
|
||||
getInvShortLink,
|
||||
getInvShortLinkKeys,
|
||||
deleteInvShortLink,
|
||||
createInvShortLink,
|
||||
setInvShortLinkSndId,
|
||||
updateShortLinkCreds,
|
||||
-- Messages
|
||||
updateRcvIds,
|
||||
createRcvMsg,
|
||||
setLastBrokerTs,
|
||||
updateRcvMsgHash,
|
||||
createSndMsgBody,
|
||||
updateSndIds,
|
||||
createSndMsg,
|
||||
updateSndMsgHash,
|
||||
@@ -245,7 +236,7 @@ import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bifunctor (first, second)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -255,7 +246,7 @@ import Data.List (foldl', sortBy)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
|
||||
@@ -271,7 +262,7 @@ import Simplex.Messaging.Agent.Stats
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.Common
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
|
||||
@@ -280,12 +271,11 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
|
||||
import Simplex.Messaging.Protocol
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>))
|
||||
import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, tshow, ($>>=), (<$$>))
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
@@ -381,13 +371,12 @@ createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode
|
||||
createNewConn db gVar cData cMode = do
|
||||
fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode)
|
||||
|
||||
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
|
||||
updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
|
||||
updateNewConnRcv db connId rq =
|
||||
getConn db connId $>>= \case
|
||||
(SomeConn _ NewConnection {}) -> updateConn
|
||||
(SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
where
|
||||
updateConn :: IO (Either StoreError RcvQueue)
|
||||
updateConn = Right <$> addConnRcvQueue_ db connId rq
|
||||
@@ -396,7 +385,7 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr
|
||||
updateNewConnSnd db connId sq =
|
||||
getConn db connId $>>= \case
|
||||
(SomeConn _ NewConnection {}) -> updateConn
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
where
|
||||
updateConn :: IO (Either StoreError SndQueue)
|
||||
updateConn = Right <$> addConnSndQueue_ db connId sq
|
||||
@@ -420,9 +409,6 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup
|
||||
|]
|
||||
(userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True)
|
||||
|
||||
deleteConnRecord :: DB.Connection -> ConnId -> IO ()
|
||||
deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId)
|
||||
|
||||
checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
|
||||
checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
|
||||
fromMaybe False
|
||||
@@ -455,7 +441,7 @@ deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of
|
||||
(pure Nothing)
|
||||
)
|
||||
where
|
||||
delete = deleteConnRecord db connId $> Just connId
|
||||
delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId
|
||||
checkNoPendingDeliveries_ = do
|
||||
r :: (Maybe Int64) <-
|
||||
maybeFirstRow fromOnly $
|
||||
@@ -472,22 +458,20 @@ upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either S
|
||||
upgradeRcvConnToDuplex db connId sq =
|
||||
getConn db connId $>>= \case
|
||||
(SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c
|
||||
(SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
|
||||
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
|
||||
upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
|
||||
upgradeSndConnToDuplex db connId rq =
|
||||
getConn db connId >>= \case
|
||||
Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
-- TODO [certs rcv] store clientServiceId from NewRcvQueue
|
||||
addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
|
||||
addConnRcvQueue db connId rq =
|
||||
getConn db connId >>= \case
|
||||
Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue
|
||||
@@ -499,7 +483,7 @@ addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreErr
|
||||
addConnSndQueue db connId sq =
|
||||
getConn db connId >>= \case
|
||||
Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c
|
||||
Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue
|
||||
@@ -728,7 +712,7 @@ createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInf
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO conn_invitations
|
||||
(invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
|
||||
(invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
|
||||
|]
|
||||
(Binary invitationId, contactConnId, connReq, Binary recipientConnInfo)
|
||||
|
||||
@@ -745,8 +729,8 @@ getInvitation db cxt invitationId =
|
||||
|]
|
||||
(Only (Binary invitationId))
|
||||
where
|
||||
invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
|
||||
Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted}
|
||||
invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, BI accepted) =
|
||||
Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}
|
||||
|
||||
acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO ()
|
||||
acceptInvitation db invitationId ownConnInfo =
|
||||
@@ -764,85 +748,12 @@ unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
|
||||
unacceptInvitation db invitationId =
|
||||
DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId))
|
||||
|
||||
deleteInvitation :: DB.Connection -> InvitationId -> IO ()
|
||||
deleteInvitation db invId =
|
||||
DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId))
|
||||
|
||||
getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
|
||||
getInvShortLink db server linkId =
|
||||
maybeFirstRow toInvShortLink $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT link_key, snd_private_key, snd_id
|
||||
FROM inv_short_links
|
||||
WHERE host = ? AND port = ? AND link_id = ?
|
||||
|]
|
||||
(host server, port server, linkId)
|
||||
where
|
||||
toInvShortLink :: (LinkKey, C.APrivateAuthKey, Maybe SenderId) -> InvShortLink
|
||||
toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk), sndId) =
|
||||
let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk
|
||||
in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId}
|
||||
|
||||
getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe (LinkId, C.AAuthKeyPair))
|
||||
getInvShortLinkKeys db srv sndId =
|
||||
maybeFirstRow toSndKeys $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT link_id, snd_private_key
|
||||
FROM inv_short_links
|
||||
WHERE host = ? AND port = ? AND snd_id = ?
|
||||
|]
|
||||
(host srv, port srv, sndId)
|
||||
where
|
||||
toSndKeys :: (LinkId, C.APrivateAuthKey) -> (LinkId, C.AAuthKeyPair)
|
||||
toSndKeys (linkId, privKey@(C.APrivateAuthKey a pk)) = (linkId, (C.APublicAuthKey a $ C.publicKey pk, privKey))
|
||||
|
||||
deleteInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO ()
|
||||
deleteInvShortLink db srv lnkId =
|
||||
DB.execute db "DELETE FROM inv_short_links WHERE host = ? AND port = ? AND link_id = ?" (host srv, port srv, lnkId)
|
||||
|
||||
createInvShortLink :: DB.Connection -> InvShortLink -> IO ()
|
||||
createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId} = do
|
||||
serverKeyHash_ <- createServer_ db server
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO inv_short_links
|
||||
(host, port, server_key_hash, link_id, link_key, snd_private_key, snd_id)
|
||||
VALUES (?,?,?,?,?,?,?)
|
||||
ON CONFLICT (host, port, link_id)
|
||||
DO UPDATE SET
|
||||
server_key_hash = EXCLUDED.server_key_hash,
|
||||
link_key = EXCLUDED.link_key,
|
||||
snd_private_key = EXCLUDED.snd_private_key,
|
||||
snd_id = EXCLUDED.snd_id
|
||||
|]
|
||||
(host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey, sndId)
|
||||
|
||||
setInvShortLinkSndId :: DB.Connection -> InvShortLink -> SenderId -> IO ()
|
||||
setInvShortLinkSndId db InvShortLink {server, linkId} sndId =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE inv_short_links
|
||||
SET snd_id = ?
|
||||
WHERE host = ? AND port = ? AND link_id = ?
|
||||
|]
|
||||
(sndId, host server, port server, linkId)
|
||||
|
||||
updateShortLinkCreds :: DB.Connection -> RcvQueue -> ShortLinkCreds -> IO ()
|
||||
updateShortLinkCreds db RcvQueue {server, rcvId} ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData} =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_queues
|
||||
SET link_id = ?, link_key = ?, link_priv_sig_key = ?, link_enc_fixed_data = ?
|
||||
WHERE host = ? AND port = ? AND rcv_id = ?
|
||||
|]
|
||||
(shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData, host server, port server, rcvId)
|
||||
deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
|
||||
deleteInvitation db contactConnId invId =
|
||||
getConn db contactConnId $>>= \case
|
||||
SomeConn SCContact _ ->
|
||||
Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
|
||||
updateRcvIds db connId = do
|
||||
@@ -857,19 +768,7 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta =
|
||||
insertRcvMsgBase_ db connId rcvMsgData
|
||||
insertRcvMsgDetails_ db connId rq rcvMsgData
|
||||
updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
|
||||
setLastBrokerTs db connId dbQueueId brokerTs
|
||||
|
||||
setLastBrokerTs :: DB.Connection -> ConnId -> DBEntityId -> UTCTime -> IO ()
|
||||
setLastBrokerTs db connId dbQueueId brokerTs =
|
||||
DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ? AND (last_broker_ts IS NULL OR last_broker_ts < ?)" (brokerTs, connId, dbQueueId, brokerTs)
|
||||
|
||||
createSndMsgBody :: DB.Connection -> AMessage -> IO Int64
|
||||
createSndMsgBody db aMessage =
|
||||
fromOnly . head <$>
|
||||
DB.query
|
||||
db
|
||||
"INSERT INTO snd_message_bodies (agent_msg) VALUES (?) RETURNING snd_message_body_id"
|
||||
(Only aMessage)
|
||||
DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId)
|
||||
|
||||
updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
|
||||
updateSndIds db connId = runExceptT $ do
|
||||
@@ -937,7 +836,7 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
|
||||
(connId, dbQueueId)
|
||||
getMsgData :: InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData))
|
||||
getMsgData msgId = runExceptT $ do
|
||||
msg <- ExceptT $ firstRow' pendingMsgData err getMsgData_
|
||||
msg <- ExceptT $ firstRow pendingMsgData err getMsgData_
|
||||
rq_ <- liftIO $ L.head <$$> getRcvQueuesByConnId_ db connId
|
||||
pure (rq_, msg)
|
||||
where
|
||||
@@ -945,25 +844,18 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, m.internal_snd_id, s.previous_msg_hash,
|
||||
s.retry_int_slow, s.retry_int_fast, s.msg_encrypt_key, s.padded_msg_len, sb.agent_msg
|
||||
SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast
|
||||
FROM messages m
|
||||
JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
|
||||
LEFT JOIN snd_message_bodies sb ON sb.snd_message_body_id = s.snd_message_body_id
|
||||
WHERE m.conn_id = ? AND m.internal_id = ?
|
||||
|]
|
||||
(connId, msgId)
|
||||
err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []"
|
||||
pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, InternalSndId, PrevSndMsgHash, Maybe Int64, Maybe Int64, Maybe CR.MsgEncryptKeyX448, Maybe Int, Maybe AMessage) -> Either StoreError PendingMsgData
|
||||
pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, internalSndId, prevMsgHash, riSlow_, riFast_, encryptKey_, paddedLen_, sndMsgBody_) = do
|
||||
pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
|
||||
pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) =
|
||||
let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
|
||||
msgRetryState = RI2State <$> riSlow_ <*> riFast_
|
||||
result pendingMsgPrepData_ = PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs, internalSndId, prevMsgHash, pendingMsgPrepData_}
|
||||
in result <$> case (encryptKey_, paddedLen_, sndMsgBody_) of
|
||||
(Nothing, Nothing, Nothing) -> Right Nothing
|
||||
(Just encryptKey, Just paddedLen, Just sndMsgBody) -> Right $ Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody}
|
||||
_ -> Left $ SEInternal "unexpected snd msg data"
|
||||
in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs}
|
||||
markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
|
||||
|
||||
getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
|
||||
@@ -1093,13 +985,12 @@ deleteMsg db connId msgId =
|
||||
DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
|
||||
|
||||
deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO ()
|
||||
deleteMsgContent db connId msgId = do
|
||||
deleteMsgContent db connId msgId =
|
||||
#if defined(dbPostgres)
|
||||
DB.execute db "UPDATE messages SET msg_body = ''::BYTEA WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
|
||||
#else
|
||||
DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
|
||||
#endif
|
||||
DB.execute db "UPDATE snd_messages SET snd_message_body_id = NULL WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
|
||||
|
||||
deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
|
||||
deleteDeliveredSndMsg db connId msgId = do
|
||||
@@ -1112,39 +1003,13 @@ deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do
|
||||
db
|
||||
"DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?"
|
||||
(connId, dbQueueId, msgId)
|
||||
getRcptAndBodyId >>= mapM_ deleteMsgAndBody
|
||||
where
|
||||
getRcptAndBodyId :: IO (Maybe (Maybe MsgReceiptStatus, Maybe Int64))
|
||||
getRcptAndBodyId =
|
||||
-- Get receipt status and message body ID if there are no pending deliveries.
|
||||
-- The current delivery is deleted above.
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT rcpt_status, snd_message_body_id FROM snd_messages
|
||||
WHERE NOT EXISTS (SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0)
|
||||
AND conn_id = ? AND internal_id = ?
|
||||
|]
|
||||
(connId, msgId, connId, msgId)
|
||||
deleteMsgAndBody :: (Maybe MsgReceiptStatus, Maybe Int64) -> IO ()
|
||||
deleteMsgAndBody (rcptStatus_, sndMsgBodyId_) = do
|
||||
let del = case rcptStatus_ of
|
||||
-- we are not deleting message if receipt is not received or had incorrect hash (for debugging).
|
||||
Just MROk -> deleteMsg
|
||||
_ -> if keepForReceipt then deleteMsgContent else deleteMsg
|
||||
del db connId msgId
|
||||
forM_ sndMsgBodyId_ $ \bodyId ->
|
||||
-- Delete message body if it is not used by any snd message.
|
||||
-- The current snd message is already deleted by deleteMsg or cleared by deleteMsgContent.
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM snd_message_bodies
|
||||
WHERE NOT EXISTS (SELECT 1 FROM snd_messages WHERE snd_message_body_id = ?)
|
||||
AND snd_message_body_id = ?
|
||||
|]
|
||||
(bodyId, bodyId)
|
||||
cnt <- countPendingSndDeliveries_ db connId msgId
|
||||
when (cnt == 0) $ do
|
||||
del <-
|
||||
maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case
|
||||
Just (Just (_ :: Int64), Just MROk) -> pure deleteMsg
|
||||
_ -> pure $ if keepForReceipt then deleteMsgContent else deleteMsg
|
||||
del db connId msgId
|
||||
|
||||
countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int
|
||||
countPendingSndDeliveries_ db connId msgId = do
|
||||
@@ -1213,7 +1078,7 @@ getSndRatchet db connId v =
|
||||
DB.query db "SELECT ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem FROM ratchets WHERE conn_id = ?" (Only connId)
|
||||
where
|
||||
result = \case
|
||||
(Just ratchetState, Just k1, Just k2, pKem_) ->
|
||||
(Just ratchetState, Just k1, Just k2, pKem_) ->
|
||||
let params = case pKem_ of
|
||||
Nothing -> CR.AE2ERatchetParams CR.SRKSProposed (CR.E2ERatchetParams v k1 k2 Nothing)
|
||||
Just (CR.ARKP s pKem) -> CR.AE2ERatchetParams s (CR.E2ERatchetParams v k1 k2 (Just pKem))
|
||||
@@ -1787,19 +1652,19 @@ getActiveNtfToken db =
|
||||
ntfMode = fromMaybe NMPeriodic ntfMode_
|
||||
in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
|
||||
|
||||
getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime))
|
||||
getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime))
|
||||
getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
|
||||
firstRow' res SEConnNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_id, rcv_queue_id, rcv_ntf_dh_secret, last_broker_ts
|
||||
SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts
|
||||
FROM rcv_queues
|
||||
WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
|
||||
|]
|
||||
(host, port, notifierId)
|
||||
where
|
||||
res (connId, dbQueueId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, dbQueueId, rcvNtfDhSecret, lastBrokerTs_)
|
||||
res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_)
|
||||
res _ = Left SEConnNotFound
|
||||
|
||||
setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
|
||||
@@ -1812,6 +1677,15 @@ instance ToField QueueStatus where toField = toField . serializeQueueStatus
|
||||
|
||||
instance FromField QueueStatus where fromField = fromTextField_ queueStatusT
|
||||
|
||||
instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId
|
||||
|
||||
instance FromField (DBQueueId 'QSStored) where
|
||||
#if defined(dbPostgres)
|
||||
fromField x dat = DBQueueId <$> fromField x dat
|
||||
#else
|
||||
fromField x = DBQueueId <$> fromField x
|
||||
#endif
|
||||
|
||||
instance ToField InternalRcvId where toField (InternalRcvId x) = toField x
|
||||
|
||||
deriving newtype instance FromField InternalRcvId
|
||||
@@ -1826,23 +1700,23 @@ deriving newtype instance FromField InternalId
|
||||
|
||||
instance ToField AgentMessageType where toField = toField . Binary . smpEncode
|
||||
|
||||
instance FromField AgentMessageType where fromField = blobFieldDecoder smpDecode
|
||||
instance FromField AgentMessageType where fromField = blobFieldParser smpP
|
||||
|
||||
instance ToField MsgIntegrity where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField MsgIntegrity where fromField = blobFieldDecoder strDecode
|
||||
instance FromField MsgIntegrity where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField SMPQueueUri where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField SMPQueueUri where fromField = blobFieldDecoder strDecode
|
||||
instance FromField SMPQueueUri where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField AConnectionRequestUri where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField AConnectionRequestUri where fromField = blobFieldDecoder strDecode
|
||||
instance FromField AConnectionRequestUri where fromField = blobFieldParser strP
|
||||
|
||||
instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . Binary . strEncode
|
||||
|
||||
instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldDecoder strDecode
|
||||
instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
@@ -1858,7 +1732,7 @@ instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . s
|
||||
|
||||
instance ToField [SMPQueueInfo] where toField = toField . Binary . smpEncodeList
|
||||
|
||||
instance FromField [SMPQueueInfo] where fromField = blobFieldDecoder $ parseAll smpListP
|
||||
instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
|
||||
|
||||
instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
@@ -1866,11 +1740,11 @@ instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ e
|
||||
|
||||
instance ToField AgentCommand where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField AgentCommand where fromField = blobFieldDecoder strDecode
|
||||
instance FromField AgentCommand where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField AgentCommandTag where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField AgentCommandTag where fromField = blobFieldDecoder strDecode
|
||||
instance FromField AgentCommandTag where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
@@ -1888,10 +1762,23 @@ deriving newtype instance ToField ChunkReplicaId
|
||||
|
||||
deriving newtype instance FromField ChunkReplicaId
|
||||
|
||||
listToEither :: e -> [a] -> Either e a
|
||||
listToEither _ (x : _) = Right x
|
||||
listToEither e _ = Left e
|
||||
|
||||
firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
|
||||
firstRow f e a = second f . listToEither e <$> a
|
||||
|
||||
maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b)
|
||||
maybeFirstRow f q = fmap f . listToMaybe <$> q
|
||||
|
||||
fromOnlyBI :: Only BoolInt -> Bool
|
||||
fromOnlyBI (Only (BI b)) = b
|
||||
{-# INLINE fromOnlyBI #-}
|
||||
|
||||
firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
|
||||
firstRow' f e a = (f <=< listToEither e) <$> a
|
||||
|
||||
#if !defined(dbPostgres)
|
||||
{- ORMOLU_DISABLE -}
|
||||
-- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
|
||||
@@ -1967,24 +1854,10 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO rcv_queues
|
||||
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
|
||||
snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
|
||||
link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
|
||||
ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
|
||||
:. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
|
||||
:. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
|
||||
:. ntfCredsFields
|
||||
)
|
||||
-- TODO [certs rcv] save client service
|
||||
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
|
||||
where
|
||||
ntfCredsFields = case clientNtfCreds of
|
||||
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing)
|
||||
((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
|
||||
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
|
||||
|
||||
-- * createSndConn helpers
|
||||
|
||||
@@ -1998,14 +1871,14 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO snd_queues
|
||||
(host, port, snd_id, queue_mode, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret,
|
||||
(host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret,
|
||||
status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
ON CONFLICT (host, port, snd_id) DO UPDATE SET
|
||||
host=EXCLUDED.host,
|
||||
port=EXCLUDED.port,
|
||||
snd_id=EXCLUDED.snd_id,
|
||||
queue_mode=EXCLUDED.queue_mode,
|
||||
snd_secure=EXCLUDED.snd_secure,
|
||||
conn_id=EXCLUDED.conn_id,
|
||||
snd_public_key=EXCLUDED.snd_public_key,
|
||||
snd_private_key=EXCLUDED.snd_private_key,
|
||||
@@ -2018,13 +1891,13 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
|
||||
smp_client_version=EXCLUDED.smp_client_version,
|
||||
server_key_hash=EXCLUDED.server_key_hash
|
||||
|]
|
||||
((host server, port server, sndId, queueMode, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret)
|
||||
((host server, port server, sndId, BI sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret)
|
||||
:. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
|
||||
pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
|
||||
|
||||
newQueueId_ :: [Only Int64] -> DBEntityId
|
||||
newQueueId_ [] = DBEntityId 1
|
||||
newQueueId_ (Only maxId : _) = DBEntityId (maxId + 1)
|
||||
newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
|
||||
newQueueId_ [] = DBQueueId 1
|
||||
newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
|
||||
|
||||
-- * getConn helpers
|
||||
|
||||
@@ -2149,37 +2022,26 @@ rcvQueueQuery :: Query
|
||||
rcvQueueQuery =
|
||||
[sql|
|
||||
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
|
||||
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status,
|
||||
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
|
||||
q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
|]
|
||||
|
||||
toRcvQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, Maybe QueueMode)
|
||||
:. (QueueStatus, DBEntityId, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret)
|
||||
:. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) ->
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt)
|
||||
:. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
|
||||
RcvQueue
|
||||
toRcvQueue
|
||||
( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode)
|
||||
:. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
|
||||
:. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)
|
||||
:. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_)
|
||||
) =
|
||||
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
|
||||
let server = SMPServer host port keyHash
|
||||
smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_
|
||||
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
_ -> Nothing
|
||||
shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
|
||||
(Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
|
||||
_ -> Nothing
|
||||
-- TODO [certs rcv] read client service
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, queueMode, shortLink, clientService = Nothing, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
|
||||
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById db connId dbRcvId =
|
||||
@@ -2200,7 +2062,7 @@ sndQueueQuery :: Query
|
||||
sndQueueQuery =
|
||||
[sql|
|
||||
SELECT
|
||||
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.queue_mode,
|
||||
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure,
|
||||
q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
|
||||
q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
|
||||
FROM snd_queues q
|
||||
@@ -2209,18 +2071,18 @@ sndQueueQuery =
|
||||
|]
|
||||
|
||||
toSndQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, Maybe QueueMode)
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, BoolInt)
|
||||
:. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
|
||||
:. (DBEntityId, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
|
||||
:. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
|
||||
SndQueue
|
||||
toSndQueue
|
||||
( (userId, keyHash, connId, host, port, sndId, queueMode)
|
||||
( (userId, keyHash, connId, host, port, sndId, BI sndSecure)
|
||||
:. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status)
|
||||
:. (dbQueueId, BI primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
|
||||
) =
|
||||
let server = SMPServer host port keyHash
|
||||
sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey
|
||||
in SndQueue {userId, connId, server, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
|
||||
in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
|
||||
|
||||
getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
|
||||
getSndQueueById db connId dbSndId =
|
||||
@@ -2344,15 +2206,11 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} =
|
||||
dbConn
|
||||
[sql|
|
||||
INSERT INTO snd_messages
|
||||
( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash, msg_encrypt_key, padded_msg_len, snd_message_body_id)
|
||||
( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash)
|
||||
VALUES
|
||||
(?,?,?,?,?,?,?,?)
|
||||
(?,?,?,?,?)
|
||||
|]
|
||||
(connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash, encryptKey_, paddedLen_, sndMsgBodyId_)
|
||||
where
|
||||
(encryptKey_, paddedLen_, sndMsgBodyId_) = case sndMsgPrepData_ of
|
||||
Nothing -> (Nothing, Nothing, Nothing)
|
||||
Just SndMsgPrepData {encryptKey, paddedLen, sndMsgBodyId} -> (Just encryptKey, Just paddedLen, Just sndMsgBodyId)
|
||||
(connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash)
|
||||
|
||||
updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO ()
|
||||
updateSndMsgHash db connId internalSndId internalHash =
|
||||
|
||||
@@ -16,3 +16,4 @@ import Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
where
|
||||
import Simplex.Messaging.Agent.Store.SQLite.DB
|
||||
#endif
|
||||
|
||||
|
||||
@@ -1,72 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Entity where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import Data.Int (Int64)
|
||||
import Data.Scientific (floatingOrInteger)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
|
||||
data DBStored = DBStored | DBNew
|
||||
|
||||
data SDBStored (s :: DBStored) where
|
||||
SDBStored :: SDBStored 'DBStored
|
||||
SDBNew :: SDBStored 'DBNew
|
||||
|
||||
deriving instance Show (SDBStored s)
|
||||
|
||||
class DBStoredI s where sdbStored :: SDBStored s
|
||||
|
||||
instance DBStoredI 'DBStored where sdbStored = SDBStored
|
||||
|
||||
instance DBStoredI 'DBNew where sdbStored = SDBNew
|
||||
|
||||
data DBEntityId' (s :: DBStored) where
|
||||
DBEntityId :: Int64 -> DBEntityId' 'DBStored
|
||||
DBNewEntity :: DBEntityId' 'DBNew
|
||||
|
||||
deriving instance Show (DBEntityId' s)
|
||||
|
||||
deriving instance Eq (DBEntityId' s)
|
||||
|
||||
type DBEntityId = DBEntityId' 'DBStored
|
||||
|
||||
type DBNewEntity = DBEntityId' 'DBNew
|
||||
|
||||
instance ToJSON (DBEntityId' s) where
|
||||
toEncoding = \case
|
||||
DBEntityId i -> toEncoding i
|
||||
DBNewEntity -> JE.null_
|
||||
toJSON = \case
|
||||
DBEntityId i -> toJSON i
|
||||
DBNewEntity -> J.Null
|
||||
|
||||
instance DBStoredI s => FromJSON (DBEntityId' s) where
|
||||
parseJSON v = case (v, sdbStored @s) of
|
||||
(J.Null, SDBNew) -> pure DBNewEntity
|
||||
(J.Number n, SDBStored) -> case floatingOrInteger n of
|
||||
Left (_ :: Double) -> fail "bad DBEntityId"
|
||||
Right i -> pure $ DBEntityId (fromInteger i)
|
||||
_ -> fail "bad DBEntityId"
|
||||
omittedField = case sdbStored @s of
|
||||
SDBStored -> Nothing
|
||||
SDBNew -> Just DBNewEntity
|
||||
|
||||
instance FromField DBEntityId where
|
||||
#if defined(dbPostgres)
|
||||
fromField x dat = DBEntityId <$> fromField x dat
|
||||
#else
|
||||
fromField x = DBEntityId <$> fromField x
|
||||
#endif
|
||||
|
||||
instance ToField DBEntityId where toField (DBEntityId i) = toField i
|
||||
@@ -1,11 +1,16 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Migrations
|
||||
( Migration (..),
|
||||
MigrationsToRun (..),
|
||||
DownMigration (..),
|
||||
DBMigrate (..),
|
||||
sharedMigrateSchema,
|
||||
Migrations.app,
|
||||
Migrations.getCurrent,
|
||||
get,
|
||||
Migrations.initialize,
|
||||
Migrations.run,
|
||||
migrateSchema,
|
||||
-- for tests
|
||||
migrationsToRun,
|
||||
toDownMigration,
|
||||
@@ -16,9 +21,19 @@ import Control.Monad
|
||||
import Data.Char (toLower)
|
||||
import Data.Functor (($>))
|
||||
import Data.Maybe (isNothing, mapMaybe)
|
||||
import Simplex.Messaging.Agent.Store.Common
|
||||
import Simplex.Messaging.Agent.Store.Shared
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (hFlush, stdout)
|
||||
#if defined(dbPostgres)
|
||||
import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
|
||||
#else
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
||||
import System.Directory (copyFile)
|
||||
#endif
|
||||
|
||||
get :: DBStore -> [Migration] -> IO (Either MTRError MigrationsToRun)
|
||||
get st migrations = migrationsToRun migrations <$> withTransaction st Migrations.getCurrent
|
||||
|
||||
migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun
|
||||
migrationsToRun [] [] = Right MTRNone
|
||||
@@ -33,42 +48,44 @@ migrationsToRun (a : as) (d : ds)
|
||||
| name a == name d = migrationsToRun as ds
|
||||
| otherwise = Left $ MTREDifferent (name a) (name d)
|
||||
|
||||
data DBMigrate = DBMigrate
|
||||
{ initialize :: IO (),
|
||||
getCurrent :: IO [Migration],
|
||||
run :: MigrationsToRun -> IO (),
|
||||
backup :: IO ()
|
||||
}
|
||||
|
||||
sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
|
||||
sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
|
||||
initialize dbm
|
||||
currentMs <- getCurrent dbm
|
||||
case migrationsToRun migrations currentMs of
|
||||
migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError ())
|
||||
migrateSchema st migrations confirmMigrations vacuum = do
|
||||
Migrations.initialize st
|
||||
get st migrations >>= \case
|
||||
Left e -> do
|
||||
when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
|
||||
pure . Left $ MigrationError e
|
||||
Right MTRNone -> pure $ Right ()
|
||||
Right ms@(MTRUp ums)
|
||||
| dbNew' -> run dbm ms $> Right ()
|
||||
| dbNew st -> Migrations.run st vacuum ms $> Right ()
|
||||
| otherwise -> case confirmMigrations of
|
||||
MCYesUp -> runWithBackup ms
|
||||
MCYesUpDown -> runWithBackup ms
|
||||
MCConsole -> confirm err >> runWithBackup ms
|
||||
MCYesUp -> runWithBackup st vacuum ms
|
||||
MCYesUpDown -> runWithBackup st vacuum ms
|
||||
MCConsole -> confirm err >> runWithBackup st vacuum ms
|
||||
MCError -> pure $ Left err
|
||||
where
|
||||
err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
|
||||
Right ms@(MTRDown dms) -> case confirmMigrations of
|
||||
MCYesUpDown -> runWithBackup ms
|
||||
MCConsole -> confirm err >> runWithBackup ms
|
||||
MCYesUpDown -> runWithBackup st vacuum ms
|
||||
MCConsole -> confirm err >> runWithBackup st vacuum ms
|
||||
MCYesUp -> pure $ Left err
|
||||
MCError -> pure $ Left err
|
||||
where
|
||||
err = MEDowngrade $ map downName dms
|
||||
where
|
||||
runWithBackup ms = backup dbm >> run dbm ms $> Right ()
|
||||
confirm err = confirmOrExit $ migrationErrorDescription err
|
||||
|
||||
runWithBackup :: DBStore -> Bool -> MigrationsToRun -> IO (Either a ())
|
||||
#if defined(dbPostgres)
|
||||
runWithBackup st vacuum ms = Migrations.run st vacuum ms $> Right ()
|
||||
#else
|
||||
runWithBackup st vacuum ms = do
|
||||
let f = dbFilePath st
|
||||
copyFile f (f <> ".bak")
|
||||
Migrations.run st vacuum ms
|
||||
pure $ Right ()
|
||||
#endif
|
||||
|
||||
confirmOrExit :: String -> IO ()
|
||||
confirmOrExit s = do
|
||||
putStrLn s
|
||||
|
||||
@@ -1,14 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Migrations.App
|
||||
#if defined(dbPostgres)
|
||||
( module Simplex.Messaging.Agent.Store.Postgres.Migrations.App,
|
||||
)
|
||||
where
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.App
|
||||
#else
|
||||
( module Simplex.Messaging.Agent.Store.SQLite.Migrations.App,
|
||||
)
|
||||
where
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.App
|
||||
#endif
|
||||
@@ -6,8 +6,6 @@
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres
|
||||
( DBOpts (..),
|
||||
Migrations.getCurrentMigrations,
|
||||
checkSchemaExists,
|
||||
createDBStore,
|
||||
closeDBStore,
|
||||
reopenDBStore,
|
||||
@@ -15,119 +13,95 @@ module Simplex.Messaging.Agent.Store.Postgres
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (finally, onException, throwIO, uninterruptibleMask_)
|
||||
import Control.Logger.Simple (logError)
|
||||
import Control.Monad
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad (unless, void)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor (($>))
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import Database.PostgreSQL.Simple.Types (Query (..))
|
||||
import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema)
|
||||
import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
|
||||
import Simplex.Messaging.Agent.Store.Migrations (migrateSchema)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
|
||||
import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
|
||||
import System.Exit (exitFailure)
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import UnliftIO.Exception (bracketOnError, onException)
|
||||
import UnliftIO.MVar
|
||||
import UnliftIO.STM
|
||||
|
||||
data DBOpts = DBOpts
|
||||
{ connstr :: ByteString,
|
||||
schema :: String
|
||||
}
|
||||
|
||||
-- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
|
||||
-- If passed schema does not exist in connectInfo database, it will be created.
|
||||
-- Applies necessary migrations to schema.
|
||||
-- TODO [postgres] authentication / user password, db encryption (?)
|
||||
createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
|
||||
createDBStore opts migrations confirmMigrations = do
|
||||
st <- connectPostgresStore opts
|
||||
r <- migrateSchema st `onException` closeDBStore st
|
||||
createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do
|
||||
st <- connectPostgresStore connstr schema
|
||||
r <- migrateSchema st migrations confirmMigrations True `onException` closeDBStore st
|
||||
case r of
|
||||
Right () -> pure $ Right st
|
||||
Left e -> closeDBStore st $> Left e
|
||||
where
|
||||
migrateSchema st =
|
||||
let initialize = Migrations.initialize st
|
||||
getCurrent = withTransaction st Migrations.getCurrentMigrations
|
||||
dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
|
||||
in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
|
||||
|
||||
connectPostgresStore :: DBOpts -> IO DBStore
|
||||
connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do
|
||||
dbPriorityPool <- newDBStorePool poolSize
|
||||
dbPool <- newDBStorePool poolSize
|
||||
dbClosed <- newTVarIO True
|
||||
let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPriorityPool, dbPool, dbNew = False, dbClosed}
|
||||
dbNew <- connectStore st createSchema
|
||||
pure st {dbNew}
|
||||
connectPostgresStore :: ByteString -> String -> IO DBStore
|
||||
connectPostgresStore dbConnstr dbSchema = do
|
||||
(dbConn, dbNew) <- connectDB dbConnstr dbSchema -- TODO [postgres] analogue for dbBusyLoop?
|
||||
dbConnection <- newMVar dbConn
|
||||
dbClosed <- newTVarIO False
|
||||
pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed}
|
||||
|
||||
-- uninterruptibleMask_ here and below is used here so that it is not interrupted half-way,
|
||||
-- it relies on the assumption that when dbClosed = True, the queue is empty,
|
||||
-- and when it is False, the queue is full (or will have connections returned to it by the threads that use them).
|
||||
connectStore :: DBStore -> Bool -> IO Bool
|
||||
connectStore DBStore {dbConnstr, dbSchema, dbPoolSize, dbPriorityPool, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do
|
||||
(conn, dbNew) <- connectDB dbConnstr dbSchema createSchema -- TODO [postgres] analogue for dbBusyLoop?
|
||||
writeConns dbPriorityPool . (conn :) =<< mkConns (dbPoolSize - 1)
|
||||
writeConns dbPool =<< mkConns dbPoolSize
|
||||
atomically $ writeTVar dbClosed False
|
||||
pure dbNew
|
||||
where
|
||||
writeConns pool conns = mapM_ (atomically . writeTBQueue (dbPoolConns pool)) conns
|
||||
mkConns n = replicateM n $ fst <$> connectDB dbConnstr dbSchema False
|
||||
|
||||
connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool)
|
||||
connectDB connstr schema createSchema = do
|
||||
connectDB :: ByteString -> String -> IO (DB.Connection, Bool)
|
||||
connectDB connstr schema = do
|
||||
db <- PSQL.connectPostgreSQL connstr
|
||||
dbNew <- prepare db `onException` PSQL.close db
|
||||
schemaExists <- prepare db `onException` PSQL.close db
|
||||
let dbNew = not schemaExists
|
||||
pure (db, dbNew)
|
||||
where
|
||||
prepare db = do
|
||||
void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
|
||||
dbNew <- not <$> doesSchemaExist db schema
|
||||
when dbNew $
|
||||
if createSchema
|
||||
then void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
|
||||
else do
|
||||
logError $ "connectPostgresStore, schema " <> safeDecodeUtf8 schema <> " does not exist, exiting."
|
||||
PSQL.close db
|
||||
exitFailure
|
||||
void $ PSQL.execute_ db $ Query $ "SET search_path TO " <> schema
|
||||
pure dbNew
|
||||
|
||||
checkSchemaExists :: ByteString -> ByteString -> IO Bool
|
||||
checkSchemaExists connstr schema = do
|
||||
db <- PSQL.connectPostgreSQL connstr
|
||||
doesSchemaExist db schema `finally` DB.close db
|
||||
|
||||
doesSchemaExist :: DB.Connection -> ByteString -> IO Bool
|
||||
doesSchemaExist db schema = do
|
||||
[Only schemaExists] <-
|
||||
PSQL.query
|
||||
db
|
||||
[sql|
|
||||
SELECT EXISTS (
|
||||
SELECT 1 FROM pg_catalog.pg_namespace
|
||||
WHERE nspname = ?
|
||||
)
|
||||
|]
|
||||
(Only schema)
|
||||
pure schemaExists
|
||||
[Only schemaExists] <-
|
||||
PSQL.query
|
||||
db
|
||||
[sql|
|
||||
SELECT EXISTS (
|
||||
SELECT 1 FROM pg_catalog.pg_namespace
|
||||
WHERE nspname = ?
|
||||
)
|
||||
|]
|
||||
(Only schema)
|
||||
unless schemaExists $ void $ PSQL.execute_ db (fromString $ "CREATE SCHEMA " <> schema)
|
||||
void $ PSQL.execute_ db (fromString $ "SET search_path TO " <> schema)
|
||||
pure schemaExists
|
||||
|
||||
-- can share with SQLite
|
||||
closeDBStore :: DBStore -> IO ()
|
||||
closeDBStore DBStore {dbPoolSize, dbPriorityPool, dbPool, dbClosed} =
|
||||
ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do
|
||||
closePool dbPriorityPool
|
||||
closePool dbPool
|
||||
atomically $ writeTVar dbClosed True
|
||||
where
|
||||
closePool pool = replicateM_ dbPoolSize $ atomically (readTBQueue $ dbPoolConns pool) >>= DB.close
|
||||
closeDBStore st@DBStore {dbClosed} =
|
||||
ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $
|
||||
withConnection st $ \conn -> do
|
||||
DB.close conn
|
||||
atomically $ writeTVar dbClosed True
|
||||
|
||||
openPostgresStore_ :: DBStore -> IO ()
|
||||
openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} =
|
||||
bracketOnError
|
||||
(takeMVar dbConnection)
|
||||
(tryPutMVar dbConnection)
|
||||
$ \_dbConn -> do
|
||||
(dbConn, _dbNew) <- connectDB dbConnstr dbSchema
|
||||
atomically $ writeTVar dbClosed False
|
||||
putMVar dbConnection dbConn
|
||||
|
||||
reopenDBStore :: DBStore -> IO ()
|
||||
reopenDBStore st =
|
||||
ifM
|
||||
(readTVarIO $ dbClosed st)
|
||||
(void $ connectStore st False)
|
||||
(putStrLn "reopenDBStore: already opened")
|
||||
reopenDBStore st@DBStore {dbClosed} =
|
||||
ifM (readTVarIO dbClosed) open (putStrLn "reopenDBStore: already opened")
|
||||
where
|
||||
open = openPostgresStore_ st
|
||||
|
||||
-- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL)
|
||||
-- TODO [postgres] not necessary for postgres (used for ExecAgentStoreSQL, ExecChatStoreSQL)
|
||||
execSQL :: PSQL.Connection -> Text -> IO [Text]
|
||||
execSQL _db _query = throwIO (userError "not implemented")
|
||||
|
||||
@@ -1,14 +1,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
( DBStore (..),
|
||||
DBStorePool (..),
|
||||
DBOpts (..),
|
||||
newDBStorePool,
|
||||
withConnection,
|
||||
withConnection',
|
||||
withTransaction,
|
||||
@@ -17,65 +10,33 @@ module Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (bracket)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Numeric.Natural (Natural)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Options
|
||||
import UnliftIO.MVar
|
||||
import UnliftIO.STM
|
||||
|
||||
-- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type)
|
||||
data DBStore = DBStore
|
||||
{ dbConnstr :: ByteString,
|
||||
dbSchema :: ByteString,
|
||||
dbPoolSize :: Int,
|
||||
dbPriorityPool :: DBStorePool,
|
||||
dbPool :: DBStorePool,
|
||||
-- dbPoolSize :: Int,
|
||||
-- dbPool :: TBQueue PSQL.Connection,
|
||||
-- -- MVar is needed for fair pool distribution, without STM retry contention.
|
||||
-- -- Only one thread can be blocked on STM read.
|
||||
-- dbSem :: MVar (),
|
||||
dbSchema :: String,
|
||||
dbConnection :: MVar PSQL.Connection,
|
||||
dbClosed :: TVar Bool,
|
||||
dbNew :: Bool
|
||||
}
|
||||
|
||||
newDBStorePool :: Natural -> IO DBStorePool
|
||||
newDBStorePool poolSize = do
|
||||
dbSem <- newMVar ()
|
||||
dbPoolConns <- newTBQueueIO poolSize
|
||||
pure DBStorePool {dbSem, dbPoolConns}
|
||||
|
||||
data DBStorePool = DBStorePool
|
||||
{ dbPoolConns :: TBQueue PSQL.Connection,
|
||||
-- MVar is needed for fair pool distribution, without STM retry contention.
|
||||
-- Only one thread can be blocked on STM read.
|
||||
dbSem :: MVar ()
|
||||
}
|
||||
|
||||
-- TODO [postgres] connection pool
|
||||
withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
|
||||
withConnectionPriority DBStore {dbPriorityPool, dbPool} priority =
|
||||
withConnectionPool $ if priority then dbPriorityPool else dbPool
|
||||
{-# INLINE withConnectionPriority #-}
|
||||
|
||||
withConnectionPool :: DBStorePool -> (PSQL.Connection -> IO a) -> IO a
|
||||
withConnectionPool DBStorePool {dbPoolConns, dbSem} =
|
||||
bracket
|
||||
(withMVar dbSem $ \_ -> atomically $ readTBQueue dbPoolConns)
|
||||
(atomically . writeTBQueue dbPoolConns)
|
||||
withConnectionPriority DBStore {dbConnection} _priority action =
|
||||
withMVar dbConnection action
|
||||
|
||||
withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
|
||||
withConnection st = withConnectionPriority st False
|
||||
{-# INLINE withConnection #-}
|
||||
|
||||
withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
|
||||
withConnection' = withConnection
|
||||
{-# INLINE withConnection' #-}
|
||||
|
||||
withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
|
||||
withTransaction' = withTransaction
|
||||
{-# INLINE withTransaction' #-}
|
||||
|
||||
withTransaction :: DBStore -> (PSQL.Connection -> IO a) -> IO a
|
||||
withTransaction st = withTransactionPriority st False
|
||||
|
||||
@@ -11,27 +11,18 @@ module Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
execute,
|
||||
execute_,
|
||||
executeMany,
|
||||
query,
|
||||
query_,
|
||||
blobFieldDecoder,
|
||||
fromTextField_,
|
||||
PSQL.query,
|
||||
PSQL.query_,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (void)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Int (Int32, Int64)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Database.PostgreSQL.Simple (ResultError (..), SqlError (..))
|
||||
import Database.PostgreSQL.Simple (ResultError (..))
|
||||
import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Database.PostgreSQL.Simple.FromField (Field (..), FieldParser, FromField (..), returnError)
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..), returnError)
|
||||
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
||||
import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid)
|
||||
|
||||
newtype BoolInt = BI {unBI :: Bool}
|
||||
|
||||
@@ -44,49 +35,17 @@ instance ToField BoolInt where
|
||||
{-# INLINE toField #-}
|
||||
|
||||
execute :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> q -> IO ()
|
||||
execute db q qs = withLoggedErrors q $ void $ PSQL.execute db q qs
|
||||
execute db q qs = void $ PSQL.execute db q qs
|
||||
{-# INLINE execute #-}
|
||||
|
||||
execute_ :: PSQL.Connection -> PSQL.Query -> IO ()
|
||||
execute_ db q = withLoggedErrors q $ void $ PSQL.execute_ db q
|
||||
execute_ db q = void $ PSQL.execute_ db q
|
||||
{-# INLINE execute_ #-}
|
||||
|
||||
executeMany :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> [q] -> IO ()
|
||||
executeMany db q qs = withLoggedErrors q $ void $ PSQL.executeMany db q qs
|
||||
executeMany db q qs = void $ PSQL.executeMany db q qs
|
||||
{-# INLINE executeMany #-}
|
||||
|
||||
query :: (PSQL.ToRow q, PSQL.FromRow r) => PSQL.Connection -> PSQL.Query -> q -> IO [r]
|
||||
query db q qs = withLoggedErrors q $ PSQL.query db q qs
|
||||
{-# INLINE query #-}
|
||||
|
||||
query_ :: PSQL.FromRow r => PSQL.Connection -> PSQL.Query -> IO [r]
|
||||
query_ db q = withLoggedErrors q $ PSQL.query_ db q
|
||||
{-# INLINE query_ #-}
|
||||
|
||||
withLoggedErrors :: Show q => q -> IO a -> IO a
|
||||
withLoggedErrors q action =
|
||||
action
|
||||
`E.catch` (\(e :: SqlError) -> logSqlErrorAndRethrow e)
|
||||
`E.catch`
|
||||
(\(e :: E.SomeException) ->
|
||||
case E.fromException e :: Maybe SqlError of
|
||||
Just sqlErr -> E.throwIO sqlErr -- rethrow SqlError without logging
|
||||
Nothing -> logGenericErrorAndRethrow e
|
||||
)
|
||||
where
|
||||
logSqlErrorAndRethrow :: SqlError -> IO a
|
||||
logSqlErrorAndRethrow e = do
|
||||
putStrLn "Caught SqlError"
|
||||
putStrLn $ "Message: " <> B.unpack (sqlErrorMsg e)
|
||||
putStrLn $ "SQL State: " <> B.unpack (sqlState e)
|
||||
putStrLn $ "Query: " <> show q
|
||||
E.throwIO e
|
||||
logGenericErrorAndRethrow :: E.SomeException -> IO a
|
||||
logGenericErrorAndRethrow e = do
|
||||
putStrLn $ "Caught generic exception: " <> show e
|
||||
putStrLn $ "Query: " <> show q
|
||||
E.throwIO e
|
||||
|
||||
-- orphan instances
|
||||
|
||||
-- used in FileSize
|
||||
@@ -104,20 +63,3 @@ instance FromField Word16 where
|
||||
if i >= 0 && i <= fromIntegral (maxBound :: Word16)
|
||||
then pure (fromIntegral i :: Word16)
|
||||
else returnError ConversionFailed field "Negative value can't be converted to Word16"
|
||||
|
||||
blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
blobFieldDecoder dec f val = do
|
||||
x <- fromField f val
|
||||
case dec x of
|
||||
Right k -> pure k
|
||||
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
|
||||
|
||||
fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a
|
||||
fromTextField_ fromText f val =
|
||||
if typeOid f `elem` [textOid, varcharOid]
|
||||
then case val of
|
||||
Just t -> case fromText $ decodeUtf8 t of
|
||||
Just x -> pure x
|
||||
_ -> returnError ConversionFailed f "invalid text value"
|
||||
Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field"
|
||||
else returnError Incompatible f "expecting TEXT or VARCHAR column type"
|
||||
|
||||
@@ -5,15 +5,16 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations
|
||||
( initialize,
|
||||
( app,
|
||||
initialize,
|
||||
run,
|
||||
getCurrentMigrations,
|
||||
getCurrent,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad (void)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
@@ -23,10 +24,21 @@ import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Database.PostgreSQL.Simple.Internal (Connection (..))
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
import Simplex.Messaging.Agent.Store.Shared
|
||||
import Simplex.Messaging.Util (($>>=))
|
||||
import UnliftIO.MVar
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
schemaMigrations =
|
||||
[ ("20241210_initial", m20241210_initial, Nothing)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
app :: [Migration]
|
||||
app = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up, down = down}
|
||||
|
||||
initialize :: DBStore -> IO ()
|
||||
initialize st = withTransaction' st $ \db ->
|
||||
void $
|
||||
@@ -41,8 +53,8 @@ initialize st = withTransaction' st $ \db ->
|
||||
)
|
||||
|]
|
||||
|
||||
run :: DBStore -> MigrationsToRun -> IO ()
|
||||
run st = \case
|
||||
run :: DBStore -> Bool -> MigrationsToRun -> IO ()
|
||||
run st _vacuum = \case
|
||||
MTRUp [] -> pure ()
|
||||
MTRUp ms -> mapM_ runUp ms
|
||||
MTRDown ms -> mapM_ runDown $ reverse ms
|
||||
@@ -58,11 +70,9 @@ run st = \case
|
||||
void $ PSQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
|
||||
execSQL db query =
|
||||
withMVar (connectionHandle db) $ \pqConn ->
|
||||
LibPQ.exec pqConn (TE.encodeUtf8 query) $>>= LibPQ.resultErrorMessage >>= \case
|
||||
Just e | not (B.null e) -> throwIO $ userError $ B.unpack e
|
||||
_ -> pure ()
|
||||
void $ LibPQ.exec pqConn (TE.encodeUtf8 query)
|
||||
|
||||
getCurrentMigrations :: PSQL.Connection -> IO [Migration]
|
||||
getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
|
||||
getCurrent :: PSQL.Connection -> IO [Migration]
|
||||
getCurrent db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
|
||||
where
|
||||
toMigration (name, down) = Migration {name, up = T.pack "", down}
|
||||
|
||||
@@ -1,25 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.App (appMigrations) where
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
schemaMigrations =
|
||||
[ ("20241210_initial", m20241210_initial, Nothing),
|
||||
("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
|
||||
("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
appMigrations :: [Migration]
|
||||
appMigrations = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up, down = down}
|
||||
@@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20250203_msg_bodies :: Text
|
||||
m20250203_msg_bodies =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BYTEA;
|
||||
ALTER TABLE snd_messages ADD COLUMN padded_msg_len BIGINT;
|
||||
|
||||
|
||||
CREATE TABLE snd_message_bodies (
|
||||
snd_message_body_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
agent_msg BYTEA NOT NULL DEFAULT ''::BYTEA
|
||||
);
|
||||
ALTER TABLE snd_messages ADD COLUMN snd_message_body_id BIGINT REFERENCES snd_message_bodies ON DELETE SET NULL;
|
||||
CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id);
|
||||
|]
|
||||
|
||||
|
||||
down_m20250203_msg_bodies :: Text
|
||||
down_m20250203_msg_bodies =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_snd_messages_snd_message_body_id;
|
||||
ALTER TABLE snd_messages DROP COLUMN snd_message_body_id;
|
||||
DROP TABLE snd_message_bodies;
|
||||
|
||||
|
||||
ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key;
|
||||
ALTER TABLE snd_messages DROP COLUMN padded_msg_len;
|
||||
|]
|
||||
@@ -1,63 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20250322_short_links :: Text
|
||||
m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BYTEA;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
ALTER TABLE rcv_queues ADD COLUMN queue_mode TEXT;
|
||||
UPDATE rcv_queues SET queue_mode = 'M' WHERE snd_secure = 1;
|
||||
ALTER TABLE rcv_queues DROP COLUMN snd_secure;
|
||||
|
||||
ALTER TABLE snd_queues ADD COLUMN queue_mode TEXT;
|
||||
UPDATE snd_queues SET queue_mode = 'M' WHERE snd_secure = 1;
|
||||
ALTER TABLE snd_queues DROP COLUMN snd_secure;
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BYTEA,
|
||||
link_id BYTEA NOT NULL,
|
||||
link_key BYTEA NOT NULL,
|
||||
snd_private_key BYTEA NOT NULL,
|
||||
snd_id BYTEA,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Text
|
||||
down_m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|
||||
ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
|
||||
UPDATE rcv_queues SET snd_secure = 1 WHERE queue_mode = 'M';
|
||||
ALTER TABLE rcv_queues DROP COLUMN queue_mode;
|
||||
|
||||
ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
|
||||
UPDATE snd_queues SET snd_secure = 1 WHERE queue_mode = 'M';
|
||||
ALTER TABLE snd_queues DROP COLUMN queue_mode;
|
||||
|]
|
||||
-37
@@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20250702_conn_invitations_remove_cascade_delete :: Text
|
||||
m20250702_conn_invitations_remove_cascade_delete =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
|
||||
|
||||
ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id DROP NOT NULL;
|
||||
|
||||
ALTER TABLE conn_invitations
|
||||
ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
|
||||
FOREIGN KEY (contact_conn_id)
|
||||
REFERENCES connections(conn_id)
|
||||
ON DELETE SET NULL;
|
||||
|]
|
||||
|
||||
down_m20250702_conn_invitations_remove_cascade_delete :: Text
|
||||
down_m20250702_conn_invitations_remove_cascade_delete =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey;
|
||||
|
||||
ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id SET NOT NULL;
|
||||
|
||||
ALTER TABLE conn_invitations
|
||||
ADD CONSTRAINT conn_invitations_contact_conn_id_fkey
|
||||
FOREIGN KEY (contact_conn_id)
|
||||
REFERENCES connections(conn_id)
|
||||
ON DELETE CASCADE;
|
||||
|]
|
||||
@@ -1,12 +0,0 @@
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Options where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Numeric.Natural
|
||||
|
||||
data DBOpts = DBOpts
|
||||
{ connstr :: ByteString,
|
||||
schema :: ByteString,
|
||||
poolSize :: Natural,
|
||||
createSchema :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
@@ -26,7 +26,6 @@
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite
|
||||
( DBOpts (..),
|
||||
Migrations.getCurrentMigrations,
|
||||
createDBStore,
|
||||
closeDBStore,
|
||||
reopenDBStore,
|
||||
@@ -53,13 +52,12 @@ import Database.SQLite.Simple (Query (..))
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import qualified Database.SQLite3 as SQLite3
|
||||
import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
||||
import Simplex.Messaging.Agent.Store.Migrations (migrateSchema)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Common
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
|
||||
import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
|
||||
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (takeDirectory)
|
||||
import UnliftIO.Exception (bracketOnError, onException)
|
||||
import UnliftIO.MVar
|
||||
@@ -67,23 +65,23 @@ import UnliftIO.STM
|
||||
|
||||
-- * SQLite Store implementation
|
||||
|
||||
data DBOpts = DBOpts
|
||||
{ dbFilePath :: FilePath,
|
||||
dbKey :: ScrubbedBytes,
|
||||
keepKey :: Bool,
|
||||
vacuum :: Bool,
|
||||
track :: DB.TrackQueries
|
||||
}
|
||||
|
||||
createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
|
||||
createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
|
||||
let dbDir = takeDirectory dbFilePath
|
||||
createDirectoryIfMissing True dbDir
|
||||
st <- connectSQLiteStore dbFilePath dbKey keepKey track
|
||||
r <- migrateSchema st `onException` closeDBStore st
|
||||
r <- migrateSchema st migrations confirmMigrations vacuum `onException` closeDBStore st
|
||||
case r of
|
||||
Right () -> pure $ Right st
|
||||
Left e -> closeDBStore st $> Left e
|
||||
where
|
||||
migrateSchema st =
|
||||
let initialize = Migrations.initialize st
|
||||
getCurrent = withTransaction st Migrations.getCurrentMigrations
|
||||
run = Migrations.run st vacuum
|
||||
backup = copyFile dbFilePath (dbFilePath <> ".bak")
|
||||
dbm = DBMigrate {initialize, getCurrent, run, backup}
|
||||
in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
|
||||
|
||||
connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore
|
||||
connectSQLiteStore dbFilePath key keepKey track = do
|
||||
|
||||
@@ -5,7 +5,6 @@
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Common
|
||||
( DBStore (..),
|
||||
DBOpts (..),
|
||||
withConnection,
|
||||
withConnection',
|
||||
withTransaction,
|
||||
@@ -40,14 +39,6 @@ data DBStore = DBStore
|
||||
dbNew :: Bool
|
||||
}
|
||||
|
||||
data DBOpts = DBOpts
|
||||
{ dbFilePath :: FilePath,
|
||||
dbKey :: ScrubbedBytes,
|
||||
keepKey :: Bool,
|
||||
vacuum :: Bool,
|
||||
track :: DB.TrackQueries
|
||||
}
|
||||
|
||||
withConnectionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a
|
||||
withConnectionPriority DBStore {dbSem, dbConnection} priority action
|
||||
| priority = E.bracket_ signal release $ withMVar dbConnection action
|
||||
|
||||
@@ -21,8 +21,6 @@ module Simplex.Messaging.Agent.Store.SQLite.DB
|
||||
executeMany,
|
||||
query,
|
||||
query_,
|
||||
blobFieldDecoder,
|
||||
fromTextField_,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -35,14 +33,10 @@ import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (diffUTCTime, getCurrentTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (FromRow, ResultError (..), Query, SQLData (..), ToRow)
|
||||
import Database.SQLite.Simple (FromRow, Query, ToRow)
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
@@ -135,20 +129,4 @@ query_ :: FromRow r => Connection -> Query -> IO [r]
|
||||
query_ c sql = timeIt c sql $ SQL.query_ (conn c) sql
|
||||
{-# INLINE query_ #-}
|
||||
|
||||
blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
blobFieldDecoder dec = \case
|
||||
f@(Field (SQLBlob b) _) ->
|
||||
case dec b of
|
||||
Right k -> Ok k
|
||||
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
|
||||
f -> returnError ConversionFailed f "expecting SQLBlob column type"
|
||||
|
||||
fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
|
||||
fromTextField_ fromText = \case
|
||||
f@(Field (SQLText t) _) ->
|
||||
case fromText t of
|
||||
Just x -> Ok x
|
||||
_ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
|
||||
f -> returnError ConversionFailed f "expecting SQLText column type"
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SlowQueryStats)
|
||||
|
||||
@@ -8,13 +8,15 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations
|
||||
( initialize,
|
||||
( app,
|
||||
initialize,
|
||||
run,
|
||||
getCurrentMigrations,
|
||||
getCurrent,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.List (sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
@@ -27,13 +29,96 @@ import qualified Database.SQLite3 as SQLite3
|
||||
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Common
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
import Simplex.Messaging.Agent.Store.Shared
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
|
||||
getCurrentMigrations :: DB.Connection -> IO [Migration]
|
||||
getCurrentMigrations DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;"
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
schemaMigrations =
|
||||
[ ("20220101_initial", m20220101_initial, Nothing),
|
||||
("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing),
|
||||
("20220322_notifications", m20220322_notifications, Nothing),
|
||||
("20220607_v2", m20220608_v2, Nothing),
|
||||
("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing),
|
||||
("m20220811_onion_hosts", m20220811_onion_hosts, Nothing),
|
||||
("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing),
|
||||
("m20220905_commands", m20220905_commands, Nothing),
|
||||
("m20220915_connection_queues", m20220915_connection_queues, Nothing),
|
||||
("m20230110_users", m20230110_users, Nothing),
|
||||
("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
|
||||
("m20230120_delete_errors", m20230120_delete_errors, Nothing),
|
||||
("m20230217_server_key_hash", m20230217_server_key_hash, Nothing),
|
||||
("m20230223_files", m20230223_files, Just down_m20230223_files),
|
||||
("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
|
||||
("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
|
||||
("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
|
||||
("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
|
||||
("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
|
||||
("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
|
||||
("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
|
||||
("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
|
||||
("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
|
||||
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
|
||||
("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
|
||||
("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
|
||||
("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
|
||||
("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
|
||||
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
|
||||
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
|
||||
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
|
||||
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
|
||||
("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
|
||||
("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
|
||||
("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
|
||||
("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
|
||||
("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
app :: [Migration]
|
||||
app = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
|
||||
|
||||
getCurrent :: DB.Connection -> IO [Migration]
|
||||
getCurrent DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;"
|
||||
where
|
||||
toMigration (name, down) = Migration {name, up = "", down}
|
||||
|
||||
|
||||
@@ -1,97 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.App (appMigrations) where
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Database.SQLite.Simple (Query (..))
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
schemaMigrations =
|
||||
[ ("20220101_initial", m20220101_initial, Nothing),
|
||||
("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing),
|
||||
("20220322_notifications", m20220322_notifications, Nothing),
|
||||
("20220607_v2", m20220608_v2, Nothing),
|
||||
("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing),
|
||||
("m20220811_onion_hosts", m20220811_onion_hosts, Nothing),
|
||||
("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing),
|
||||
("m20220905_commands", m20220905_commands, Nothing),
|
||||
("m20220915_connection_queues", m20220915_connection_queues, Nothing),
|
||||
("m20230110_users", m20230110_users, Nothing),
|
||||
("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
|
||||
("m20230120_delete_errors", m20230120_delete_errors, Nothing),
|
||||
("m20230217_server_key_hash", m20230217_server_key_hash, Nothing),
|
||||
("m20230223_files", m20230223_files, Just down_m20230223_files),
|
||||
("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
|
||||
("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
|
||||
("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
|
||||
("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
|
||||
("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
|
||||
("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
|
||||
("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
|
||||
("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
|
||||
("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
|
||||
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
|
||||
("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
|
||||
("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
|
||||
("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
|
||||
("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
|
||||
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
|
||||
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
|
||||
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
|
||||
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
|
||||
("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
|
||||
("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
|
||||
("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
|
||||
("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
|
||||
("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
|
||||
("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links),
|
||||
("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
appMigrations :: [Migration]
|
||||
appMigrations = sortOn name $ map migration schemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
|
||||
@@ -1,33 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20250203_msg_bodies :: Query
|
||||
m20250203_msg_bodies =
|
||||
[sql|
|
||||
ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BLOB;
|
||||
ALTER TABLE snd_messages ADD COLUMN padded_msg_len INTEGER;
|
||||
|
||||
|
||||
CREATE TABLE snd_message_bodies (
|
||||
snd_message_body_id INTEGER PRIMARY KEY,
|
||||
agent_msg BLOB NOT NULL DEFAULT x''
|
||||
);
|
||||
ALTER TABLE snd_messages ADD COLUMN snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL;
|
||||
CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id);
|
||||
|]
|
||||
|
||||
down_m20250203_msg_bodies :: Query
|
||||
down_m20250203_msg_bodies =
|
||||
[sql|
|
||||
DROP INDEX idx_snd_messages_snd_message_body_id;
|
||||
ALTER TABLE snd_messages DROP COLUMN snd_message_body_id;
|
||||
DROP TABLE snd_message_bodies;
|
||||
|
||||
|
||||
ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key;
|
||||
ALTER TABLE snd_messages DROP COLUMN padded_msg_len;
|
||||
|]
|
||||
@@ -1,60 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20250322_short_links :: Query
|
||||
m20250322_short_links =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BLOB;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
ALTER TABLE rcv_queues ADD COLUMN queue_mode TEXT;
|
||||
UPDATE rcv_queues SET queue_mode = 'M' WHERE snd_secure = 1;
|
||||
ALTER TABLE rcv_queues DROP COLUMN snd_secure;
|
||||
|
||||
ALTER TABLE snd_queues ADD COLUMN queue_mode TEXT;
|
||||
UPDATE snd_queues SET queue_mode = 'M' WHERE snd_secure = 1;
|
||||
ALTER TABLE snd_queues DROP COLUMN snd_secure;
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
snd_id BLOB,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Query
|
||||
down_m20250322_short_links =
|
||||
[sql|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|
||||
ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
|
||||
UPDATE rcv_queues SET snd_secure = 1 WHERE queue_mode = 'M';
|
||||
ALTER TABLE rcv_queues DROP COLUMN queue_mode;
|
||||
|
||||
ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
|
||||
UPDATE snd_queues SET snd_secure = 1 WHERE queue_mode = 'M';
|
||||
ALTER TABLE snd_queues DROP COLUMN queue_mode;
|
||||
|]
|
||||
@@ -1,40 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
-- TODO move date forward, create migration for postgres
|
||||
m20250517_service_certs :: Query
|
||||
m20250517_service_certs =
|
||||
[sql|
|
||||
CREATE TABLE server_certs(
|
||||
server_cert_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON UPDATE RESTRICT ON DELETE CASCADE,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
certificate BLOB NOT NULL,
|
||||
priv_key BLOB NOT NULL,
|
||||
service_id BLOB,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON UPDATE CASCADE ON DELETE RESTRICT,
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON server_certs(user_id, host, port);
|
||||
|
||||
CREATE INDEX idx_server_certs_host_port ON server_certs(host, port);
|
||||
|
||||
ALTER TABLE rcv_queues ADD COLUMN rcv_service_id BLOB;
|
||||
|]
|
||||
|
||||
down_m20250517_service_certs :: Query
|
||||
down_m20250517_service_certs =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues DROP COLUMN rcv_service_id;
|
||||
|
||||
DROP INDEX idx_server_certs_host_port;
|
||||
|
||||
DROP INDEX idx_server_certs_user_id_host_port;
|
||||
|
||||
DROP TABLE server_certs;
|
||||
|]
|
||||
-38
@@ -1,38 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20250702_conn_invitations_remove_cascade_delete :: Query
|
||||
m20250702_conn_invitations_remove_cascade_delete =
|
||||
[sql|
|
||||
PRAGMA writable_schema=1;
|
||||
|
||||
UPDATE sqlite_master
|
||||
SET sql = replace(
|
||||
sql,
|
||||
'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE',
|
||||
'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL'
|
||||
)
|
||||
WHERE name = 'conn_invitations' AND type = 'table';
|
||||
|
||||
PRAGMA writable_schema=0;
|
||||
|]
|
||||
|
||||
down_m20250702_conn_invitations_remove_cascade_delete :: Query
|
||||
down_m20250702_conn_invitations_remove_cascade_delete =
|
||||
[sql|
|
||||
PRAGMA writable_schema=1;
|
||||
|
||||
UPDATE sqlite_master
|
||||
SET sql = replace(
|
||||
sql,
|
||||
'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL',
|
||||
'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE'
|
||||
)
|
||||
WHERE name = 'conn_invitations' AND type = 'table';
|
||||
|
||||
PRAGMA writable_schema=0;
|
||||
|]
|
||||
@@ -55,12 +55,8 @@ CREATE TABLE rcv_queues(
|
||||
server_key_hash BLOB,
|
||||
switch_status TEXT,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
snd_secure INTEGER NOT NULL DEFAULT 0,
|
||||
last_broker_ts TEXT,
|
||||
link_id BLOB,
|
||||
link_key BLOB,
|
||||
link_priv_sig_key BLOB,
|
||||
link_enc_fixed_data BLOB,
|
||||
queue_mode TEXT,
|
||||
PRIMARY KEY(host, port, rcv_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE,
|
||||
@@ -83,7 +79,7 @@ CREATE TABLE snd_queues(
|
||||
replace_snd_queue_id INTEGER NULL,
|
||||
server_key_hash BLOB,
|
||||
switch_status TEXT,
|
||||
queue_mode TEXT,
|
||||
snd_secure INTEGER NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY(host, port, snd_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
@@ -131,9 +127,6 @@ CREATE TABLE snd_messages(
|
||||
retry_int_fast INTEGER,
|
||||
rcpt_internal_id INTEGER,
|
||||
rcpt_status TEXT,
|
||||
msg_encrypt_key BLOB,
|
||||
padded_msg_len INTEGER,
|
||||
snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL,
|
||||
PRIMARY KEY(conn_id, internal_snd_id),
|
||||
FOREIGN KEY(conn_id, internal_id) REFERENCES messages
|
||||
ON DELETE CASCADE
|
||||
@@ -154,7 +147,7 @@ CREATE TABLE conn_confirmations(
|
||||
) WITHOUT ROWID;
|
||||
CREATE TABLE conn_invitations(
|
||||
invitation_id BLOB NOT NULL PRIMARY KEY,
|
||||
contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL,
|
||||
contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
cr_invitation BLOB NOT NULL,
|
||||
recipient_conn_info BLOB NOT NULL,
|
||||
accepted INTEGER NOT NULL DEFAULT 0,
|
||||
@@ -422,21 +415,6 @@ CREATE TABLE ntf_tokens_to_delete(
|
||||
del_failed INTEGER DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE snd_message_bodies(
|
||||
snd_message_body_id INTEGER PRIMARY KEY,
|
||||
agent_msg BLOB NOT NULL DEFAULT x''
|
||||
);
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
snd_id BLOB,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
|
||||
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
|
||||
@@ -563,12 +541,3 @@ CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(
|
||||
internal_id
|
||||
);
|
||||
CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
|
||||
CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(
|
||||
snd_message_body_id
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(
|
||||
host,
|
||||
port,
|
||||
link_id
|
||||
);
|
||||
|
||||
+154
-346
@@ -8,7 +8,6 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@@ -47,17 +46,9 @@ module Simplex.Messaging.Client
|
||||
getSMPMessage,
|
||||
subscribeSMPQueueNotifications,
|
||||
subscribeSMPQueuesNtfs,
|
||||
subscribeService,
|
||||
smpClientService,
|
||||
secureSMPQueue,
|
||||
secureSndSMPQueue,
|
||||
proxySecureSndSMPQueue,
|
||||
addSMPQueueLink,
|
||||
deleteSMPQueueLink,
|
||||
secureGetSMPQueueLink,
|
||||
proxySecureGetSMPQueueLink,
|
||||
getSMPQueueLink,
|
||||
proxyGetSMPQueueLink,
|
||||
enableSMPQueueNotifications,
|
||||
disableSMPQueueNotifications,
|
||||
enableSMPQueuesNtfs,
|
||||
@@ -82,16 +73,11 @@ module Simplex.Messaging.Client
|
||||
unexpectedResponse,
|
||||
ProtocolClientConfig (..),
|
||||
NetworkConfig (..),
|
||||
NetworkTimeout (..),
|
||||
NetworkRequestMode (..),
|
||||
pattern NRMInteractive,
|
||||
TransportSessionMode (..),
|
||||
HostMode (..),
|
||||
SocksMode (..),
|
||||
SMPProxyMode (..),
|
||||
SMPProxyFallback (..),
|
||||
SMPWebPortServers (..),
|
||||
netTimeoutInt,
|
||||
defaultClientConfig,
|
||||
defaultSMPClientConfig,
|
||||
defaultNetworkConfig,
|
||||
@@ -99,7 +85,6 @@ module Simplex.Messaging.Client
|
||||
clientSocksCredentials,
|
||||
chooseTransportHost,
|
||||
temporaryClientError,
|
||||
smpClientServiceError,
|
||||
smpProxyError,
|
||||
textToHostMode,
|
||||
ServerTransmissionBatch,
|
||||
@@ -116,12 +101,11 @@ module Simplex.Messaging.Client
|
||||
TBQueueInfo (..),
|
||||
getTBQueueInfo,
|
||||
getProtocolClientQueuesInfo,
|
||||
nonBlockingWriteTBQueue,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent (ThreadId, forkFinally, forkIO, killThread, mkWeakThreadId)
|
||||
import Control.Concurrent (ThreadId, forkFinally, killThread, mkWeakThreadId)
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception
|
||||
@@ -138,7 +122,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, isSuffixOf)
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
@@ -147,7 +131,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import Network.Socket (ServiceName)
|
||||
import Network.Socks5 (SocksCredentials (..))
|
||||
import Numeric.Natural
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -159,9 +143,9 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
|
||||
import Simplex.Messaging.Transport.KeepAlive
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
|
||||
import Simplex.Messaging.Version
|
||||
import System.Mem.Weak (Weak, deRefWeak)
|
||||
import System.Timeout (timeout)
|
||||
@@ -180,15 +164,15 @@ data PClient v err msg = PClient
|
||||
{ connected :: TVar Bool,
|
||||
transportSession :: TransportSession msg,
|
||||
transportHost :: TransportHost,
|
||||
tcpConnectTimeout :: NetworkTimeout,
|
||||
tcpTimeout :: NetworkTimeout,
|
||||
tcpConnectTimeout :: Int,
|
||||
tcpTimeout :: Int,
|
||||
sendPings :: TVar Bool,
|
||||
lastReceived :: TVar UTCTime,
|
||||
timeoutErrorCount :: TVar Int,
|
||||
clientCorrId :: TVar ChaChaDRG,
|
||||
sentCommands :: TMap CorrId (Request err msg),
|
||||
sndQ :: TBQueue (Maybe (Request err msg), ByteString),
|
||||
rcvQ :: TBQueue (NonEmpty (Transmission (Either err msg))),
|
||||
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
|
||||
msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
|
||||
}
|
||||
|
||||
@@ -203,7 +187,6 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
timeoutErrorCount <- newTVarIO 0
|
||||
sndQ <- newTBQueueIO 100
|
||||
rcvQ <- newTBQueueIO 100
|
||||
let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig
|
||||
return
|
||||
ProtocolClient
|
||||
{ action = Nothing,
|
||||
@@ -216,8 +199,7 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
blockSize = smpBlockSize,
|
||||
implySessId = thVersion >= authCmdsSMPVersion,
|
||||
encryptBlock = Nothing,
|
||||
batch = True,
|
||||
serviceAuth = thVersion >= serviceCertsSMPVersion
|
||||
batch = True
|
||||
},
|
||||
sessionTs = ts,
|
||||
client_ =
|
||||
@@ -225,8 +207,8 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
{ connected,
|
||||
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
|
||||
transportHost = "localhost",
|
||||
tcpConnectTimeout,
|
||||
tcpTimeout,
|
||||
tcpConnectTimeout = 20_000_000,
|
||||
tcpTimeout = 15_000_000,
|
||||
sendPings,
|
||||
lastReceived,
|
||||
timeoutErrorCount,
|
||||
@@ -241,7 +223,7 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
|
||||
|
||||
-- | Type for client command data
|
||||
type ClientCommand msg = (EntityId, Maybe C.APrivateAuthKey, ProtoCommand msg)
|
||||
type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
|
||||
|
||||
-- | Type synonym for transmission from SPM servers.
|
||||
-- Batch response is presented as a single `ServerTransmissionBatch` tuple.
|
||||
@@ -302,11 +284,11 @@ data NetworkConfig = NetworkConfig
|
||||
-- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
|
||||
smpProxyFallback :: SMPProxyFallback,
|
||||
-- | use web port 443 for SMP protocol
|
||||
smpWebPortServers :: SMPWebPortServers,
|
||||
smpWebPort :: Bool,
|
||||
-- | timeout for the initial client TCP/TLS connection (microseconds)
|
||||
tcpConnectTimeout :: NetworkTimeout,
|
||||
tcpConnectTimeout :: Int,
|
||||
-- | timeout of protocol commands (microseconds)
|
||||
tcpTimeout :: NetworkTimeout,
|
||||
tcpTimeout :: Int,
|
||||
-- | additional timeout per kilobyte (1024 bytes) to be sent
|
||||
tcpTimeoutPerKb :: Int64,
|
||||
-- | break response timeouts into groups, so later responses get later deadlines
|
||||
@@ -321,28 +303,6 @@ data NetworkConfig = NetworkConfig
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data NetworkTimeout = NetworkTimeout {backgroundTimeout :: Int, interactiveTimeout :: Int}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data NetworkRequestMode
|
||||
= NRMBackground
|
||||
| NRMInteractive' {retryCount :: Int}
|
||||
|
||||
pattern NRMInteractive :: NetworkRequestMode
|
||||
pattern NRMInteractive = NRMInteractive' 0
|
||||
|
||||
netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
|
||||
netTimeoutInt NetworkTimeout {backgroundTimeout, interactiveTimeout} = \case
|
||||
NRMBackground -> backgroundTimeout
|
||||
NRMInteractive' n
|
||||
| n <= 0 -> interactiveTimeout
|
||||
| otherwise ->
|
||||
let (m, d)
|
||||
| n == 1 = (3, 2)
|
||||
| n == 2 = (9, 4)
|
||||
| otherwise = (27, 8)
|
||||
in (interactiveTimeout * m) `div` d
|
||||
|
||||
data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -360,12 +320,6 @@ data SMPProxyFallback
|
||||
| SPFProhibit -- prohibit direct connection to destination relay.
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SMPWebPortServers
|
||||
= SWPAll
|
||||
| SWPPreset
|
||||
| SWPOff
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding SMPProxyMode where
|
||||
strEncode = \case
|
||||
SPMAlways -> "always"
|
||||
@@ -392,18 +346,6 @@ instance StrEncoding SMPProxyFallback where
|
||||
"no" -> pure SPFProhibit
|
||||
_ -> fail "Invalid SMP proxy fallback mode"
|
||||
|
||||
instance StrEncoding SMPWebPortServers where
|
||||
strEncode = \case
|
||||
SWPAll -> "all"
|
||||
SWPPreset -> "preset"
|
||||
SWPOff -> "off"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"all" -> pure SWPAll
|
||||
"preset" -> pure SWPPreset
|
||||
"off" -> pure SWPOff
|
||||
_ -> fail "Invalid SMP wep port setting"
|
||||
|
||||
defaultNetworkConfig :: NetworkConfig
|
||||
defaultNetworkConfig =
|
||||
NetworkConfig
|
||||
@@ -414,9 +356,9 @@ defaultNetworkConfig =
|
||||
sessionMode = TSMSession,
|
||||
smpProxyMode = SPMNever,
|
||||
smpProxyFallback = SPFAllow,
|
||||
smpWebPortServers = SWPPreset,
|
||||
tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000},
|
||||
tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000},
|
||||
smpWebPort = False,
|
||||
tcpConnectTimeout = defaultTcpConnectTimeout,
|
||||
tcpTimeout = 15_000_000,
|
||||
tcpTimeoutPerKb = 5_000,
|
||||
rcvConcurrency = 8,
|
||||
tcpKeepAlive = Just defaultKeepAliveOpts,
|
||||
@@ -425,11 +367,10 @@ defaultNetworkConfig =
|
||||
logTLSErrors = False
|
||||
}
|
||||
|
||||
transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} nm host useSNI clientALPN =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout = tOut, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
|
||||
transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI}
|
||||
where
|
||||
tOut = netTimeoutInt tcpConnectTimeout nm
|
||||
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
|
||||
useSocksProxy SMAlways = socksProxy'
|
||||
useSocksProxy SMOnion = case host of
|
||||
@@ -457,11 +398,10 @@ data ProtocolClientConfig v = ProtocolClientConfig
|
||||
{ -- | size of TBQueue to use for server commands and responses
|
||||
qSize :: Natural,
|
||||
-- | default server port if port is not specified in ProtocolServer
|
||||
defaultTransport :: (ServiceName, ATransport 'TClient),
|
||||
defaultTransport :: (ServiceName, ATransport),
|
||||
-- | network configuration
|
||||
networkConfig :: NetworkConfig,
|
||||
clientALPN :: Maybe [ALPN],
|
||||
serviceCredentials :: Maybe ServiceCredentials,
|
||||
-- | client-server protocol version range
|
||||
serverVRange :: VersionRange v,
|
||||
-- | agree shared session secret (used in SMP proxy for additional encryption layer)
|
||||
@@ -480,7 +420,6 @@ defaultClientConfig clientALPN useSNI serverVRange =
|
||||
defaultTransport = ("443", transport @TLS),
|
||||
networkConfig = defaultNetworkConfig,
|
||||
clientALPN,
|
||||
serviceCredentials = Nothing,
|
||||
serverVRange,
|
||||
agreeSecret = False,
|
||||
proxyServer = False,
|
||||
@@ -490,7 +429,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
|
||||
|
||||
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
|
||||
defaultSMPClientConfig =
|
||||
(defaultClientConfig (Just alpnSupportedSMPHandshakes) False supportedClientSMPRelayVRange)
|
||||
(defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
|
||||
{ defaultTransport = (show defaultSMPPort, transport @TLS),
|
||||
agreeSecret = True
|
||||
}
|
||||
@@ -552,15 +491,15 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
|
||||
--
|
||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||
-- as 'SMPServerTransmission' includes server information.
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} msgQ proxySessTs disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
|
||||
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
|
||||
Left e -> pure $ Left e
|
||||
where
|
||||
NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
|
||||
NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
|
||||
mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
|
||||
mkProtocolClient transportHost ts = do
|
||||
connected <- newTVarIO False
|
||||
@@ -588,39 +527,31 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
|
||||
msgQ
|
||||
}
|
||||
|
||||
runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
runClient (port', ATransport t) useHost c = do
|
||||
cVar <- newEmptyTMVarIO
|
||||
let tcConfig = (transportClientConfig networkConfig nm useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
|
||||
let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
|
||||
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
|
||||
tId <-
|
||||
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
|
||||
`forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
|
||||
c_ <- netTimeoutInt tcpConnectTimeout nm `timeout` atomically (takeTMVar cVar)
|
||||
c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
|
||||
case c_ of
|
||||
Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'}
|
||||
Just (Left e) -> pure $ Left e
|
||||
Nothing -> killThread tId $> Left PCENetworkError
|
||||
|
||||
useTransport :: (ServiceName, ATransport 'TClient)
|
||||
useTransport :: (ServiceName, ATransport)
|
||||
useTransport = case port srv of
|
||||
"" -> case protocolTypeI @(ProtoType msg) of
|
||||
SPSMP | smpWebPort -> ("443", transport @TLS)
|
||||
_ -> defaultTransport cfg
|
||||
p -> (p, transport @TLS)
|
||||
where
|
||||
smpWebPort = case smpWebPortServers of
|
||||
SWPAll -> True
|
||||
SWPPreset -> case srv of
|
||||
ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
|
||||
_ -> False
|
||||
SWPOff -> False
|
||||
|
||||
client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
|
||||
client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
|
||||
client _ c cVar h = do
|
||||
ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
|
||||
serviceKeys_ <- mapM (\creds -> (creds,) <$> atomically (C.generateKeyPair g)) serviceCredentials
|
||||
runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer serviceKeys_) >>= \case
|
||||
runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case
|
||||
Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
|
||||
Right th@THandle {params} -> do
|
||||
sessionTs <- getCurrentTime
|
||||
@@ -644,7 +575,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
|
||||
|
||||
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
|
||||
receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
|
||||
tGetClient h >>= atomically . writeTBQueue rcvQ
|
||||
tGet h >>= atomically . writeTBQueue rcvQ
|
||||
getCurrentTime >>= atomically . writeTVar lastReceived
|
||||
atomically $ writeTVar timeoutErrorCount 0
|
||||
|
||||
@@ -660,7 +591,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
|
||||
if remaining > 1_000_000 -- delay pings only for significant time
|
||||
then loop remaining
|
||||
else do
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c NRMBackground Nothing NoEntity (protocolPing @v @err @msg)
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
|
||||
-- sendProtocolCommand/getResponse updates counter for each command
|
||||
cnt <- readTVarIO timeoutErrorCount
|
||||
-- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
|
||||
@@ -671,14 +602,14 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
|
||||
process :: ProtocolClient v err msg -> IO ()
|
||||
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c
|
||||
|
||||
processMsgs :: ProtocolClient v err msg -> NonEmpty (Transmission (Either err msg)) -> IO ()
|
||||
processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO ()
|
||||
processMsgs c ts = do
|
||||
ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts)
|
||||
forM_ msgQ $ \q ->
|
||||
mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts')
|
||||
|
||||
processMsg :: ProtocolClient v err msg -> Transmission (Either err msg) -> IO (Maybe (EntityId, ServerTransmission err msg))
|
||||
processMsg ProtocolClient {client_ = PClient {sentCommands}} (corrId, entId, respOrErr)
|
||||
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
|
||||
processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
|
||||
| B.null $ bs corrId = sendMsg $ STEvent clientResp
|
||||
| otherwise =
|
||||
TM.lookupIO corrId sentCommands >>= \case
|
||||
@@ -738,8 +669,6 @@ data ProtocolClientError err
|
||||
PCENetworkError
|
||||
| -- | No host compatible with network configuration
|
||||
PCEIncompatibleHost
|
||||
| -- | Service is unavailable for command that requires service connection
|
||||
PCEServiceUnavailable
|
||||
| -- | TCP transport handshake or some other transport error.
|
||||
-- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
|
||||
PCETransportError TransportError
|
||||
@@ -759,14 +688,6 @@ temporaryClientError = \case
|
||||
_ -> False
|
||||
{-# INLINE temporaryClientError #-}
|
||||
|
||||
smpClientServiceError :: SMPClientError -> Bool
|
||||
smpClientServiceError = \case
|
||||
PCEServiceUnavailable -> True
|
||||
PCETransportError (TEHandshake BAD_SERVICE) -> True -- TODO [certs] this error may be temporary, so we should possibly resubscribe.
|
||||
PCEProtocolError SERVICE -> True
|
||||
PCEProtocolError (PROXY (BROKER NO_SERVICE)) -> True -- for completeness, it cannot happen.
|
||||
_ -> False
|
||||
|
||||
-- converts error of client running on proxy to the error sent to client connected to proxy
|
||||
smpProxyError :: SMPClientError -> ErrorType
|
||||
smpProxyError = \case
|
||||
@@ -776,7 +697,6 @@ smpProxyError = \case
|
||||
PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
|
||||
PCENetworkError -> PROXY $ BROKER NETWORK
|
||||
PCEIncompatibleHost -> PROXY $ BROKER HOST
|
||||
PCEServiceUnavailable -> PROXY $ BROKER $ NO_SERVICE -- for completeness, it cannot happen.
|
||||
PCETransportError t -> PROXY $ BROKER $ TRANSPORT t
|
||||
PCECryptoError _ -> CRYPTO
|
||||
PCEIOError _ -> INTERNAL
|
||||
@@ -786,54 +706,48 @@ smpProxyError = \case
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
|
||||
createSMPQueue ::
|
||||
SMPClient ->
|
||||
NetworkRequestMode ->
|
||||
Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
|
||||
C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
|
||||
RcvPublicDhKey ->
|
||||
Maybe BasicAuth ->
|
||||
SubscriptionMode ->
|
||||
QueueReqData ->
|
||||
Maybe NewNtfCreds ->
|
||||
Bool ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
|
||||
sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
|
||||
createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
|
||||
sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Subscribe to the SMP queue.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
|
||||
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
subscribeSMPQueue c rpKey rId = do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
|
||||
sendSMPCommand c (Just rpKey) rId SUB >>= \case
|
||||
OK -> pure ()
|
||||
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Subscribe to multiple SMP queues batching commands if supported.
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
|
||||
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
subscribeSMPQueues c qs = do
|
||||
liftIO $ enablePings c
|
||||
sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c)
|
||||
sendProtocolCommands c cs >>= mapM (processSUBResponse c)
|
||||
where
|
||||
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
|
||||
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
|
||||
|
||||
-- This command is always sent in background request mode
|
||||
streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
|
||||
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c NRMBackground cs $ mapM process >=> cb
|
||||
streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO ()
|
||||
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
|
||||
where
|
||||
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
|
||||
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
|
||||
process r@(Response rId _) = (rId,) <$> processSUBResponse c r
|
||||
|
||||
processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
|
||||
processSUBResponse c (Response rId r) = pure r $>>= processSUBResponse_ c rId
|
||||
|
||||
processSUBResponse_ :: SMPClient -> RecipientId -> BrokerMsg -> IO (Either SMPClientError (Maybe ServiceId))
|
||||
processSUBResponse_ c rId = \case
|
||||
OK -> pure $ Right Nothing
|
||||
SOK serviceId_ -> pure $ Right serviceId_
|
||||
cmd@MSG {} -> writeSMPMessage c rId cmd $> Right Nothing
|
||||
r' -> pure . Left $ unexpectedResponse r'
|
||||
processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SMPClientError ())
|
||||
processSUBResponse c (Response rId r) = case r of
|
||||
Right OK -> pure $ Right ()
|
||||
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
|
||||
Right r' -> pure . Left $ unexpectedResponse r'
|
||||
Left e -> pure $ Left e
|
||||
|
||||
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
|
||||
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c)
|
||||
@@ -845,62 +759,28 @@ serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionI
|
||||
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
|
||||
--
|
||||
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
|
||||
-- This command is always sent in interactive request mode, as NSE has limited time
|
||||
getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
|
||||
getSMPMessage c rpKey rId =
|
||||
sendSMPCommand c NRMInteractive (Just rpKey) rId GET >>= \case
|
||||
sendSMPCommand c (Just rpKey) rId GET >>= \case
|
||||
OK -> pure Nothing
|
||||
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
|
||||
r -> throwE $ unexpectedResponse r
|
||||
{-# INLINE getSMPMessage #-}
|
||||
|
||||
-- | Subscribe to the SMP queue notifications.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
|
||||
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
|
||||
subscribeSMPQueueNotifications c npKey nId = do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_
|
||||
okSMPCommand NSUB c npKey nId
|
||||
{-# INLINE subscribeSMPQueueNotifications #-}
|
||||
|
||||
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
|
||||
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
subscribeSMPQueuesNtfs c qs = do
|
||||
liftIO $ enablePings c
|
||||
L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs
|
||||
where
|
||||
cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
|
||||
|
||||
nsubResponse :: Response ErrorType BrokerMsg -> Either SMPClientError (Maybe ServiceId)
|
||||
nsubResponse (Response _ r) = r >>= nsubResponse_
|
||||
{-# INLINE nsubResponse #-}
|
||||
|
||||
nsubResponse_ :: BrokerMsg -> Either SMPClientError (Maybe ServiceId)
|
||||
nsubResponse_ = \case
|
||||
OK -> Right Nothing
|
||||
SOK serviceId_ -> Right serviceId_
|
||||
r' -> Left $ unexpectedResponse r'
|
||||
{-# INLINE nsubResponse_ #-}
|
||||
|
||||
-- This command is always sent in background request mode
|
||||
subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
|
||||
subscribeService c party = case smpClientService c of
|
||||
Just THClientService {serviceId, serviceKey} -> do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
|
||||
SOKS n -> pure n
|
||||
r -> throwE $ unexpectedResponse r
|
||||
where
|
||||
subCmd :: Command p
|
||||
subCmd = case party of
|
||||
SRecipientService -> SUBS
|
||||
SNotifierService -> NSUBS
|
||||
Nothing -> throwE PCEServiceUnavailable
|
||||
|
||||
smpClientService :: SMPClient -> Maybe THClientService
|
||||
smpClientService = thAuth . thParams >=> clientService
|
||||
{-# INLINE smpClientService #-}
|
||||
okSMPCommands NSUB c qs
|
||||
{-# INLINE subscribeSMPQueuesNtfs #-}
|
||||
|
||||
enablePings :: SMPClient -> IO ()
|
||||
enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeTVar sendPings True
|
||||
@@ -909,73 +789,33 @@ enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeT
|
||||
-- | Secure the SMP queue by adding a sender public key.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
|
||||
secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKey rId
|
||||
secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
|
||||
{-# INLINE secureSMPQueue #-}
|
||||
|
||||
-- | Secure the SMP queue via sender queue ID.
|
||||
secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId
|
||||
secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
|
||||
{-# INLINE secureSndSMPQueue #-}
|
||||
|
||||
proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
{-# INLINE proxySecureSndSMPQueue #-}
|
||||
|
||||
-- | Add or update date for queue link
|
||||
addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
|
||||
addSMPQueueLink c nm rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c nm rpKey rId
|
||||
{-# INLINE addSMPQueueLink #-}
|
||||
|
||||
-- | Delete queue link
|
||||
deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueueLink = okSMPCommand LDEL
|
||||
{-# INLINE deleteSMPQueueLink #-}
|
||||
|
||||
-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
|
||||
secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
secureGetSMPQueueLink c nm spKey lnkId senderKey =
|
||||
sendSMPCommand c nm (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey =
|
||||
proxySMPCommand c nm proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Get contact address SMP queue link data.
|
||||
getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
getSMPQueueLink c nm lnkId =
|
||||
sendSMPCommand c nm Nothing lnkId LGET >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- LGET command - get short link data
|
||||
proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxyGetSMPQueueLink c nm proxiedRelay lnkId =
|
||||
proxySMPCommand c nm proxiedRelay Nothing lnkId LGET >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Enable notifications for the queue for push notifications server.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
|
||||
enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
|
||||
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
|
||||
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
|
||||
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Enable notifications for the multiple queues for push notifications server.
|
||||
-- This command is always sent in background request mode
|
||||
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
|
||||
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
|
||||
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
|
||||
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
|
||||
process (Response _ r) = case r of
|
||||
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
@@ -984,36 +824,33 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackgroun
|
||||
-- | Disable notifications for the queue for push notifications server.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
|
||||
-- This command is always sent in background request mode
|
||||
disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
disableSMPQueueNotifications c = okSMPCommand NDEL c NRMBackground
|
||||
disableSMPQueueNotifications = okSMPCommand NDEL
|
||||
{-# INLINE disableSMPQueueNotifications #-}
|
||||
|
||||
-- | Disable notifications for multiple queues for push notifications server.
|
||||
-- This command is always sent in background request mode
|
||||
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
disableSMPQueuesNtfs c = okSMPCommands NDEL c NRMBackground
|
||||
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
disableSMPQueuesNtfs = okSMPCommands NDEL
|
||||
{-# INLINE disableSMPQueuesNtfs #-}
|
||||
|
||||
-- | Send SMP message.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
|
||||
sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
|
||||
sendSMPMessage c nm spKey sId flags msg =
|
||||
sendSMPCommand c nm spKey sId (SEND flags msg) >>= \case
|
||||
sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
|
||||
sendSMPMessage c spKey sId flags msg =
|
||||
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
|
||||
OK -> pure ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg)
|
||||
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg)
|
||||
|
||||
-- | Acknowledge message delivery (server deletes the message).
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
|
||||
-- This command is always sent in background request mode
|
||||
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
|
||||
ackSMPMessage c rpKey rId msgId =
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
|
||||
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
|
||||
OK -> return ()
|
||||
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||
r -> throwE $ unexpectedResponse r
|
||||
@@ -1022,45 +859,46 @@ ackSMPMessage c rpKey rId msgId =
|
||||
-- The existing messages from the queue will still be delivered.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
|
||||
suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
suspendSMPQueue = okSMPCommand OFF
|
||||
{-# INLINE suspendSMPQueue #-}
|
||||
|
||||
-- | Irreversibly delete SMP queue and all messages in it.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
|
||||
deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueue = okSMPCommand DEL
|
||||
{-# INLINE deleteSMPQueue #-}
|
||||
|
||||
-- | Delete multiple SMP queues batching commands if supported.
|
||||
deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
deleteSMPQueues = okSMPCommands DEL
|
||||
{-# INLINE deleteSMPQueues #-}
|
||||
|
||||
-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
|
||||
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
|
||||
connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
| thVersion (thParams c) >= sendingProxySMPVersion =
|
||||
sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (CertChainPubKey chain key) ->
|
||||
sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (chain, key) ->
|
||||
case supportedClientSMPRelayVRange `compatibleVersion` vr of
|
||||
Nothing -> throwE $ transportErr TEVersion
|
||||
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key
|
||||
r -> throwE $ unexpectedResponse r
|
||||
| otherwise = throwE $ PCETransportError TEVersion
|
||||
where
|
||||
tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm
|
||||
tOut = Just $ tcpConnectTimeout + tcpTimeout
|
||||
transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
|
||||
validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
|
||||
validateRelay (X.CertificateChain cert) exact = do
|
||||
serverKey <- case cert of
|
||||
[leaf, ca]
|
||||
| XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 ->
|
||||
C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned leaf
|
||||
C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned leaf, []) >>= C.pubKey
|
||||
_ -> throwError "bad certificate"
|
||||
C.x509ToPublic' =<< C.verifyX509 serverKey exact
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
|
||||
data ProxiedRelay = ProxiedRelay
|
||||
{ prSessionId :: SessionId,
|
||||
@@ -1117,54 +955,44 @@ instance StrEncoding ProxyClientError where
|
||||
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
|
||||
|
||||
-- This function proxies Sender commands that return OK or ERR
|
||||
proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxyOKSMPCommand c nm proxiedRelay spKey sId command =
|
||||
proxySMPCommand c nm proxiedRelay spKey sId command >>= \case
|
||||
Right OK -> pure $ Right ()
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
proxySMPCommand ::
|
||||
forall p.
|
||||
PartyI p =>
|
||||
SMPClient ->
|
||||
NetworkRequestMode ->
|
||||
-- proxy session from PKEY
|
||||
ProxiedRelay ->
|
||||
-- message to deliver
|
||||
Maybe SndPrivateAuthKey ->
|
||||
SenderId ->
|
||||
Command p ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
Command 'Sender ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
-- prepare params
|
||||
let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
|
||||
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
|
||||
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
|
||||
(cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
|
||||
let cmdSecret = C.dh' serverKey cmdPrivKey
|
||||
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
|
||||
-- encode
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
|
||||
-- serviceAuth is False here – proxied commands are not used with service certificates
|
||||
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth False spKey nonce tForAuth
|
||||
b <- case batchTransmissions serverThParams [Right (auth, tToSend)] of
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
|
||||
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
|
||||
b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
|
||||
[] -> throwE $ PCETransportError TELargeMsg
|
||||
TBError e _ : _ -> throwE $ PCETransportError e
|
||||
TBTransmission s _ : _ -> pure s
|
||||
TBTransmissions s _ _ : _ -> pure s
|
||||
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
|
||||
-- proxy interaction errors are wrapped
|
||||
let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
|
||||
tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
let tOut = Just $ 2 * tcpTimeout
|
||||
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
Right r -> case r of
|
||||
PRES (EncResponse er) -> do
|
||||
-- server interaction errors are thrown directly
|
||||
t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
|
||||
case tParse serverThParams t' of
|
||||
t'' :| [] -> case tDecodeClient serverThParams t'' of
|
||||
(_, _, cmd) -> case cmd of
|
||||
t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
|
||||
(_auth, _signed, (_c, _e, cmd)) -> case cmd of
|
||||
Right OK -> pure $ Right ()
|
||||
Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
|
||||
Right r' -> pure $ Right r'
|
||||
Right r' -> throwE $ unexpectedResponse r'
|
||||
Left e -> throwE $ PCEResponseError e
|
||||
_ -> throwE $ PCETransportError TEBadBlock
|
||||
ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
|
||||
@@ -1179,7 +1007,6 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
-- sends RFWD :: EncFwdTransmission -> Command Sender
|
||||
-- receives RRES :: EncFwdResponse -> BrokerMsg
|
||||
-- proxy should send PRES to the client with EncResponse
|
||||
-- Always uses background timeout mode
|
||||
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
|
||||
forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
|
||||
-- prepare params
|
||||
@@ -1191,7 +1018,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
|
||||
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
|
||||
-- send
|
||||
sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
|
||||
sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case
|
||||
RRES (EncFwdResponse efr) -> do
|
||||
-- unwrap
|
||||
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
|
||||
@@ -1199,41 +1026,40 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
pure fwdResponse
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- get queue information - always sent interactively
|
||||
getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
|
||||
getSMPQueueInfo c nm pKey qId =
|
||||
sendSMPCommand c nm (Just pKey) qId QUE >>= \case
|
||||
getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
|
||||
getSMPQueueInfo c pKey qId =
|
||||
sendSMPCommand c (Just pKey) qId QUE >>= \case
|
||||
INFO info -> pure info
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
okSMPCommand cmd c nm pKey qId =
|
||||
sendSMPCommand c nm (Just pKey) qId cmd >>= \case
|
||||
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
okSMPCommand cmd c pKey qId =
|
||||
sendSMPCommand c (Just pKey) qId cmd >>= \case
|
||||
OK -> return ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs
|
||||
okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
aCmd = Cmd sParty cmd
|
||||
cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
|
||||
cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
|
||||
process (Response _ r) = case r of
|
||||
Right OK -> Right ()
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
Left e -> Left e
|
||||
|
||||
-- | Send SMP command
|
||||
sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> Command p -> ExceptT SMPClientError IO BrokerMsg
|
||||
sendSMPCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (Cmd sParty cmd)
|
||||
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
|
||||
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
|
||||
{-# INLINE sendSMPCommand #-}
|
||||
|
||||
type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
|
||||
|
||||
-- | Send multiple commands with batching and collect responses
|
||||
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
|
||||
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
|
||||
validate . concat =<< mapM (sendBatch c nm) bs
|
||||
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
|
||||
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
|
||||
validate . concat =<< mapM (sendBatch c) bs
|
||||
where
|
||||
validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
|
||||
validate rs
|
||||
@@ -1247,39 +1073,37 @@ sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
|
||||
where
|
||||
diff = L.length cs - length rs
|
||||
|
||||
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands c@ProtocolClient {thParams} nm cs cb = do
|
||||
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
|
||||
mapM_ (cb <=< sendBatch c nm) bs
|
||||
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
|
||||
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
|
||||
mapM_ (cb <=< sendBatch c) bs
|
||||
|
||||
sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
|
||||
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
|
||||
sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
|
||||
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
|
||||
case b of
|
||||
TBError e Request {entityId} -> do
|
||||
putStrLn "send error: large message"
|
||||
pure [Response entityId $ Left $ PCETransportError e]
|
||||
TBTransmissions s n rs
|
||||
| n > 0 -> do
|
||||
nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
|
||||
mapConcurrently (getResponse c nm Nothing) rs
|
||||
atomically $ writeTBQueue sndQ (Nothing, s) -- do not expire batched responses
|
||||
mapConcurrently (getResponse c Nothing) rs
|
||||
| otherwise -> pure []
|
||||
TBTransmission s r -> do
|
||||
nonBlockingWriteTBQueue sndQ (Nothing, s)
|
||||
(: []) <$> getResponse c nm Nothing r
|
||||
atomically $ writeTBQueue sndQ (Nothing, s)
|
||||
(: []) <$> getResponse c Nothing r
|
||||
|
||||
-- | Send Protocol command
|
||||
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing
|
||||
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
|
||||
|
||||
-- Currently there is coupling - batch commands do not expire, and individually sent commands do.
|
||||
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
|
||||
-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does.
|
||||
-- But a better solution is to process delayed delete responses.
|
||||
--
|
||||
-- Please note: if nonce is passed it is also used as a correlation ID
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd)
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
|
||||
where
|
||||
-- two separate "atomically" needed to avoid blocking
|
||||
sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
|
||||
@@ -1288,21 +1112,16 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
|
||||
Right t
|
||||
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
|
||||
| otherwise -> do
|
||||
nonBlockingWriteTBQueue sndQ (Just r, s)
|
||||
response <$> getResponse c nm tOut r
|
||||
atomically $ writeTBQueue sndQ (Just r, s)
|
||||
response <$> getResponse c tOut r
|
||||
where
|
||||
s
|
||||
| batch = tEncodeBatch1 serviceAuth t
|
||||
| otherwise = tEncode serviceAuth t
|
||||
| batch = tEncodeBatch1 t
|
||||
| otherwise = tEncode t
|
||||
|
||||
nonBlockingWriteTBQueue :: TBQueue a -> a -> IO ()
|
||||
nonBlockingWriteTBQueue q x = do
|
||||
sent <- atomically $ tryWriteTBQueue q x
|
||||
unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
|
||||
|
||||
getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do
|
||||
r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar)
|
||||
getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do
|
||||
r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar)
|
||||
response <- atomically $ do
|
||||
writeTVar pending False
|
||||
-- Try to read response again in case it arrived after timeout expired
|
||||
@@ -1313,14 +1132,14 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} n
|
||||
Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout
|
||||
pure Response {entityId, response}
|
||||
|
||||
mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
|
||||
mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
|
||||
mkTransmission c = mkTransmission_ c Nothing
|
||||
|
||||
mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
|
||||
mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (entityId, pKey_, command) = do
|
||||
mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, 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) pKey_ nonce tForAuth
|
||||
r <- mkRequest (CorrId corrId)
|
||||
pure ((,tToSend) <$> auth, r)
|
||||
where
|
||||
@@ -1339,25 +1158,18 @@ 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) -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TransmissionAuth)
|
||||
authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_
|
||||
where
|
||||
authenticate :: C.APrivateAuthKey -> Either TransportError TAuthorizations
|
||||
authenticate (C.APrivateAuthKey a pk) = (,serviceSig) <$> case a of
|
||||
authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
|
||||
authenticate (C.APrivateAuthKey a pk) = case a of
|
||||
C.SX25519 -> case thAuth of
|
||||
Just THAuthClient {peerServerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t'
|
||||
Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t
|
||||
Nothing -> Left TENoServerAuth
|
||||
C.SEd25519 -> sign pk
|
||||
C.SEd448 -> sign pk
|
||||
-- When command is signed by both entity key and service key,
|
||||
-- entity key must sign over both transmission and service certificate hash,
|
||||
-- to prevent any service substitution via MITM inside TLS.
|
||||
(t', serviceSig) = case clientService =<< thAuth of
|
||||
Just THClientService {serviceCertHash = XV.Fingerprint fp, serviceKey} | serviceAuth ->
|
||||
(fp <> t, Just $ C.sign' serviceKey t) -- service key only needs to sign transmission itself
|
||||
_ -> (t, Nothing)
|
||||
sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
|
||||
sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t')
|
||||
sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
|
||||
|
||||
data TBQueueInfo = TBQueueInfo
|
||||
{ qLength :: Int,
|
||||
@@ -1387,10 +1199,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''NetworkTimeout)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''NetworkConfig)
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)
|
||||
|
||||
@@ -1,8 +1,6 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -11,27 +9,7 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Client.Agent
|
||||
( SMPClientAgent (..),
|
||||
SMPClientAgentConfig (..),
|
||||
SMPClientAgentEvent (..),
|
||||
OwnServer,
|
||||
defaultSMPClientAgentConfig,
|
||||
newSMPClientAgent,
|
||||
getSMPServerClient'',
|
||||
getConnectedSMPServerClient,
|
||||
closeSMPClientAgent,
|
||||
lookupSMPServerClient,
|
||||
isOwnServer,
|
||||
subscribeServiceNtfs,
|
||||
subscribeQueuesNtfs,
|
||||
activeClientSession',
|
||||
removeActiveSub,
|
||||
removeActiveSubs,
|
||||
removePendingSub,
|
||||
removePendingSubs,
|
||||
)
|
||||
where
|
||||
module Simplex.Messaging.Client.Agent where
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.Async (Async, uninterruptibleCancel)
|
||||
@@ -42,43 +20,29 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Constraint (Dict (..))
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
|
||||
import Data.Tuple (swap)
|
||||
import Numeric.Natural
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
( BrokerMsg,
|
||||
ErrorType,
|
||||
NotifierId,
|
||||
NtfPrivateAuthKey,
|
||||
Party (..),
|
||||
PartyI,
|
||||
ProtocolServer (..),
|
||||
QueueId,
|
||||
SMPServer,
|
||||
SParty (..),
|
||||
ServiceParty,
|
||||
serviceParty,
|
||||
partyServiceRole
|
||||
)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
|
||||
import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Util (catchAll_, ifM, safeDecodeUtf8, toChunks, tshow, whenM, ($>>=), (<$$>))
|
||||
import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=), (<$$>))
|
||||
import System.Timeout (timeout)
|
||||
import UnliftIO (async)
|
||||
import qualified UnliftIO.Exception as E
|
||||
@@ -87,18 +51,17 @@ import UnliftIO.STM
|
||||
type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient))
|
||||
|
||||
data SMPClientAgentEvent
|
||||
= CAConnected SMPServer (Maybe ServiceId)
|
||||
| CADisconnected SMPServer (NonEmpty QueueId)
|
||||
| CASubscribed SMPServer (Maybe ServiceId) (NonEmpty QueueId)
|
||||
| CASubError SMPServer (NonEmpty (QueueId, SMPClientError))
|
||||
| CAServiceDisconnected SMPServer (ServiceId, Int64)
|
||||
| CAServiceSubscribed SMPServer (ServiceId, Int64) Int64
|
||||
| CAServiceSubError SMPServer (ServiceId, Int64) SMPClientError
|
||||
-- CAServiceUnavailable is used when service ID in pending subscription is different from the current service in connection.
|
||||
-- This will require resubscribing to all queues associated with this service ID individually, creating new associations.
|
||||
-- It may happen if, for example, SMP server deletes service information (e.g. via downgrade and upgrade)
|
||||
-- and assigns different service ID to the service certificate.
|
||||
| CAServiceUnavailable SMPServer (ServiceId, Int64)
|
||||
= CAConnected SMPServer
|
||||
| CADisconnected SMPServer (Set SMPSub)
|
||||
| CASubscribed SMPServer SMPSubParty (NonEmpty QueueId)
|
||||
| CASubError SMPServer SMPSubParty (NonEmpty (QueueId, SMPClientError))
|
||||
|
||||
data SMPSubParty = SPRecipient | SPNotifier
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type SMPSub = (SMPSubParty, QueueId)
|
||||
|
||||
-- type SMPServerSub = (SMPServer, SMPSub)
|
||||
|
||||
data SMPClientAgentConfig = SMPClientAgentConfig
|
||||
{ smpCfg :: ProtocolClientConfig SMPVersion,
|
||||
@@ -129,9 +92,8 @@ defaultSMPClientAgentConfig =
|
||||
where
|
||||
second = 1000000
|
||||
|
||||
data SMPClientAgent p = SMPClientAgent
|
||||
data SMPClientAgent = SMPClientAgent
|
||||
{ agentCfg :: SMPClientAgentConfig,
|
||||
agentParty :: SParty p,
|
||||
active :: TVar Bool,
|
||||
startedAt :: UTCTime,
|
||||
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
|
||||
@@ -139,39 +101,29 @@ data SMPClientAgent p = SMPClientAgent
|
||||
randomDrg :: TVar ChaChaDRG,
|
||||
smpClients :: TMap SMPServer SMPClientVar,
|
||||
smpSessions :: TMap SessionId (OwnServer, SMPClient),
|
||||
-- Only one service subscription can exist per server with this agent.
|
||||
-- With correctly functioning SMP server, queue and service subscriptions can't be
|
||||
-- active at the same time.
|
||||
activeServiceSubs :: TMap SMPServer (TVar (Maybe ((ServiceId, Int64), SessionId))),
|
||||
activeQueueSubs :: TMap SMPServer (TMap QueueId (SessionId, C.APrivateAuthKey)),
|
||||
-- Pending service subscriptions can co-exist with pending queue subscriptions
|
||||
-- on the same SMP server during subscriptions being transitioned from per-queue to service.
|
||||
pendingServiceSubs :: TMap SMPServer (TVar (Maybe (ServiceId, Int64))),
|
||||
pendingQueueSubs :: TMap SMPServer (TMap QueueId C.APrivateAuthKey),
|
||||
srvSubs :: TMap SMPServer (TMap SMPSub (SessionId, C.APrivateAuthKey)),
|
||||
pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
|
||||
smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
|
||||
workerSeq :: TVar Int
|
||||
}
|
||||
|
||||
type OwnServer = Bool
|
||||
|
||||
newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO (SMPClientAgent p)
|
||||
newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
|
||||
newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
|
||||
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
|
||||
active <- newTVarIO True
|
||||
startedAt <- getCurrentTime
|
||||
msgQ <- newTBQueueIO msgQSize
|
||||
agentQ <- newTBQueueIO agentQSize
|
||||
smpClients <- TM.emptyIO
|
||||
smpSessions <- TM.emptyIO
|
||||
activeServiceSubs <- TM.emptyIO
|
||||
activeQueueSubs <- TM.emptyIO
|
||||
pendingServiceSubs <- TM.emptyIO
|
||||
pendingQueueSubs <- TM.emptyIO
|
||||
srvSubs <- TM.emptyIO
|
||||
pendingSrvSubs <- TM.emptyIO
|
||||
smpSubWorkers <- TM.emptyIO
|
||||
workerSeq <- newTVarIO 0
|
||||
pure
|
||||
SMPClientAgent
|
||||
{ agentCfg,
|
||||
agentParty,
|
||||
active,
|
||||
startedAt,
|
||||
msgQ,
|
||||
@@ -179,20 +131,18 @@ newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize
|
||||
randomDrg,
|
||||
smpClients,
|
||||
smpSessions,
|
||||
activeServiceSubs,
|
||||
activeQueueSubs,
|
||||
pendingServiceSubs,
|
||||
pendingQueueSubs,
|
||||
srvSubs,
|
||||
pendingSrvSubs,
|
||||
smpSubWorkers,
|
||||
workerSeq
|
||||
}
|
||||
|
||||
-- | Get or create SMP client for SMPServer
|
||||
getSMPServerClient' :: SMPClientAgent p -> SMPServer -> ExceptT SMPClientError IO SMPClient
|
||||
getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
|
||||
getSMPServerClient' ca srv = snd <$> getSMPServerClient'' ca srv
|
||||
{-# INLINE getSMPServerClient' #-}
|
||||
|
||||
getSMPServerClient'' :: SMPClientAgent p -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
|
||||
getSMPServerClient'' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
|
||||
getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, workerSeq} srv = do
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getClientVar ts) >>= either (ExceptT . newSMPClient) waitForSMPClient
|
||||
@@ -203,7 +153,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
|
||||
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
|
||||
waitForSMPClient v = do
|
||||
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
|
||||
smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
|
||||
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
|
||||
case smpClient_ of
|
||||
Just (Right smpClient) -> pure smpClient
|
||||
Just (Left (e, ts_)) -> case ts_ of
|
||||
@@ -226,8 +176,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
|
||||
atomically $ do
|
||||
putTMVar (sessionVar v) (Right c)
|
||||
TM.insert (sessionId $ thParams smp) c smpSessions
|
||||
let serviceId_ = (\THClientService {serviceId} -> serviceId) <$> smpClientService smp
|
||||
notify ca $ CAConnected srv serviceId_
|
||||
notify ca $ CAConnected srv
|
||||
pure $ Right c
|
||||
Left e -> do
|
||||
let ei = persistErrorInterval agentCfg
|
||||
@@ -241,68 +190,49 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
|
||||
reconnectClient ca srv
|
||||
pure $ Left e
|
||||
|
||||
isOwnServer :: SMPClientAgent p -> SMPServer -> OwnServer
|
||||
isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer
|
||||
isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
|
||||
let srv = strEncode $ L.head host
|
||||
in any (\s -> s == srv || B.cons '.' s `B.isSuffixOf` srv) (ownServerDomains agentCfg)
|
||||
|
||||
-- | Run an SMP client for SMPClientVar
|
||||
connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
|
||||
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
|
||||
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
|
||||
getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
|
||||
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
|
||||
where
|
||||
clientDisconnected :: SMPClient -> IO ()
|
||||
clientDisconnected smp = do
|
||||
removeClientAndSubs smp >>= serverDown
|
||||
removeClientAndSubs smp >>= (`forM_` serverDown)
|
||||
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
|
||||
|
||||
removeClientAndSubs :: SMPClient -> IO (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey))
|
||||
removeClientAndSubs smp = do
|
||||
-- Looking up subscription vars outside of STM transaction to reduce re-evaluation.
|
||||
-- It is possible because these vars are never removed, they are only added.
|
||||
sVar_ <- TM.lookupIO srv $ activeServiceSubs ca
|
||||
qVar_ <- TM.lookupIO srv $ activeQueueSubs ca
|
||||
atomically $ do
|
||||
TM.delete sessId smpSessions
|
||||
removeSessVar v srv smpClients
|
||||
sSub <- pure sVar_ $>>= updateServiceSub
|
||||
qSubs <- pure qVar_ $>>= updateQueueSubs
|
||||
pure (sSub, qSubs)
|
||||
removeClientAndSubs :: SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey))
|
||||
removeClientAndSubs smp = atomically $ do
|
||||
TM.delete sessId smpSessions
|
||||
removeSessVar v srv smpClients
|
||||
TM.lookup srv (srvSubs ca) >>= mapM updateSubs
|
||||
where
|
||||
sessId = sessionId $ thParams smp
|
||||
updateServiceSub sVar = do -- (sub, sessId')
|
||||
-- We don't change active subscription in case session ID is different from disconnected client
|
||||
serviceSub_ <- stateTVar sVar $ \case
|
||||
Just (serviceSub, sessId') | sessId == sessId' -> (Just serviceSub, Nothing)
|
||||
s -> (Nothing, s)
|
||||
-- We don't reset pending subscription to Nothing here to avoid any race conditions
|
||||
-- with subsequent client sessions that might have set pending already.
|
||||
when (isJust serviceSub_) $ setPendingServiceSub ca srv serviceSub_
|
||||
pure serviceSub_
|
||||
updateQueueSubs qVar = do
|
||||
updateSubs sVar = do
|
||||
-- removing subscriptions that have matching sessionId to disconnected client
|
||||
-- and keep the other ones (they can be made by the new client)
|
||||
subs <- M.map snd <$> stateTVar qVar (M.partition ((sessId ==) . fst))
|
||||
if M.null subs
|
||||
then pure Nothing
|
||||
else Just subs <$ addSubs_ (pendingQueueSubs ca) srv subs
|
||||
pending <- M.map snd <$> stateTVar sVar (M.partition ((sessId ==) . fst))
|
||||
addSubs_ (pendingSrvSubs ca) srv pending
|
||||
pure pending
|
||||
|
||||
serverDown :: (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey)) -> IO ()
|
||||
serverDown (sSub, qSubs) = do
|
||||
mapM_ (notify ca . CAServiceDisconnected srv) sSub
|
||||
let qIds = L.nonEmpty . M.keys =<< qSubs
|
||||
mapM_ (notify ca . CADisconnected srv) qIds
|
||||
when (isJust sSub || isJust qIds) $ reconnectClient ca srv
|
||||
serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
|
||||
serverDown ss = unless (M.null ss) $ do
|
||||
notify ca . CADisconnected srv $ M.keysSet ss
|
||||
reconnectClient ca srv
|
||||
|
||||
-- | Spawn reconnect worker if needed
|
||||
reconnectClient :: SMPClientAgent p -> SMPServer -> IO ()
|
||||
reconnectClient :: SMPClientAgent -> SMPServer -> IO ()
|
||||
reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} srv = do
|
||||
ts <- getCurrentTime
|
||||
whenM (readTVarIO active) $ atomically (getWorkerVar ts) >>= mapM_ (either newSubWorker (\_ -> pure ()))
|
||||
where
|
||||
getWorkerVar ts =
|
||||
ifM
|
||||
(noPending <$> getPending TM.lookup readTVar)
|
||||
(noPending)
|
||||
(pure Nothing) -- prevent race with cleanup and adding pending queues in another call
|
||||
(Just <$> getSessVar workerSeq srv smpSubWorkers ts)
|
||||
newSubWorker :: SessionVar (Async ()) -> IO ()
|
||||
@@ -311,17 +241,13 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
|
||||
atomically $ putTMVar (sessionVar v) a
|
||||
runSubWorker =
|
||||
withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
|
||||
subs <- getPending TM.lookupIO readTVarIO
|
||||
unless (noPending subs) $ whenM (readTVarIO active) $ do
|
||||
void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
|
||||
pending <- liftIO getPending
|
||||
unless (null pending) $ whenM (readTVarIO active) $ do
|
||||
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending)
|
||||
loop
|
||||
ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
|
||||
noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs
|
||||
getPending :: Monad m => (forall a. SMPServer -> TMap SMPServer a -> m (Maybe a)) -> (forall a. TVar a -> m a) -> m (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey))
|
||||
getPending lkup rd = do
|
||||
sSub <- lkup srv (pendingServiceSubs ca) $>>= rd
|
||||
qSubs <- lkup srv (pendingQueueSubs ca) >>= mapM rd
|
||||
pure (sSub, qSubs)
|
||||
noPending = maybe (pure True) (fmap M.null . readTVar) =<< TM.lookup srv (pendingSrvSubs ca)
|
||||
getPending = maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (pendingSrvSubs ca)
|
||||
cleanup :: SessionVar (Async ()) -> STM ()
|
||||
cleanup v = do
|
||||
-- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
|
||||
@@ -329,28 +255,32 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
|
||||
whenM (isEmptyTMVar $ sessionVar v) retry
|
||||
removeSessVar v srv smpSubWorkers
|
||||
|
||||
reconnectSMPClient :: forall p. SMPClientAgent p -> SMPServer -> (Maybe (ServiceId, Int64), Maybe (Map QueueId C.APrivateAuthKey)) -> ExceptT SMPClientError IO ()
|
||||
reconnectSMPClient ca@SMPClientAgent {agentCfg, agentParty} srv (sSub_, qSubs_) =
|
||||
withSMP ca srv $ \smp -> liftIO $ case serviceParty agentParty of
|
||||
Just Dict -> resubscribe smp
|
||||
Nothing -> pure ()
|
||||
reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO ()
|
||||
reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs =
|
||||
withSMP ca srv $ \smp -> liftIO $ do
|
||||
currSubs <- maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (srvSubs ca)
|
||||
let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs
|
||||
subscribe_ smp SPNotifier nSubs
|
||||
subscribe_ smp SPRecipient rSubs
|
||||
where
|
||||
resubscribe :: (PartyI p, ServiceParty p) => SMPClient -> IO ()
|
||||
resubscribe smp = do
|
||||
mapM_ (smpSubscribeService ca smp srv) sSub_
|
||||
forM_ qSubs_ $ \qSubs -> do
|
||||
currSubs_ <- mapM readTVarIO =<< TM.lookupIO srv (activeQueueSubs ca)
|
||||
let qSubs' :: [(QueueId, C.APrivateAuthKey)] =
|
||||
maybe id (\currSubs -> filter ((`M.notMember` currSubs) . fst)) currSubs_ $ M.assocs qSubs
|
||||
mapM_ (smpSubscribeQueues @p ca smp srv) $ toChunks (agentSubsBatchSize agentCfg) qSubs'
|
||||
groupSub :: Map SMPSub (SessionId, C.APrivateAuthKey) -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
|
||||
groupSub currSubs (s@(party, qId), k) acc@(nSubs, rSubs)
|
||||
| M.member s currSubs = acc
|
||||
| otherwise = case party of
|
||||
SPNotifier -> (s' : nSubs, rSubs)
|
||||
SPRecipient -> (nSubs, s' : rSubs)
|
||||
where
|
||||
s' = (qId, k)
|
||||
subscribe_ :: SMPClient -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> IO ()
|
||||
subscribe_ smp party = mapM_ (smpSubscribeQueues party ca smp srv) . toChunks (agentSubsBatchSize agentCfg)
|
||||
|
||||
notify :: MonadIO m => SMPClientAgent p -> SMPClientAgentEvent -> m ()
|
||||
notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
|
||||
notify ca evt = atomically $ writeTBQueue (agentQ ca) evt
|
||||
{-# INLINE notify #-}
|
||||
|
||||
-- Returns already connected client for proxying messages or Nothing if client is absent, not connected yet or stores expired error.
|
||||
-- If Nothing is return proxy will spawn a new thread to wait or to create another client connection to destination relay.
|
||||
getConnectedSMPServerClient :: SMPClientAgent p -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
|
||||
getConnectedSMPServerClient :: SMPClientAgent -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
|
||||
getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
|
||||
atomically (TM.lookup srv smpClients $>>= \v -> (v,) <$$> tryReadTMVar (sessionVar v)) -- Nothing: client is absent or not connected yet
|
||||
$>>= \case
|
||||
@@ -363,10 +293,10 @@ getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
|
||||
(Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection
|
||||
(pure $ Just $ Left e) -- not expired, returning error
|
||||
|
||||
lookupSMPServerClient :: SMPClientAgent p -> SessionId -> IO (Maybe (OwnServer, SMPClient))
|
||||
lookupSMPServerClient :: SMPClientAgent -> SessionId -> IO (Maybe (OwnServer, SMPClient))
|
||||
lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookupIO sessId smpSessions
|
||||
|
||||
closeSMPClientAgent :: SMPClientAgent p -> IO ()
|
||||
closeSMPClientAgent :: SMPClientAgent -> IO ()
|
||||
closeSMPClientAgent c = do
|
||||
atomically $ writeTVar (active c) False
|
||||
closeSMPServerClients c
|
||||
@@ -375,7 +305,7 @@ closeSMPClientAgent c = do
|
||||
cancelReconnect :: SessionVar (Async ()) -> IO ()
|
||||
cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel
|
||||
|
||||
closeSMPServerClients :: SMPClientAgent p -> IO ()
|
||||
closeSMPServerClients :: SMPClientAgent -> IO ()
|
||||
closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient)
|
||||
where
|
||||
closeClient v =
|
||||
@@ -386,30 +316,30 @@ closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_
|
||||
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
|
||||
cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
|
||||
|
||||
withSMP :: SMPClientAgent p -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
|
||||
withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
|
||||
withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
|
||||
where
|
||||
logSMPError :: SMPClientError -> ExceptT SMPClientError IO a
|
||||
logSMPError e = do
|
||||
logInfo $ "SMP error (" <> safeDecodeUtf8 (strEncode $ host srv) <> "): " <> tshow e
|
||||
liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
|
||||
throwE e
|
||||
|
||||
subscribeQueuesNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
|
||||
subscribeQueuesNtfs = subscribeQueues_
|
||||
{-# INLINE subscribeQueuesNtfs #-}
|
||||
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO ()
|
||||
subscribeQueuesSMP = subscribeQueues_ SPRecipient
|
||||
|
||||
subscribeQueues_ :: ServiceParty p => SMPClientAgent p -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
|
||||
subscribeQueues_ ca srv subs = do
|
||||
atomically $ addPendingSubs ca srv $ L.toList subs
|
||||
subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
|
||||
subscribeQueuesNtfs = subscribeQueues_ SPNotifier
|
||||
|
||||
subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
|
||||
subscribeQueues_ party ca srv subs = do
|
||||
atomically $ addPendingSubs ca srv party $ L.toList subs
|
||||
runExceptT (getSMPServerClient' ca srv) >>= \case
|
||||
Right smp -> smpSubscribeQueues ca smp srv subs
|
||||
Right smp -> smpSubscribeQueues party ca smp srv subs
|
||||
Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
|
||||
|
||||
smpSubscribeQueues :: ServiceParty p => SMPClientAgent p -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
|
||||
smpSubscribeQueues ca smp srv subs = do
|
||||
rs <- case agentParty ca of
|
||||
SRecipientService -> subscribeSMPQueues smp subs
|
||||
SNotifierService -> subscribeSMPQueuesNtfs smp subs
|
||||
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
|
||||
smpSubscribeQueues party ca smp srv subs = do
|
||||
rs <- subscribe smp $ L.map swap subs
|
||||
rs' <-
|
||||
atomically $
|
||||
ifM
|
||||
@@ -417,164 +347,79 @@ smpSubscribeQueues ca smp srv subs = do
|
||||
(Just <$> processSubscriptions rs)
|
||||
(pure Nothing)
|
||||
case rs' of
|
||||
Just (tempErrs, finalErrs, (qOks, sQs), _) -> do
|
||||
notify_ (`CASubscribed` Nothing) $ map fst qOks
|
||||
when (isJust smpServiceId) $ notify_ (`CASubscribed` smpServiceId) sQs
|
||||
Just (tempErrs, finalErrs, oks, _) -> do
|
||||
notify_ CASubscribed $ map fst oks
|
||||
notify_ CASubError finalErrs
|
||||
when tempErrs $ reconnectClient ca srv
|
||||
Nothing -> reconnectClient ca srv
|
||||
where
|
||||
processSubscriptions :: NonEmpty (Either SMPClientError (Maybe ServiceId)) -> STM (Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId])
|
||||
processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
|
||||
processSubscriptions rs = do
|
||||
pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingQueueSubs ca)
|
||||
let acc@(_, _, (qOks, sQs), notPending) = foldr (groupSub pending) (False, [], ([], []), []) (L.zip subs rs)
|
||||
unless (null qOks) $ addActiveSubs ca srv qOks
|
||||
unless (null sQs) $ forM_ smpServiceId $ \serviceId ->
|
||||
updateActiveServiceSub ca srv ((serviceId, fromIntegral $ length sQs), sessId)
|
||||
unless (null notPending) $ removePendingSubs ca srv notPending
|
||||
pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
|
||||
let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs)
|
||||
unless (null oks) $ addSubscriptions ca srv party oks
|
||||
unless (null notPending) $ removePendingSubs ca srv party notPending
|
||||
pure acc
|
||||
sessId = sessionId $ thParams smp
|
||||
smpServiceId = (\THClientService {serviceId} -> serviceId) <$> smpClientService smp
|
||||
groupSub ::
|
||||
Map QueueId C.APrivateAuthKey ->
|
||||
((QueueId, C.APrivateAuthKey), Either SMPClientError (Maybe ServiceId)) ->
|
||||
(Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId]) ->
|
||||
(Bool, [(QueueId, SMPClientError)], ([(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]), [QueueId])
|
||||
groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks@(qOks, sQs), notPending) = case r of
|
||||
Right serviceId_
|
||||
| M.member qId pending ->
|
||||
let oks' = case (smpServiceId, serviceId_) of
|
||||
(Just sId, Just sId') | sId == sId' -> (qOks, qId : sQs)
|
||||
_ -> ((qId, (sessId, pk)) : qOks, sQs)
|
||||
in (tempErrs, finalErrs, oks', qId : notPending)
|
||||
groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
|
||||
groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
|
||||
Right ()
|
||||
| M.member (party, qId) pending -> (tempErrs, finalErrs, (qId, (sessId, pk)) : oks, qId : notPending)
|
||||
| otherwise -> acc
|
||||
Left e
|
||||
| temporaryClientError e -> (True, finalErrs, oks, notPending)
|
||||
| otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending)
|
||||
notify_ :: (SMPServer -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
|
||||
notify_ evt qs = mapM_ (notify ca . evt srv) $ L.nonEmpty qs
|
||||
subscribe = case party of
|
||||
SPRecipient -> subscribeSMPQueues
|
||||
SPNotifier -> subscribeSMPQueuesNtfs
|
||||
notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
|
||||
notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs
|
||||
|
||||
subscribeServiceNtfs :: SMPClientAgent 'NotifierService -> SMPServer -> (ServiceId, Int64) -> IO ()
|
||||
subscribeServiceNtfs = subscribeService_
|
||||
{-# INLINE subscribeServiceNtfs #-}
|
||||
|
||||
subscribeService_ :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPServer -> (ServiceId, Int64) -> IO ()
|
||||
subscribeService_ ca srv serviceSub = do
|
||||
atomically $ setPendingServiceSub ca srv $ Just serviceSub
|
||||
runExceptT (getSMPServerClient' ca srv) >>= \case
|
||||
Right smp -> smpSubscribeService ca smp srv serviceSub
|
||||
Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
|
||||
|
||||
smpSubscribeService :: (PartyI p, ServiceParty p) => SMPClientAgent p -> SMPClient -> SMPServer -> (ServiceId, Int64) -> IO ()
|
||||
smpSubscribeService ca smp srv serviceSub@(serviceId, _) = case smpClientService smp of
|
||||
Just service | serviceAvailable service -> subscribe
|
||||
_ -> notifyUnavailable
|
||||
where
|
||||
subscribe = do
|
||||
r <- runExceptT $ subscribeService smp $ agentParty ca
|
||||
ok <-
|
||||
atomically $
|
||||
ifM
|
||||
(activeClientSession ca smp srv)
|
||||
(True <$ processSubscription r)
|
||||
(pure False)
|
||||
if ok
|
||||
then case r of
|
||||
Right n -> notify ca $ CAServiceSubscribed srv serviceSub n
|
||||
Left e
|
||||
| smpClientServiceError e -> notifyUnavailable
|
||||
| temporaryClientError e -> reconnectClient ca srv
|
||||
| otherwise -> notify ca $ CAServiceSubError srv serviceSub e
|
||||
else reconnectClient ca srv
|
||||
processSubscription = mapM_ $ \n -> do
|
||||
setActiveServiceSub ca srv $ Just ((serviceId, n), sessId)
|
||||
setPendingServiceSub ca srv Nothing
|
||||
serviceAvailable THClientService {serviceRole, serviceId = serviceId'} =
|
||||
serviceId == serviceId' && partyServiceRole (agentParty ca) == serviceRole
|
||||
notifyUnavailable = do
|
||||
atomically $ setPendingServiceSub ca srv Nothing
|
||||
notify ca $ CAServiceUnavailable srv serviceSub -- this will resubscribe all queues directly
|
||||
sessId = sessionId $ thParams smp
|
||||
|
||||
activeClientSession' :: SMPClientAgent p -> SessionId -> SMPServer -> STM Bool
|
||||
activeClientSession' :: SMPClientAgent -> SessionId -> SMPServer -> STM Bool
|
||||
activeClientSession' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
|
||||
where
|
||||
sameSess = \case
|
||||
Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
|
||||
_ -> False
|
||||
|
||||
activeClientSession :: SMPClientAgent p -> SMPClient -> SMPServer -> STM Bool
|
||||
activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
|
||||
activeClientSession ca = activeClientSession' ca . sessionId . thParams
|
||||
|
||||
showServer :: SMPServer -> ByteString
|
||||
showServer ProtocolServer {host, port} =
|
||||
strEncode host <> B.pack (if null port then "" else ':' : port)
|
||||
|
||||
addActiveSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
|
||||
addActiveSubs = addSubsList_ . activeQueueSubs
|
||||
{-# INLINE addActiveSubs #-}
|
||||
addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
|
||||
addSubscriptions = addSubsList_ . srvSubs
|
||||
{-# INLINE addSubscriptions #-}
|
||||
|
||||
addPendingSubs :: SMPClientAgent p -> SMPServer -> [(QueueId, C.APrivateAuthKey)] -> STM ()
|
||||
addPendingSubs = addSubsList_ . pendingQueueSubs
|
||||
addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
|
||||
addPendingSubs = addSubsList_ . pendingSrvSubs
|
||||
{-# INLINE addPendingSubs #-}
|
||||
|
||||
addSubsList_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [(QueueId, s)] -> STM ()
|
||||
addSubsList_ subs srv ss = addSubs_ subs srv $ M.fromList ss
|
||||
-- where
|
||||
-- ss' = M.fromList $ map (first (party,)) ss
|
||||
addSubsList_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [(QueueId, s)] -> STM ()
|
||||
addSubsList_ subs srv party ss = addSubs_ subs srv ss'
|
||||
where
|
||||
ss' = M.fromList $ map (first (party,)) ss
|
||||
|
||||
addSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> Map QueueId s -> STM ()
|
||||
addSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> Map SMPSub s -> STM ()
|
||||
addSubs_ subs srv ss =
|
||||
TM.lookup srv subs >>= \case
|
||||
Just m -> TM.union ss m
|
||||
_ -> TM.insertM srv (newTVar ss) subs
|
||||
_ -> newTVar ss >>= \v -> TM.insert srv v subs
|
||||
|
||||
setActiveServiceSub :: SMPClientAgent p -> SMPServer -> Maybe ((ServiceId, Int64), SessionId) -> STM ()
|
||||
setActiveServiceSub = setServiceSub_ activeServiceSubs
|
||||
{-# INLINE setActiveServiceSub #-}
|
||||
removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
|
||||
removeSubscription = removeSub_ . srvSubs
|
||||
{-# INLINE removeSubscription #-}
|
||||
|
||||
setPendingServiceSub :: SMPClientAgent p -> SMPServer -> Maybe (ServiceId, Int64) -> STM ()
|
||||
setPendingServiceSub = setServiceSub_ pendingServiceSubs
|
||||
{-# INLINE setPendingServiceSub #-}
|
||||
|
||||
setServiceSub_ ::
|
||||
(SMPClientAgent p -> TMap SMPServer (TVar (Maybe sub))) ->
|
||||
SMPClientAgent p ->
|
||||
SMPServer ->
|
||||
Maybe sub ->
|
||||
STM ()
|
||||
setServiceSub_ subsSel ca srv sub =
|
||||
TM.lookup srv (subsSel ca) >>= \case
|
||||
Just v -> writeTVar v sub
|
||||
Nothing -> TM.insertM srv (newTVar sub) (subsSel ca)
|
||||
|
||||
updateActiveServiceSub :: SMPClientAgent p -> SMPServer -> ((ServiceId, Int64), SessionId) -> STM ()
|
||||
updateActiveServiceSub ca srv sub@((serviceId', n'), sessId') =
|
||||
TM.lookup srv (activeServiceSubs ca) >>= \case
|
||||
Just v -> modifyTVar' v $ \case
|
||||
Just ((serviceId, n), sessId) | serviceId == serviceId' && sessId == sessId' ->
|
||||
Just ((serviceId, n + n'), sessId)
|
||||
_ -> Just sub
|
||||
Nothing -> TM.insertM srv (newTVar $ Just sub) (activeServiceSubs ca)
|
||||
|
||||
removeActiveSub :: SMPClientAgent p -> SMPServer -> QueueId -> STM ()
|
||||
removeActiveSub = removeSub_ . activeQueueSubs
|
||||
{-# INLINE removeActiveSub #-}
|
||||
|
||||
removePendingSub :: SMPClientAgent p -> SMPServer -> QueueId -> STM ()
|
||||
removePendingSub = removeSub_ . pendingQueueSubs
|
||||
{-# INLINE removePendingSub #-}
|
||||
|
||||
removeSub_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> QueueId -> STM ()
|
||||
removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM ()
|
||||
removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
|
||||
|
||||
removeActiveSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
|
||||
removeActiveSubs = removeSubs_ . activeQueueSubs
|
||||
{-# INLINE removeActiveSubs #-}
|
||||
|
||||
removePendingSubs :: SMPClientAgent p -> SMPServer -> [QueueId] -> STM ()
|
||||
removePendingSubs = removeSubs_ . pendingQueueSubs
|
||||
removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
|
||||
removePendingSubs = removeSubs_ . pendingSrvSubs
|
||||
{-# INLINE removePendingSubs #-}
|
||||
|
||||
removeSubs_ :: TMap SMPServer (TMap QueueId s) -> SMPServer -> [QueueId] -> STM ()
|
||||
removeSubs_ subs srv qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` S.fromList qs))
|
||||
removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
|
||||
removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss))
|
||||
where
|
||||
ss = S.fromList $ map (party,) qs
|
||||
|
||||
+56
-146
@@ -64,7 +64,6 @@ module Simplex.Messaging.Crypto
|
||||
AAuthKeyPair,
|
||||
KeyPair,
|
||||
KeyPairX25519,
|
||||
KeyPairEd25519,
|
||||
ASignatureKeyPair,
|
||||
DhSecret (..),
|
||||
DhSecretX25519,
|
||||
@@ -79,9 +78,7 @@ module Simplex.Messaging.Crypto
|
||||
generateDhKeyPair,
|
||||
privateToX509,
|
||||
x509ToPublic,
|
||||
x509ToPublic',
|
||||
x509ToPrivate,
|
||||
x509ToPrivate',
|
||||
publicKey,
|
||||
signatureKeyPair,
|
||||
publicToX509,
|
||||
@@ -145,8 +142,6 @@ module Simplex.Messaging.Crypto
|
||||
cbDecryptNoPad,
|
||||
sbDecrypt_,
|
||||
sbEncrypt_,
|
||||
sbEncryptNoPad,
|
||||
sbDecryptNoPad,
|
||||
cbNonce,
|
||||
randomCbNonce,
|
||||
reverseNonce,
|
||||
@@ -165,7 +160,6 @@ module Simplex.Messaging.Crypto
|
||||
SbKeyNonce,
|
||||
sbcInit,
|
||||
sbcHkdf,
|
||||
hkdf,
|
||||
|
||||
-- * pseudo-random bytes
|
||||
randomBytes,
|
||||
@@ -173,15 +167,14 @@ module Simplex.Messaging.Crypto
|
||||
-- * digests
|
||||
sha256Hash,
|
||||
sha512Hash,
|
||||
sha3_256,
|
||||
sha3_384,
|
||||
|
||||
-- * Message padding / un-padding
|
||||
canPad,
|
||||
pad,
|
||||
unPad,
|
||||
|
||||
-- * X509 Certificates
|
||||
SignedCertificate,
|
||||
Certificate,
|
||||
signCertificate,
|
||||
signX509,
|
||||
verifyX509,
|
||||
@@ -213,7 +206,7 @@ import Crypto.Cipher.AES (AES256)
|
||||
import qualified Crypto.Cipher.Types as AES
|
||||
import qualified Crypto.Cipher.XSalsa as XSalsa
|
||||
import qualified Crypto.Error as CE
|
||||
import Crypto.Hash (Digest, SHA3_256, SHA3_384, SHA256 (..), SHA512 (..), hash, hashDigestSize)
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import qualified Crypto.MAC.Poly1305 as Poly1305
|
||||
import qualified Crypto.PubKey.Curve25519 as X25519
|
||||
@@ -241,14 +234,14 @@ import Data.String
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Proxy (Proxy), Typeable)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.X509 as X
|
||||
import Data.X509
|
||||
import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
|
||||
import Network.Transport.Internal (decodeWord16, encodeWord16)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder)
|
||||
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.Parsers (blobFieldDecoder, parseAll, parseString)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
-- | Cryptographic algorithms.
|
||||
@@ -681,8 +674,6 @@ type KeyPair a = KeyPairType (PrivateKey a)
|
||||
|
||||
type KeyPairX25519 = KeyPair X25519
|
||||
|
||||
type KeyPairEd25519 = KeyPair Ed25519
|
||||
|
||||
-- TODO narrow key pair types to have the same algorithm in both keys
|
||||
type AKeyPair = KeyPairType APrivateKey
|
||||
|
||||
@@ -794,19 +785,10 @@ class CryptoSignature s where
|
||||
|
||||
instance CryptoSignature (Signature s) => StrEncoding (Signature s) where
|
||||
strEncode = serializeSignature
|
||||
{-# INLINE strEncode #-}
|
||||
strDecode = decodeSignature
|
||||
{-# INLINE strDecode #-}
|
||||
|
||||
instance CryptoSignature (Signature s) => Encoding (Signature s) where
|
||||
smpEncode = smpEncode . signatureBytes
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = decodeSignature <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance CryptoSignature ASignature where
|
||||
signatureBytes (ASignature _ sig) = signatureBytes sig
|
||||
{-# INLINE signatureBytes #-}
|
||||
decodeSignature s
|
||||
| B.length s == Ed25519.signatureSize =
|
||||
ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s
|
||||
@@ -818,7 +800,6 @@ instance CryptoSignature ASignature where
|
||||
|
||||
instance CryptoSignature (Maybe ASignature) where
|
||||
signatureBytes = maybe "" signatureBytes
|
||||
{-# INLINE signatureBytes #-}
|
||||
decodeSignature s
|
||||
| B.null s = Right Nothing
|
||||
| otherwise = Just <$> decodeSignature s
|
||||
@@ -827,7 +808,6 @@ instance AlgorithmI a => CryptoSignature (Signature a) where
|
||||
signatureBytes = \case
|
||||
SignatureEd25519 s -> BA.convert s
|
||||
SignatureEd448 s -> BA.convert s
|
||||
{-# INLINE signatureBytes #-}
|
||||
decodeSignature s = do
|
||||
ASignature _ sig <- decodeSignature s
|
||||
checkAlgorithm sig
|
||||
@@ -838,31 +818,25 @@ instance SignatureSize (Signature a) where
|
||||
signatureSize = \case
|
||||
SignatureEd25519 _ -> Ed25519.signatureSize
|
||||
SignatureEd448 _ -> Ed448.signatureSize
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
instance SignatureSize ASignature where
|
||||
signatureSize (ASignature _ s) = signatureSize s
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
instance SignatureSize APrivateSignKey where
|
||||
signatureSize (APrivateSignKey _ k) = signatureSize k
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
instance SignatureSize APublicVerifyKey where
|
||||
signatureSize (APublicVerifyKey _ k) = signatureSize k
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where
|
||||
signatureSize = \case
|
||||
PrivateKeyEd25519 _ _ -> Ed25519.signatureSize
|
||||
PrivateKeyEd448 _ _ -> Ed448.signatureSize
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
instance SignatureAlgorithm a => SignatureSize (PublicKey a) where
|
||||
signatureSize = \case
|
||||
PublicKeyEd25519 _ -> Ed25519.signatureSize
|
||||
PublicKeyEd448 _ -> Ed448.signatureSize
|
||||
{-# INLINE signatureSize #-}
|
||||
|
||||
-- | Various cryptographic or related errors.
|
||||
data CryptoError
|
||||
@@ -912,7 +886,6 @@ x448_size = 448 `quot` 8
|
||||
validSignatureSize :: Int -> Bool
|
||||
validSignatureSize n =
|
||||
n == Ed25519.signatureSize || n == Ed448.signatureSize
|
||||
{-# INLINE validSignatureSize #-}
|
||||
|
||||
-- | AES key newtype.
|
||||
newtype Key = Key {unKey :: ByteString}
|
||||
@@ -987,22 +960,10 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
|
||||
-- | SHA256 digest.
|
||||
sha256Hash :: ByteString -> ByteString
|
||||
sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
|
||||
{-# INLINE sha256Hash #-}
|
||||
|
||||
-- | SHA512 digest.
|
||||
sha512Hash :: ByteString -> ByteString
|
||||
sha512Hash = BA.convert . (hash :: ByteString -> Digest SHA512)
|
||||
{-# INLINE sha512Hash #-}
|
||||
|
||||
-- | SHA3-256 digest.
|
||||
sha3_256 :: ByteString -> ByteString
|
||||
sha3_256 = BA.convert . (hash :: ByteString -> Digest SHA3_256)
|
||||
{-# INLINE sha3_256 #-}
|
||||
|
||||
-- | SHA3-384 digest.
|
||||
sha3_384 :: ByteString -> ByteString
|
||||
sha3_384 = BA.convert . (hash :: ByteString -> Digest SHA3_384)
|
||||
{-# INLINE sha3_384 #-}
|
||||
|
||||
-- | AEAD-GCM encryption with associated data.
|
||||
--
|
||||
@@ -1019,7 +980,6 @@ encryptAEAD aesKey ivBytes paddedLen ad msg = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAESNoPad key iv = encryptAEADNoPad key iv ""
|
||||
{-# INLINE encryptAESNoPad #-}
|
||||
|
||||
encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAEADNoPad aesKey ivBytes ad msg = do
|
||||
@@ -1041,7 +1001,6 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
decryptAESNoPad :: Key -> GCMIV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAESNoPad key iv = decryptAEADNoPad key iv ""
|
||||
{-# INLINE decryptAESNoPad #-}
|
||||
|
||||
decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
|
||||
@@ -1051,11 +1010,6 @@ decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
|
||||
maxMsgLen :: Int
|
||||
maxMsgLen = 2 ^ (16 :: Int) - 3
|
||||
|
||||
canPad :: Int -> Int -> Bool
|
||||
canPad msgLen paddedLen = msgLen <= maxMsgLen && padLen >= 0
|
||||
where
|
||||
padLen = paddedLen - msgLen - 2
|
||||
|
||||
pad :: ByteString -> Int -> Either CryptoError ByteString
|
||||
pad msg paddedLen
|
||||
| len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
|
||||
@@ -1094,7 +1048,6 @@ maxLenBS s
|
||||
|
||||
unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
|
||||
unsafeMaxLenBS = MLBS
|
||||
{-# INLINE unsafeMaxLenBS #-}
|
||||
|
||||
padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
|
||||
padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
|
||||
@@ -1107,7 +1060,6 @@ appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
|
||||
|
||||
maxLength :: forall i. KnownNat i => Int
|
||||
maxLength = fromIntegral (natVal $ Proxy @i)
|
||||
{-# INLINE maxLength #-}
|
||||
|
||||
-- this function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
|
||||
-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
|
||||
@@ -1128,15 +1080,12 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
|
||||
-- | Random AES256 key.
|
||||
randomAesKey :: TVar ChaChaDRG -> STM Key
|
||||
randomAesKey = fmap Key . randomBytes aesKeySize
|
||||
{-# INLINE randomAesKey #-}
|
||||
|
||||
randomGCMIV :: TVar ChaChaDRG -> STM GCMIV
|
||||
randomGCMIV = fmap GCMIV . randomBytes gcmIVSize
|
||||
{-# INLINE randomGCMIV #-}
|
||||
|
||||
ivSize :: forall c. AES.BlockCipher c => Int
|
||||
ivSize = AES.blockSize (undefined :: c)
|
||||
{-# INLINE ivSize #-}
|
||||
|
||||
gcmIVSize :: Int
|
||||
gcmIVSize = 12
|
||||
@@ -1146,7 +1095,6 @@ makeIV bs = maybeError CryptoIVError $ AES.makeIV bs
|
||||
|
||||
maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a
|
||||
maybeError e = maybe (throwE e) return
|
||||
{-# INLINE maybeError #-}
|
||||
|
||||
cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a
|
||||
cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
@@ -1157,18 +1105,15 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
|
||||
sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
|
||||
sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
|
||||
{-# INLINE sign' #-}
|
||||
|
||||
sign :: APrivateSignKey -> ByteString -> ASignature
|
||||
sign (APrivateSignKey a k) = ASignature a . sign' k
|
||||
{-# INLINE sign #-}
|
||||
|
||||
signCertificate :: APrivateSignKey -> X.Certificate -> X.SignedCertificate
|
||||
signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
|
||||
signCertificate = signX509
|
||||
{-# INLINE signCertificate #-}
|
||||
|
||||
signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> X.SignedExact o
|
||||
signX509 key = fst . X.objectToSignedExact f
|
||||
signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
|
||||
signX509 key = fst . objectToSignedExact f
|
||||
where
|
||||
f bytes =
|
||||
( signatureBytes $ sign key bytes,
|
||||
@@ -1177,74 +1122,69 @@ signX509 key = fst . X.objectToSignedExact f
|
||||
)
|
||||
{-# INLINE signX509 #-}
|
||||
|
||||
verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> X.SignedExact o -> Either String o
|
||||
verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o
|
||||
verifyX509 key exact = do
|
||||
signature <- case signedAlg of
|
||||
X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
|
||||
X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
|
||||
SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
|
||||
SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
|
||||
_ -> Left "unknown x509 signature algorithm"
|
||||
if verify key signature $ X.getSignedData exact then Right signedObject else Left "bad signature"
|
||||
if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature"
|
||||
where
|
||||
X.Signed {signedObject, signedAlg, signedSignature} = X.getSigned exact
|
||||
Signed {signedObject, signedAlg, signedSignature} = getSigned exact
|
||||
{-# INLINE verifyX509 #-}
|
||||
|
||||
certificateFingerprint :: X.SignedCertificate -> KeyHash
|
||||
certificateFingerprint :: SignedCertificate -> KeyHash
|
||||
certificateFingerprint = signedFingerprint
|
||||
{-# INLINE certificateFingerprint #-}
|
||||
|
||||
signedFingerprint :: (ASN1Object o, Eq o, Show o) => X.SignedExact o -> KeyHash
|
||||
signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
|
||||
signedFingerprint o = KeyHash fp
|
||||
where
|
||||
Fingerprint fp = getFingerprint o X.HashSHA256
|
||||
Fingerprint fp = getFingerprint o HashSHA256
|
||||
|
||||
class SignatureAlgorithmX509 a where
|
||||
signatureAlgorithmX509 :: a -> X.SignatureALG
|
||||
signatureAlgorithmX509 :: a -> SignatureALG
|
||||
|
||||
instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
|
||||
signatureAlgorithmX509 = \case
|
||||
SEd25519 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519
|
||||
SEd448 -> X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
|
||||
SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
|
||||
|
||||
instance SignatureAlgorithmX509 APrivateSignKey where
|
||||
signatureAlgorithmX509 (APrivateSignKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
instance SignatureAlgorithmX509 APublicVerifyKey where
|
||||
signatureAlgorithmX509 (APublicVerifyKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | An instance for 'ASignatureKeyPair' / ('PublicKeyType' pk, pk), without touching its type family.
|
||||
instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
|
||||
signatureAlgorithmX509 = signatureAlgorithmX509 . snd
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | A wrapper to marshall signed ASN1 objects, like certificates.
|
||||
newtype SignedObject a = SignedObject {getSignedExact :: X.SignedExact a}
|
||||
newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
|
||||
|
||||
instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
|
||||
#if defined(dbPostgres)
|
||||
fromField f dat = SignedObject <$> blobFieldDecoder X.decodeSignedObject f dat
|
||||
fromField f dat = SignedObject <$> blobFieldDecoder decodeSignedObject f dat
|
||||
#else
|
||||
fromField = fmap SignedObject . blobFieldDecoder X.decodeSignedObject
|
||||
fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
|
||||
#endif
|
||||
|
||||
instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
|
||||
toField (SignedObject s) = toField . Binary $ X.encodeSignedObject s
|
||||
toField (SignedObject s) = toField . Binary $ encodeSignedObject s
|
||||
|
||||
instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
|
||||
smpEncode (SignedObject exact) = smpEncode . Large $ X.encodeSignedObject exact
|
||||
smpP = fmap SignedObject . X.decodeSignedObject . unLarge <$?> smpP
|
||||
smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
|
||||
smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP
|
||||
|
||||
encodeCertChain :: X.CertificateChain -> L.NonEmpty Large
|
||||
encodeCertChain :: CertificateChain -> L.NonEmpty Large
|
||||
encodeCertChain cc = L.fromList $ map Large blobs
|
||||
where
|
||||
X.CertificateChainRaw blobs = X.encodeCertificateChain cc
|
||||
CertificateChainRaw blobs = encodeCertificateChain cc
|
||||
|
||||
certChainP :: A.Parser X.CertificateChain
|
||||
certChainP :: A.Parser CertificateChain
|
||||
certChainP = do
|
||||
rawChain <- X.CertificateChainRaw . map unLarge . L.toList <$> smpP
|
||||
either (fail . show) pure $ X.decodeCertificateChain rawChain
|
||||
rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP
|
||||
either (fail . show) pure $ decodeCertificateChain rawChain
|
||||
|
||||
-- | Signature verification.
|
||||
--
|
||||
@@ -1252,7 +1192,6 @@ certChainP = do
|
||||
verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool
|
||||
verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig
|
||||
verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig
|
||||
{-# INLINE verify' #-}
|
||||
|
||||
verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool
|
||||
verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of
|
||||
@@ -1262,35 +1201,25 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
|
||||
dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
|
||||
dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
|
||||
dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
|
||||
{-# INLINE dh' #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
|
||||
cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret
|
||||
{-# INLINE cbEncrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding).
|
||||
cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString
|
||||
cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce
|
||||
{-# INLINE cbEncryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt (SbKey key) = sbEncrypt_ key
|
||||
{-# INLINE sbEncrypt #-}
|
||||
|
||||
sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt_ secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
|
||||
{-# INLINE sbEncrypt_ #-}
|
||||
|
||||
sbEncryptNoPad :: SbKey -> CbNonce -> ByteString -> ByteString
|
||||
sbEncryptNoPad (SbKey key) (CbNonce nonce) = cryptoBox key nonce
|
||||
{-# INLINE sbEncryptNoPad #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
|
||||
cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
|
||||
cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
|
||||
{-# INLINE cbEncryptMaxLenBS #-}
|
||||
|
||||
cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
|
||||
cryptoBox secret nonce s = BA.convert tag <> c
|
||||
@@ -1301,26 +1230,18 @@ cryptoBox secret nonce s = BA.convert tag <> c
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
|
||||
cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
|
||||
{-# INLINE cbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret
|
||||
{-# INLINE cbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt (SbKey key) = sbDecrypt_ key
|
||||
{-# INLINE sbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
|
||||
sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce
|
||||
{-# INLINE sbDecrypt_ #-}
|
||||
|
||||
sbDecryptNoPad :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecryptNoPad (SbKey key) = sbDecryptNoPad_ key
|
||||
{-# INLINE sbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
@@ -1429,23 +1350,20 @@ newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
|
||||
sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
|
||||
sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
|
||||
where
|
||||
(ck1, ck2) = B.splitAt 32 $ hkdf salt secret "SimpleXSbChainInit" 64
|
||||
prk = H.extract salt secret :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
|
||||
(ck1, ck2) = B.splitAt 32 out
|
||||
|
||||
type SbKeyNonce = (SbKey, CbNonce)
|
||||
|
||||
sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
|
||||
sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
|
||||
where
|
||||
out = hkdf "" ck "SimpleXSbChain" 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
prk = H.extract B.empty ck :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
(ck', rest) = B.splitAt 32 out
|
||||
(sk, nonce) = B.splitAt 32 rest
|
||||
|
||||
hkdf :: ByteArrayAccess secret => ByteString -> secret -> ByteString -> Int -> ByteString
|
||||
hkdf salt ikm info n =
|
||||
let prk = H.extract salt ikm :: H.PRK SHA512
|
||||
in H.expand prk info n
|
||||
{-# INLINE hkdf #-}
|
||||
|
||||
xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
|
||||
xSalsa20 secret nonce msg = (rs, msg')
|
||||
where
|
||||
@@ -1456,19 +1374,19 @@ xSalsa20 secret nonce msg = (rs, msg')
|
||||
(rs, state2) = XSalsa.generate state1 32
|
||||
(msg', _) = XSalsa.combine state2 msg
|
||||
|
||||
publicToX509 :: PublicKey a -> X.PubKey
|
||||
publicToX509 :: PublicKey a -> PubKey
|
||||
publicToX509 = \case
|
||||
PublicKeyEd25519 k -> X.PubKeyEd25519 k
|
||||
PublicKeyEd448 k -> X.PubKeyEd448 k
|
||||
PublicKeyX25519 k -> X.PubKeyX25519 k
|
||||
PublicKeyX448 k -> X.PubKeyX448 k
|
||||
PublicKeyEd25519 k -> PubKeyEd25519 k
|
||||
PublicKeyEd448 k -> PubKeyEd448 k
|
||||
PublicKeyX25519 k -> PubKeyX25519 k
|
||||
PublicKeyX448 k -> PubKeyX448 k
|
||||
|
||||
privateToX509 :: PrivateKey a -> X.PrivKey
|
||||
privateToX509 :: PrivateKey a -> PrivKey
|
||||
privateToX509 = \case
|
||||
PrivateKeyEd25519 k _ -> X.PrivKeyEd25519 k
|
||||
PrivateKeyEd448 k _ -> X.PrivKeyEd448 k
|
||||
PrivateKeyX25519 k _ -> X.PrivKeyX25519 k
|
||||
PrivateKeyX448 k _ -> X.PrivKeyX448 k
|
||||
PrivateKeyEd25519 k _ -> PrivKeyEd25519 k
|
||||
PrivateKeyEd448 k _ -> PrivKeyEd448 k
|
||||
PrivateKeyX25519 k _ -> PrivKeyX25519 k
|
||||
PrivateKeyX448 k _ -> PrivKeyX448 k
|
||||
|
||||
encodeASNObj :: ASN1Object a => a -> ByteString
|
||||
encodeASNObj k = toStrict . encodeASN1 DER $ toASN1 k []
|
||||
@@ -1481,30 +1399,22 @@ decodePubKey = decodeKey >=> x509ToPublic >=> pubKey
|
||||
decodePrivKey :: CryptoPrivateKey k => ByteString -> Either String k
|
||||
decodePrivKey = decodeKey >=> x509ToPrivate >=> privKey
|
||||
|
||||
x509ToPublic :: (X.PubKey, [ASN1]) -> Either String APublicKey
|
||||
x509ToPublic :: (PubKey, [ASN1]) -> Either String APublicKey
|
||||
x509ToPublic = \case
|
||||
(X.PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k
|
||||
(X.PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k
|
||||
(X.PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k
|
||||
(X.PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k
|
||||
(PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k
|
||||
(PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k
|
||||
(PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k
|
||||
(PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k
|
||||
r -> keyError r
|
||||
|
||||
x509ToPublic' :: CryptoPublicKey k => X.PubKey -> Either String k
|
||||
x509ToPublic' k = x509ToPublic (k, []) >>= pubKey
|
||||
{-# INLINE x509ToPublic' #-}
|
||||
|
||||
x509ToPrivate :: (X.PrivKey, [ASN1]) -> Either String APrivateKey
|
||||
x509ToPrivate :: (PrivKey, [ASN1]) -> Either String APrivateKey
|
||||
x509ToPrivate = \case
|
||||
(X.PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k
|
||||
(X.PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k
|
||||
(X.PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 . PrivateKeyX25519 k $ X25519.toPublic k
|
||||
(X.PrivKeyX448 k, []) -> Right . APrivateKey SX448 . PrivateKeyX448 k $ X448.toPublic k
|
||||
(PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k
|
||||
(PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k
|
||||
(PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 . PrivateKeyX25519 k $ X25519.toPublic k
|
||||
(PrivKeyX448 k, []) -> Right . APrivateKey SX448 . PrivateKeyX448 k $ X448.toPublic k
|
||||
r -> keyError r
|
||||
|
||||
x509ToPrivate' :: CryptoPrivateKey k => X.PrivKey -> Either String k
|
||||
x509ToPrivate' pk = x509ToPrivate (pk, []) >>= privKey
|
||||
{-# INLINE x509ToPrivate' #-}
|
||||
|
||||
decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1])
|
||||
decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict
|
||||
|
||||
|
||||
@@ -21,8 +21,6 @@
|
||||
module Simplex.Messaging.Crypto.Ratchet
|
||||
( Ratchet (..),
|
||||
RatchetX448,
|
||||
MsgEncryptKey (..),
|
||||
MsgEncryptKeyX448,
|
||||
SkippedMsgDiff (..),
|
||||
SkippedMsgKeys,
|
||||
InitialKeys (..),
|
||||
@@ -55,10 +53,8 @@ module Simplex.Messaging.Crypto.Ratchet
|
||||
supportedE2EEncryptVRange,
|
||||
generateRcvE2EParams,
|
||||
generateSndE2EParams,
|
||||
mkRcvE2ERatchetParams,
|
||||
initialPQEncryption,
|
||||
connPQEncryption,
|
||||
joinContactInitialKeys,
|
||||
replyKEM_,
|
||||
pqSupportToEnc,
|
||||
pqEncToSupport,
|
||||
@@ -68,9 +64,7 @@ module Simplex.Messaging.Crypto.Ratchet
|
||||
pqX3dhRcv,
|
||||
initSndRatchet,
|
||||
initRcvRatchet,
|
||||
rcCheckCanPad,
|
||||
rcEncryptHeader,
|
||||
rcEncryptMsg,
|
||||
rcEncrypt,
|
||||
rcDecrypt,
|
||||
-- used in tests
|
||||
MsgHeader (..),
|
||||
@@ -91,11 +85,12 @@ module Simplex.Messaging.Crypto.Ratchet
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Cipher.AES (AES256)
|
||||
import Crypto.Hash (SHA512)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
@@ -116,12 +111,12 @@ import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Simplex.Messaging.Agent.QueryString
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..))
|
||||
import Simplex.Messaging.Crypto
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, parseE, parseE')
|
||||
import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE')
|
||||
import Simplex.Messaging.Util (($>>=), (<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
@@ -197,8 +192,6 @@ data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RK
|
||||
|
||||
deriving instance Show ARKEMParams
|
||||
|
||||
type RcvRKEMParams = RKEMParams 'RKSProposed
|
||||
|
||||
instance RatchetKEMStateI s => Encoding (RKEMParams s) where
|
||||
smpEncode = \case
|
||||
RKParamsProposed k -> smpEncode ('P', k)
|
||||
@@ -310,13 +303,11 @@ instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri
|
||||
| otherwise = case kem of
|
||||
RKParamsProposed k -> [("kem_key", strEncode k)]
|
||||
RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)]
|
||||
strP = toE2ERatchetParamsUri <$?> strP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
toE2ERatchetParamsUri :: RatchetKEMStateI s => AE2ERatchetParamsUri a -> Either String (E2ERatchetParamsUri s a)
|
||||
toE2ERatchetParamsUri = \case
|
||||
AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing
|
||||
AE2ERatchetParamsUri _ ps -> checkRatchetKEMState ps
|
||||
strP = toParamsURI <$?> strP
|
||||
where
|
||||
toParamsURI = \case
|
||||
AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing
|
||||
AE2ERatchetParamsUri _ ps -> checkRatchetKEMState ps
|
||||
|
||||
instance AlgorithmI a => StrEncoding (AE2ERatchetParamsUri a) where
|
||||
strEncode (AE2ERatchetParamsUri _ ps) = strEncode ps
|
||||
@@ -346,33 +337,6 @@ instance StrEncoding AnyE2ERatchetParamsUri where
|
||||
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
|
||||
Just ct -> ARKP SRKSAccepted $ RKParamsAccepted ct k
|
||||
|
||||
instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParamsUri s a) where
|
||||
smpEncode (E2ERatchetParamsUri vr k1 k2 kem_) = smpEncode (vr, k1, k2, kem_)
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = toE2ERatchetParamsUri <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance AlgorithmI a => Encoding (AE2ERatchetParamsUri a) where
|
||||
smpEncode (AE2ERatchetParamsUri _ ps) = smpEncode ps
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = (\(AnyE2ERatchetParamsUri s _ ps) -> AE2ERatchetParamsUri s <$> checkAlgorithm ps) <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance Encoding AnyE2ERatchetParamsUri where
|
||||
smpEncode (AnyE2ERatchetParamsUri _ _ ps) = smpEncode ps
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = do
|
||||
vr <- smpP @VersionRangeE2E
|
||||
APublicDhKey a k1 <- smpP
|
||||
APublicDhKey a' k2 <- smpP
|
||||
case testEquality a a' of
|
||||
Nothing -> fail "bad e2e params: different key algorithms"
|
||||
Just Refl ->
|
||||
let result = \case
|
||||
Just (ARKP s kem) -> AnyE2ERatchetParamsUri s a $ E2ERatchetParamsUri vr k1 k2 (Just kem)
|
||||
Nothing -> AnyE2ERatchetParamsUri SRKSProposed a $ E2ERatchetParamsUri vr k1 k2 Nothing
|
||||
in result <$> smpP
|
||||
|
||||
type RcvE2ERatchetParams a = E2ERatchetParams 'RKSProposed a
|
||||
|
||||
type SndE2ERatchetParams a = AE2ERatchetParams a
|
||||
@@ -409,12 +373,6 @@ data UseKEM (s :: RatchetKEMState) where
|
||||
|
||||
data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
|
||||
|
||||
mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
|
||||
mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem)
|
||||
where
|
||||
mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
|
||||
mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k
|
||||
|
||||
generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
|
||||
generateE2EParams g v useKEM_ = do
|
||||
(k1, pk1) <- atomically $ generateKeyPair g
|
||||
@@ -606,7 +564,6 @@ applySMDiff smks = \case
|
||||
type HeaderKey = Key
|
||||
|
||||
data MessageKey = MessageKey Key IV
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding MessageKey where
|
||||
smpEncode (MessageKey (Key key) (IV iv)) = smpEncode (key, iv)
|
||||
@@ -861,47 +818,36 @@ instance StrEncoding PQSupport where
|
||||
strP = pqEncToSupport <$> strP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
data InitialKeys
|
||||
= IKUsePQ -- use PQ keys in contact request and short link data
|
||||
| IKLinkPQ PQSupport -- use PQ keys in short link data only, if PQSupport enabled
|
||||
data InitialKeys = IKUsePQ | IKNoPQ PQSupport
|
||||
deriving (Eq, Show)
|
||||
|
||||
pattern IKPQOn :: InitialKeys
|
||||
pattern IKPQOn = IKLinkPQ PQSupportOn
|
||||
pattern IKPQOn = IKNoPQ PQSupportOn
|
||||
|
||||
pattern IKPQOff :: InitialKeys
|
||||
pattern IKPQOff = IKLinkPQ PQSupportOff
|
||||
pattern IKPQOff = IKNoPQ PQSupportOff
|
||||
|
||||
instance StrEncoding InitialKeys where
|
||||
strEncode = \case
|
||||
IKUsePQ -> "pq=invitation"
|
||||
IKLinkPQ pq -> strEncode pq
|
||||
strP = IKLinkPQ <$> strP <|> "pq=invitation" $> IKUsePQ
|
||||
IKNoPQ pq -> strEncode pq
|
||||
strP = IKNoPQ <$> strP <|> "pq=invitation" $> IKUsePQ
|
||||
|
||||
-- determines whether PQ key should be included in invitation link
|
||||
initialPQEncryption :: Bool -> InitialKeys -> PQSupport
|
||||
initialPQEncryption shortLink = \case
|
||||
initialPQEncryption :: InitialKeys -> PQSupport
|
||||
initialPQEncryption = \case
|
||||
IKUsePQ -> PQSupportOn
|
||||
IKLinkPQ (PQSupport enable) -> PQSupport $ enable && shortLink
|
||||
IKNoPQ _ -> PQSupportOff -- default
|
||||
|
||||
-- determines whether PQ encryption should be used in connection
|
||||
connPQEncryption :: InitialKeys -> PQSupport
|
||||
connPQEncryption = \case
|
||||
IKUsePQ -> PQSupportOn
|
||||
IKLinkPQ pq -> pq -- default for creating connection is IKLinkPQ PQEncOn
|
||||
IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn
|
||||
|
||||
joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
|
||||
joinContactInitialKeys pqCompatible = \case
|
||||
PQSupportOn | pqCompatible -> IKUsePQ
|
||||
pqEnc -> IKLinkPQ pqEnc
|
||||
|
||||
rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
|
||||
rcCheckCanPad paddedMsgLen msg =
|
||||
unless (canPad (B.length msg) paddedMsgLen) $ throwE CryptoLargeMsgError
|
||||
|
||||
rcEncryptHeader :: AlgorithmI a => Ratchet a -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
|
||||
rcEncryptHeader Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState
|
||||
rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} pqEnc_ supportedE2EVersion = do
|
||||
rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (ByteString, Ratchet a)
|
||||
rcEncrypt Ratchet {rcSnd = Nothing} _ _ _ _ = throwE CERatchetState
|
||||
rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} paddedMsgLen msg pqEnc_ supportedE2EVersion = do
|
||||
-- state.CKs, mk = KDF_CK(state.CKs)
|
||||
let (ck', mk, iv, ehIV) = chainKdf rcCKs
|
||||
v = current rcVersion
|
||||
@@ -916,15 +862,11 @@ rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, r
|
||||
rcVersion' = rcVersion {maxSupported = maxSupported'}
|
||||
-- enc_header = HENCRYPT(state.HKs, header)
|
||||
(ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen v rcSupportKEM') rcAD (msgHeader v maxSupported')
|
||||
-- return enc_header
|
||||
-- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
|
||||
let emHeader = smpEncode EncMessageHeader {ehVersion = v, ehBody, ehAuthTag, ehIV}
|
||||
msgEncryptKey =
|
||||
MsgEncryptKey
|
||||
{ msgRcVersion = v,
|
||||
msgKey = MessageKey mk iv,
|
||||
msgRcAD = rcAD,
|
||||
msgEncHeader = emHeader
|
||||
}
|
||||
(emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg
|
||||
let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag}
|
||||
-- state.Ns += 1
|
||||
rc' =
|
||||
rc
|
||||
{ rcSnd = Just sr {rcCKs = ck'},
|
||||
@@ -934,7 +876,7 @@ rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, r
|
||||
rcVersion = rcVersion',
|
||||
rcKEM = if pqEnc_ == Just PQEncOff then (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM else rcKEM
|
||||
}
|
||||
pure (msgEncryptKey, rc')
|
||||
pure (msg', rc')
|
||||
where
|
||||
-- header = HEADER_PQ2(
|
||||
-- dh = state.DHRs.public,
|
||||
@@ -957,23 +899,6 @@ rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, r
|
||||
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
|
||||
Just RatchetKEMAccepted {rcPQRct} -> ARKP SRKSAccepted $ RKParamsAccepted rcPQRct k
|
||||
|
||||
type MsgEncryptKeyX448 = MsgEncryptKey 'X448
|
||||
|
||||
data MsgEncryptKey a = MsgEncryptKey
|
||||
{ msgRcVersion :: VersionE2E,
|
||||
msgKey :: MessageKey,
|
||||
msgRcAD :: ByteString,
|
||||
msgEncHeader :: ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
rcEncryptMsg :: AlgorithmI a => MsgEncryptKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString
|
||||
rcEncryptMsg MsgEncryptKey {msgKey = MessageKey mk iv, msgRcAD, msgEncHeader, msgRcVersion = v} paddedMsgLen msg = do
|
||||
-- return ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
|
||||
(emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (msgRcAD <> msgEncHeader) msg
|
||||
let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader = msgEncHeader, emBody, emAuthTag}
|
||||
pure msg'
|
||||
|
||||
data SkippedMessage a
|
||||
= SMMessage (DecryptResult a)
|
||||
| SMHeader (Maybe RatchetStep) (MsgHeader a)
|
||||
@@ -1174,7 +1099,8 @@ chainKdf (RatchetKey ck) =
|
||||
hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
|
||||
hkdf3 salt ikm info = (s1, s2, s3)
|
||||
where
|
||||
out = hkdf salt ikm info 96
|
||||
prk = H.extract salt ikm :: H.PRK SHA512
|
||||
out = H.expand prk info 96
|
||||
(s1, rest) = B.splitAt 32 out
|
||||
(s2, s3) = B.splitAt 32 rest
|
||||
|
||||
@@ -1204,7 +1130,7 @@ instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = b
|
||||
|
||||
instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField (BI pqEnc)
|
||||
|
||||
instance FromField PQEncryption where
|
||||
instance FromField PQEncryption where
|
||||
#if defined(dbPostgres)
|
||||
fromField f dat = PQEncryption . unBI <$> fromField f dat
|
||||
#else
|
||||
@@ -1219,14 +1145,3 @@ instance FromField PQSupport where
|
||||
#else
|
||||
fromField f = PQSupport . unBI <$> fromField f
|
||||
#endif
|
||||
|
||||
instance Encoding (MsgEncryptKey a) where
|
||||
smpEncode MsgEncryptKey {msgRcVersion = v, msgKey, msgRcAD, msgEncHeader} =
|
||||
smpEncode (v, msgRcAD, msgKey, Large msgEncHeader)
|
||||
smpP = do
|
||||
(v, msgRcAD, msgKey, Large msgEncHeader) <- smpP
|
||||
pure MsgEncryptKey {msgRcVersion = v, msgRcAD, msgKey, msgEncHeader}
|
||||
|
||||
instance AlgorithmI a => ToField (MsgEncryptKey a) where toField = toField . Binary . smpEncode
|
||||
|
||||
instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField = blobFieldDecoder smpDecode
|
||||
|
||||
@@ -10,10 +10,11 @@ import Data.Bifunctor (bimap)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import Foreign (nullPtr)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (rngFuncPtr, withDRG)
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
|
||||
@@ -42,7 +43,7 @@ sntrup761Keypair drg =
|
||||
c_SNTRUP761_SECRETKEY_SIZE
|
||||
( \skPtr ->
|
||||
BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr ->
|
||||
withDRG drg $ \cxtPtr -> c_sntrup761_keypair pkPtr skPtr cxtPtr rngFuncPtr
|
||||
withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr
|
||||
)
|
||||
|
||||
sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
|
||||
@@ -53,7 +54,7 @@ sntrup761Enc drg (KEMPublicKey pk) =
|
||||
c_SNTRUP761_SIZE
|
||||
( \kPtr ->
|
||||
BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr ->
|
||||
withDRG drg $ \cxtPtr -> c_sntrup761_enc cPtr kPtr pkPtr cxtPtr rngFuncPtr
|
||||
withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr
|
||||
)
|
||||
|
||||
sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
|
||||
( withDRG,
|
||||
rngFuncPtr,
|
||||
RNGContext,
|
||||
RNGFunc,
|
||||
) where
|
||||
@@ -13,20 +12,19 @@ import Foreign
|
||||
import Foreign.C
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
|
||||
withDRG :: TVar ChaChaDRG -> (Ptr RNGContext -> IO a) -> IO a
|
||||
withDRG drg = bracket (castStablePtrToPtr <$> newStablePtr drg) (freeStablePtr . castPtrToStablePtr)
|
||||
withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a
|
||||
withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr
|
||||
|
||||
rngFunc :: RNGFunc
|
||||
rngFunc cxt sz buf = do
|
||||
drg <- deRefStablePtr $ castPtrToStablePtr cxt
|
||||
bs <- atomically $ C.randomBytes (fromIntegral sz) drg
|
||||
copyByteArrayToPtr bs buf
|
||||
createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc)
|
||||
createRNGFunc drg =
|
||||
mkRNGFunc $ \_ctx sz buf -> do
|
||||
bs <- atomically $ C.randomBytes (fromIntegral sz) drg
|
||||
copyByteArrayToPtr bs buf
|
||||
|
||||
type RNGContext = ()
|
||||
|
||||
-- typedef void random_func (void *ctx, size_t length, uint8_t *dst);
|
||||
type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO ()
|
||||
|
||||
foreign export ccall "haskell_rng_func" rngFunc :: RNGFunc
|
||||
|
||||
foreign import ccall "&haskell_rng_func" rngFuncPtr :: FunPtr RNGFunc
|
||||
foreign import ccall "wrapper"
|
||||
mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc)
|
||||
|
||||
@@ -1,102 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.ShortLink
|
||||
( contactShortLinkKdf,
|
||||
invShortLinkKdf,
|
||||
encodeSignLinkData,
|
||||
encodeSignUserData,
|
||||
encryptLinkData,
|
||||
encryptUserData,
|
||||
decryptLinkData,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Simplex.Messaging.Agent.Client (cryptoError)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Protocol (EntityId (..), LinkId, EncDataBytes (..), QueueLinkData)
|
||||
import Simplex.Messaging.Util (liftEitherWith)
|
||||
|
||||
fixedDataPaddedLength :: Int
|
||||
fixedDataPaddedLength = 2008 -- 2048 - 24 (nonce) - 16 (auth tag)
|
||||
|
||||
userDataPaddedLength :: Int
|
||||
userDataPaddedLength = 13784 -- 13824 - 24 - 16
|
||||
|
||||
contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey)
|
||||
contactShortLinkKdf (LinkKey k) =
|
||||
let (lnkId, sbKey) = B.splitAt 24 $ C.hkdf "" k "SimpleXContactLink" 56
|
||||
in (EntityId lnkId, C.unsafeSbKey sbKey)
|
||||
|
||||
invShortLinkKdf :: LinkKey -> C.SbKey
|
||||
invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
|
||||
|
||||
encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> UserLinkData -> (LinkKey, (ByteString, ByteString))
|
||||
encodeSignLinkData (rootKey, pk) agentVRange connReq userData =
|
||||
let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq}
|
||||
md = smpEncode $ connLinkData @c agentVRange userData
|
||||
in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md))
|
||||
|
||||
encodeSignUserData :: forall c. ConnectionModeI c => SConnectionMode c -> C.PrivateKeyEd25519 -> VersionRangeSMPA -> UserLinkData -> ByteString
|
||||
encodeSignUserData _ pk agentVRange userData =
|
||||
encodeSign pk $ smpEncode $ connLinkData @c agentVRange userData
|
||||
|
||||
connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> UserLinkData -> ConnLinkData c
|
||||
connLinkData agentVRange userData = case sConnectionMode @c of
|
||||
SCMInvitation -> InvitationLinkData agentVRange userData
|
||||
SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData}
|
||||
|
||||
encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString
|
||||
encodeSign pk s = smpEncode (C.sign' pk s) <> s
|
||||
|
||||
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
|
||||
|
||||
encryptUserData :: TVar ChaChaDRG -> C.SbKey -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
|
||||
encryptUserData g k s = encryptData g k userDataPaddedLength s
|
||||
|
||||
encryptData :: TVar ChaChaDRG -> C.SbKey -> Int -> ByteString -> ExceptT AgentErrorType IO EncDataBytes
|
||||
encryptData g k len s = do
|
||||
nonce <- liftIO $ atomically $ C.randomCbNonce g
|
||||
ct <- liftEitherWith cryptoError $ C.sbEncrypt k nonce s len
|
||||
pure $ EncDataBytes $ smpEncode nonce <> ct
|
||||
|
||||
decryptLinkData :: forall c. ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnLinkData c)
|
||||
decryptLinkData linkKey k (encFD, encMD) = do
|
||||
(sig1, fd) <- decrypt encFD
|
||||
(sig2, md) <- decrypt encMD
|
||||
FixedLinkData {rootKey, connReq} <- decode fd
|
||||
md' <- decode @(ConnLinkData c) md
|
||||
if
|
||||
| LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash"
|
||||
| not (C.verify' rootKey sig1 fd) -> linkErr "link data signature"
|
||||
| not (C.verify' rootKey sig2 md) -> linkErr "user data signature"
|
||||
| otherwise -> Right (connReq, md')
|
||||
where
|
||||
decrypt (EncDataBytes d) = do
|
||||
(nonce, Tail ct) <- decode d
|
||||
(sig, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct)
|
||||
pure (sig, s)
|
||||
decode :: Encoding a => ByteString -> Either AgentErrorType a
|
||||
decode = msgErr . smpDecode
|
||||
msgErr = first (const $ AGENT A_MESSAGE)
|
||||
linkErr = Left . AGENT . A_LINK
|
||||
@@ -143,7 +143,7 @@ instance Encoding Large where
|
||||
instance Encoding SystemTime where
|
||||
smpEncode = smpEncode . systemSeconds
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = (`MkSystemTime` 0) <$> smpP
|
||||
smpP = MkSystemTime <$> smpP <*> pure 0
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
_smpP :: Encoding a => Parser a
|
||||
|
||||
@@ -39,11 +39,9 @@ import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.Clock.System (SystemTime (..))
|
||||
import Data.Time.Format.ISO8601
|
||||
import Data.Word (Word16, Word32)
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
|
||||
class TextEncoding a where
|
||||
textEncode :: a -> Text
|
||||
@@ -91,10 +89,6 @@ instance StrEncoding String where
|
||||
strEncode = strEncode . B.pack
|
||||
strP = B.unpack <$> strP
|
||||
|
||||
instance StrEncoding Text where
|
||||
strEncode = encodeUtf8
|
||||
strP = safeDecodeUtf8 <$> A.takeTill (\c -> c == ' ' || c == '\n')
|
||||
|
||||
instance ToJSON Str where
|
||||
toJSON (Str s) = strToJSON s
|
||||
toEncoding (Str s) = strToJEncoding s
|
||||
@@ -146,23 +140,11 @@ instance StrEncoding Int64 where
|
||||
|
||||
instance StrEncoding SystemTime where
|
||||
strEncode = strEncode . systemSeconds
|
||||
strP = (`MkSystemTime` 0) <$> strP
|
||||
strP = MkSystemTime <$> strP <*> pure 0
|
||||
|
||||
instance StrEncoding UTCTime where
|
||||
strEncode = B.pack . iso8601Show
|
||||
strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n' || c == ',' || c == ';')
|
||||
|
||||
instance StrEncoding X.CertificateChain where
|
||||
strEncode = (\(X.CertificateChainRaw blobs) -> strEncodeList blobs) . X.encodeCertificateChain
|
||||
{-# INLINE strEncode #-}
|
||||
strP = either (fail . show) pure . X.decodeCertificateChain . X.CertificateChainRaw =<< strListP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding XV.Fingerprint where
|
||||
strEncode (XV.Fingerprint s) = strEncode s
|
||||
{-# INLINE strEncode #-}
|
||||
strP = XV.Fingerprint <$> strP
|
||||
{-# INLINE strP #-}
|
||||
strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
|
||||
|
||||
-- lists encode/parse as comma-separated strings
|
||||
strEncodeList :: StrEncoding a => [a] -> ByteString
|
||||
|
||||
@@ -14,7 +14,7 @@ import Data.Word (Word16)
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, alpnSupportedNTFHandshakes)
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
|
||||
import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
|
||||
import Simplex.Messaging.Transport (TLS, Transport (..))
|
||||
|
||||
@@ -24,45 +24,44 @@ type NtfClientError = ProtocolClientError ErrorType
|
||||
|
||||
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
|
||||
defaultNTFClientConfig =
|
||||
(defaultClientConfig (Just alpnSupportedNTFHandshakes) False supportedClientNTFVRange)
|
||||
(defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange)
|
||||
{defaultTransport = ("443", transport @TLS)}
|
||||
{-# INLINE defaultNTFClientConfig #-}
|
||||
|
||||
ntfRegisterToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c nm pKey newTkn =
|
||||
sendNtfCommand c nm (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
||||
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c pKey newTkn =
|
||||
sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
||||
NRTknId tknId dhKey -> pure (tknId, dhKey)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
|
||||
ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId
|
||||
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
|
||||
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
|
||||
|
||||
ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
|
||||
ntfCheckToken c nm pKey tknId =
|
||||
sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case
|
||||
ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
|
||||
ntfCheckToken c pKey tknId =
|
||||
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
|
||||
NRTkn stat -> pure stat
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
|
||||
ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
|
||||
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
|
||||
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
|
||||
|
||||
ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteToken = okNtfCommand TDEL
|
||||
|
||||
-- set to 0 to disable
|
||||
ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
|
||||
ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm pKey tknId
|
||||
ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
|
||||
ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
|
||||
|
||||
ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
|
||||
ntfCreateSubscription c pKey newSub =
|
||||
sendNtfCommand c NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case
|
||||
sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
|
||||
NRSubId subId -> pure subId
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
|
||||
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs
|
||||
cs = L.map (\newSub -> (Just pKey, NoEntity, NtfCmd SSubscription $ SNEW newSub)) newSubs
|
||||
process (Response _ r) = case r of
|
||||
Right (NRSubId subId) -> Right subId
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
@@ -70,28 +69,28 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c
|
||||
|
||||
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
|
||||
ntfCheckSubscription c pKey subId =
|
||||
sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case
|
||||
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
||||
NRSub stat -> pure stat
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
|
||||
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds
|
||||
cs = L.map (\subId -> (Just pKey, subId, NtfCmd SSubscription SCHK)) subIds
|
||||
process (Response _ r) = case r of
|
||||
Right (NRSub stat) -> Right stat
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
Left e -> Left e
|
||||
|
||||
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground
|
||||
ntfDeleteSubscription = okNtfCommand SDEL
|
||||
|
||||
-- | Send notification server command
|
||||
sendNtfCommand :: NtfEntityI e => NtfClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
|
||||
sendNtfCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (NtfCmd sNtfEntity cmd)
|
||||
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
|
||||
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
|
||||
|
||||
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
|
||||
okNtfCommand cmd c nm pKey entId =
|
||||
sendNtfCommand c nm (Just pKey) entId cmd >>= \case
|
||||
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
|
||||
okNtfCommand cmd c pKey entId =
|
||||
sendNtfCommand c (Just pKey) entId cmd >>= \case
|
||||
NROk -> return ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -11,7 +11,7 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Protocol where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
@@ -28,11 +28,12 @@ import Data.Time.Clock.System
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake)
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake)
|
||||
import Simplex.Messaging.Parsers (fromTextField_)
|
||||
import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
|
||||
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
|
||||
|
||||
@@ -154,15 +155,10 @@ instance Protocol NTFVersion ErrorType NtfResponse where
|
||||
type ProtoCommand NtfResponse = NtfCmd
|
||||
type ProtoType NtfResponse = 'PNTF
|
||||
protocolClientHandshake c _ks = ntfClientHandshake c
|
||||
{-# INLINE protocolClientHandshake #-}
|
||||
useServiceAuth _ = False
|
||||
{-# INLINE useServiceAuth #-}
|
||||
protocolPing = NtfCmd SSubscription PING
|
||||
{-# INLINE protocolPing #-}
|
||||
protocolError = \case
|
||||
NRErr e -> Just e
|
||||
_ -> Nothing
|
||||
{-# INLINE protocolError #-}
|
||||
|
||||
data NtfCommand (e :: NtfEntity) where
|
||||
-- | register new device token for notifications
|
||||
@@ -214,7 +210,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh
|
||||
fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials auth (EntityId entityId) cmd = case cmd of
|
||||
checkCredentials (auth, _, EntityId entityId, _) cmd = case cmd of
|
||||
-- TNEW and SNEW must have signature but NOT token/subscription IDs
|
||||
TNEW {} -> sigNoEntity
|
||||
SNEW {} -> sigNoEntity
|
||||
@@ -254,7 +250,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfCmd where
|
||||
fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials tAuth entId (NtfCmd e c) = NtfCmd e <$> checkCredentials tAuth entId c
|
||||
checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
|
||||
|
||||
data NtfResponseTag
|
||||
= NRTknId_
|
||||
@@ -300,18 +296,12 @@ data NtfResponse
|
||||
|
||||
instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
|
||||
type Tag NtfResponse = NtfResponseTag
|
||||
encodeProtocol v = \case
|
||||
encodeProtocol _v = \case
|
||||
NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
|
||||
NRSubId entId -> e (NRSubId_, ' ', entId)
|
||||
NROk -> e NROk_
|
||||
NRErr err -> e (NRErr_, ' ', err)
|
||||
NRTkn stat -> e (NRTkn_, ' ', stat')
|
||||
where
|
||||
stat'
|
||||
| v >= invalidReasonNTFVersion = stat
|
||||
| otherwise = case stat of
|
||||
NTInvalid _ -> NTInvalid Nothing
|
||||
_ -> stat
|
||||
NRTkn stat -> e (NRTkn_, ' ', stat)
|
||||
NRSub stat -> e (NRSub_, ' ', stat)
|
||||
NRPong -> e NRPong_
|
||||
where
|
||||
@@ -334,7 +324,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
|
||||
PEBlock -> BLOCK
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials _ (EntityId entId) cmd = case cmd of
|
||||
checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
|
||||
-- IDTKN response must not have queue ID
|
||||
NRTknId {} -> noEntity
|
||||
-- IDSUB response must not have queue ID
|
||||
@@ -483,8 +473,6 @@ data NtfSubStatus
|
||||
NSDeleted
|
||||
| -- | SMP AUTH error
|
||||
NSAuth
|
||||
| -- | SMP SERVICE error - rejected service signature on individual subscriptions
|
||||
NSService
|
||||
| -- | SMP error other than AUTH
|
||||
NSErr ByteString
|
||||
deriving (Eq, Ord, Show)
|
||||
@@ -498,7 +486,6 @@ ntfShouldSubscribe = \case
|
||||
NSEnd -> False
|
||||
NSDeleted -> False
|
||||
NSAuth -> False
|
||||
NSService -> True
|
||||
NSErr _ -> False
|
||||
|
||||
instance Encoding NtfSubStatus where
|
||||
@@ -510,7 +497,6 @@ instance Encoding NtfSubStatus where
|
||||
NSEnd -> "END"
|
||||
NSDeleted -> "DELETED"
|
||||
NSAuth -> "AUTH"
|
||||
NSService -> "SERVICE"
|
||||
NSErr err -> "ERR " <> err
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
@@ -521,15 +507,12 @@ instance Encoding NtfSubStatus where
|
||||
"END" -> pure NSEnd
|
||||
"DELETED" -> pure NSDeleted
|
||||
"AUTH" -> pure NSAuth
|
||||
"SERVICE" -> pure NSService
|
||||
"ERR" -> NSErr <$> (A.space *> A.takeByteString)
|
||||
_ -> fail "bad NtfSubStatus"
|
||||
|
||||
instance StrEncoding NtfSubStatus where
|
||||
strEncode = smpEncode
|
||||
{-# INLINE strEncode #-}
|
||||
strP = smpP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
data NtfTknStatus
|
||||
= -- | Token created in DB
|
||||
@@ -537,7 +520,7 @@ data NtfTknStatus
|
||||
| -- | state after registration (TNEW)
|
||||
NTRegistered
|
||||
| -- | if initial notification failed (push provider error) or verification failed
|
||||
NTInvalid (Maybe NTInvalidReason)
|
||||
NTInvalid
|
||||
| -- | Token confirmed via notification (accepted by push provider or verification code received by client)
|
||||
NTConfirmed
|
||||
| -- | after successful verification (TVFY)
|
||||
@@ -546,65 +529,24 @@ data NtfTknStatus
|
||||
NTExpired
|
||||
deriving (Eq, Show)
|
||||
|
||||
allowTokenVerification :: NtfTknStatus -> Bool
|
||||
allowTokenVerification = \case
|
||||
NTNew -> False
|
||||
NTRegistered -> True
|
||||
NTInvalid _ -> False
|
||||
NTConfirmed -> True
|
||||
NTActive -> True
|
||||
NTExpired -> False
|
||||
|
||||
allowNtfSubCommands :: NtfTknStatus -> Bool
|
||||
allowNtfSubCommands = \case
|
||||
NTNew -> False
|
||||
NTRegistered -> False
|
||||
-- TODO we could have separate statuses to show whether it became invalid
|
||||
-- after verification (allow commands) or before (do not allow)
|
||||
NTInvalid _ -> True
|
||||
NTConfirmed -> False
|
||||
NTActive -> True
|
||||
NTExpired -> True
|
||||
|
||||
instance Encoding NtfTknStatus where
|
||||
smpEncode = \case
|
||||
NTNew -> "NEW"
|
||||
NTRegistered -> "REGISTERED"
|
||||
NTInvalid r_ -> "INVALID" <> maybe "" (\r -> ',' `B.cons` strEncode r) r_
|
||||
NTInvalid -> "INVALID"
|
||||
NTConfirmed -> "CONFIRMED"
|
||||
NTActive -> "ACTIVE"
|
||||
NTExpired -> "EXPIRED"
|
||||
smpP =
|
||||
A.takeTill (\c -> c == ' ' || c == ',') >>= \case
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"NEW" -> pure NTNew
|
||||
"REGISTERED" -> pure NTRegistered
|
||||
"INVALID" -> NTInvalid <$> optional (A.char ',' *> strP)
|
||||
"INVALID" -> pure NTInvalid
|
||||
"CONFIRMED" -> pure NTConfirmed
|
||||
"ACTIVE" -> pure NTActive
|
||||
"EXPIRED" -> pure NTExpired
|
||||
_ -> fail "bad NtfTknStatus"
|
||||
|
||||
instance StrEncoding NTInvalidReason where
|
||||
strEncode = smpEncode
|
||||
strP = smpP
|
||||
|
||||
data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRExpiredToken | NTIRUnregistered
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding NTInvalidReason where
|
||||
smpEncode = \case
|
||||
NTIRBadToken -> "BAD"
|
||||
NTIRTokenNotForTopic -> "TOPIC"
|
||||
NTIRExpiredToken -> "EXPIRED"
|
||||
NTIRUnregistered -> "UNREGISTERED"
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"BAD" -> pure NTIRBadToken
|
||||
"TOPIC" -> pure NTIRTokenNotForTopic
|
||||
"EXPIRED" -> pure NTIRExpiredToken
|
||||
"UNREGISTERED" -> pure NTIRUnregistered
|
||||
_ -> fail "bad NTInvalidReason"
|
||||
|
||||
instance StrEncoding NtfTknStatus where
|
||||
strEncode = smpEncode
|
||||
strP = smpP
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -9,72 +8,60 @@
|
||||
module Simplex.Messaging.Notifications.Server.Env where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Crypto.Random
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Data.Word (Word16)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.TLS as T
|
||||
import Numeric.Natural
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..))
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Postgres
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), Transmission)
|
||||
import Simplex.Messaging.Server.Env.STM (StartOptions (..))
|
||||
import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
|
||||
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
|
||||
import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), ServiceCredentials (..), THandleParams, TransportPeer (..))
|
||||
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerConfig = NtfServerConfig
|
||||
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
|
||||
{ transports :: [(ServiceName, ATransport, AddHTTP)],
|
||||
controlPort :: Maybe ServiceName,
|
||||
controlPortUserAuth :: Maybe BasicAuth,
|
||||
controlPortAdminAuth :: Maybe BasicAuth,
|
||||
subIdBytes :: Int,
|
||||
regCodeBytes :: Int,
|
||||
clientQSize :: Natural,
|
||||
subQSize :: Natural,
|
||||
pushQSize :: Natural,
|
||||
smpAgentCfg :: SMPClientAgentConfig,
|
||||
apnsConfig :: APNSPushClientConfig,
|
||||
subsBatchSize :: Int,
|
||||
inactiveClientExpiration :: Maybe ExpirationConfig,
|
||||
dbStoreConfig :: PostgresStoreCfg,
|
||||
storeLogFile :: Maybe FilePath,
|
||||
storeLastNtfsFile :: Maybe FilePath,
|
||||
ntfCredentials :: ServerCredentials,
|
||||
-- send service credentials and use service subscriptions when SMP server supports them
|
||||
useServiceCreds :: Bool,
|
||||
periodicNtfsInterval :: Int, -- seconds
|
||||
-- stats config - see SMP server config
|
||||
logStatsInterval :: Maybe Int64,
|
||||
logStatsStartTime :: Int64,
|
||||
serverStatsLogFile :: FilePath,
|
||||
serverStatsBackupFile :: Maybe FilePath,
|
||||
-- | interval and file to save prometheus metrics
|
||||
prometheusInterval :: Maybe Int,
|
||||
prometheusMetricsFile :: FilePath,
|
||||
ntfServerVRange :: VersionRangeNTF,
|
||||
transportConfig :: TransportServerConfig,
|
||||
startOptions :: StartOptions
|
||||
transportConfig :: TransportServerConfig
|
||||
}
|
||||
|
||||
defaultInactiveClientExpiration :: ExpirationConfig
|
||||
@@ -88,75 +75,71 @@ data NtfEnv = NtfEnv
|
||||
{ config :: NtfServerConfig,
|
||||
subscriber :: NtfSubscriber,
|
||||
pushServer :: NtfPushServer,
|
||||
store :: NtfPostgresStore,
|
||||
store :: NtfStore,
|
||||
storeLog :: Maybe (StoreLog 'WriteMode),
|
||||
random :: TVar ChaChaDRG,
|
||||
tlsServerCreds :: TLS.Credential,
|
||||
tlsServerCreds :: T.Credential,
|
||||
serverIdentity :: C.KeyHash,
|
||||
serverStats :: NtfServerStats
|
||||
}
|
||||
|
||||
newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
|
||||
newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, startOptions} = do
|
||||
when (compactLog startOptions) $ compactDbStoreLog $ dbStoreLogPath dbStoreConfig
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do
|
||||
random <- C.newRandom
|
||||
store <- newNtfDbStore dbStoreConfig
|
||||
tlsServerCreds <- loadServerCredential ntfCredentials
|
||||
serviceCertHash@(XV.Fingerprint fp) <- loadFingerprint ntfCredentials
|
||||
smpAgentCfg' <-
|
||||
if useServiceCreds
|
||||
then do
|
||||
serviceSignKey <- case C.x509ToPrivate' $ snd tlsServerCreds of
|
||||
Right pk -> pure pk
|
||||
Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
|
||||
let service = ServiceCredentials {serviceRole = SRNotifier, serviceCreds = tlsServerCreds, serviceCertHash, serviceSignKey}
|
||||
pure smpAgentCfg {smpCfg = (smpCfg smpAgentCfg) {serviceCredentials = Just service}}
|
||||
else pure smpAgentCfg
|
||||
subscriber <- newNtfSubscriber smpAgentCfg' random
|
||||
store <- newNtfStore
|
||||
logInfo "restoring subscriptions..."
|
||||
storeLog <- mapM (`readWriteNtfStore` store) storeLogFile
|
||||
logInfo "restored subscriptions"
|
||||
subscriber <- newNtfSubscriber subQSize smpAgentCfg random
|
||||
pushServer <- newNtfPushServer pushQSize apnsConfig
|
||||
tlsServerCreds <- loadServerCredential ntfCredentials
|
||||
Fingerprint fp <- loadFingerprint ntfCredentials
|
||||
serverStats <- newNtfServerStats =<< getCurrentTime
|
||||
pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
where
|
||||
compactDbStoreLog = \case
|
||||
Just f -> do
|
||||
logNote $ "compacting store log " <> T.pack f
|
||||
newNtfSTMStore >>= readWriteNtfSTMStore False f >>= closeStoreLog
|
||||
Nothing -> do
|
||||
logError "Error: `--compact-log` used without `enable: on` option in STORE_LOG section of INI file"
|
||||
exitFailure
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriberVar,
|
||||
subscriberSeq :: TVar Int,
|
||||
smpAgent :: SMPClientAgent 'NotifierService
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
|
||||
newSubQ :: TBQueue [NtfEntityRec 'Subscription],
|
||||
smpAgent :: SMPClientAgent
|
||||
}
|
||||
|
||||
type SMPSubscriberVar = SessionVar SMPSubscriber
|
||||
|
||||
newNtfSubscriber :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
|
||||
newNtfSubscriber smpAgentCfg random = do
|
||||
newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
|
||||
newNtfSubscriber qSize smpAgentCfg random = do
|
||||
smpSubscribers <- TM.emptyIO
|
||||
subscriberSeq <- newTVarIO 0
|
||||
smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg random
|
||||
pure NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent}
|
||||
newSubQ <- newTBQueueIO qSize
|
||||
smpAgent <- newSMPClientAgent smpAgentCfg random
|
||||
pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
|
||||
|
||||
data SMPSubscriber = SMPSubscriber
|
||||
{ smpServer :: SMPServer,
|
||||
smpServerId :: Int64,
|
||||
subscriberSubQ :: TQueue ServerNtfSub,
|
||||
subThreadId :: Weak ThreadId
|
||||
{ newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)),
|
||||
subThreadId :: TVar (Maybe (Weak ThreadId))
|
||||
}
|
||||
|
||||
newSMPSubscriber :: IO SMPSubscriber
|
||||
newSMPSubscriber = do
|
||||
newSubQ <- newTQueueIO
|
||||
subThreadId <- newTVarIO Nothing
|
||||
pure SMPSubscriber {newSubQ, subThreadId}
|
||||
|
||||
data NtfPushServer = NtfPushServer
|
||||
{ pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
|
||||
{ pushQ :: TBQueue (NtfTknData, PushNotification),
|
||||
pushClients :: TMap PushProvider PushProviderClient,
|
||||
intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
|
||||
apnsConfig :: APNSPushClientConfig
|
||||
}
|
||||
|
||||
data IntervalNotifier = IntervalNotifier
|
||||
{ action :: Async (),
|
||||
token :: NtfTknData,
|
||||
interval :: Word16
|
||||
}
|
||||
|
||||
newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
|
||||
newNtfPushServer qSize apnsConfig = do
|
||||
pushQ <- newTBQueueIO qSize
|
||||
pushClients <- TM.emptyIO
|
||||
pure NtfPushServer {pushQ, pushClients, apnsConfig}
|
||||
intervalNotifiers <- TM.emptyIO
|
||||
pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
|
||||
|
||||
newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -10,48 +9,30 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Main where
|
||||
|
||||
import Control.Logger.Simple (setLogLevel)
|
||||
import Control.Monad ((<$!>))
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text.IO as T
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
|
||||
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 (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
||||
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer, restoreServerLastNtfs)
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer)
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
|
||||
import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Postgres (exportNtfDbStore, importNtfSTMStore, newNtfDbStore)
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog (readWriteNtfSTMStore)
|
||||
import Simplex.Messaging.Notifications.Transport (alpnSupportedNTFHandshakes, supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Env.STM (StartOptions (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Main (strParse)
|
||||
import Simplex.Messaging.Server.Main.Init (iniDbOpts)
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
|
||||
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
|
||||
import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion)
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
|
||||
import System.Exit (exitFailure)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
@@ -63,8 +44,14 @@ ntfServerCLI cfgPath logPath =
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
||||
_ -> initializeServer opts
|
||||
OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts
|
||||
Start opts -> withIniFile $ runServer opts
|
||||
OnlineCert certOpts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> genOnline cfgPath certOpts
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Start ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit
|
||||
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
@@ -72,75 +59,13 @@ ntfServerCLI cfgPath logPath =
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
|
||||
schemaExists <- checkSchemaExists connstr schema
|
||||
storeLogExists <- doesFileExist storeLogFilePath
|
||||
lastNtfsExists <- doesFileExist defaultLastNtfsFile
|
||||
case cmd of
|
||||
SCImport skipTokens
|
||||
| schemaExists && (storeLogExists || lastNtfsExists) -> exitConfigureNtfStore connstr schema
|
||||
| schemaExists -> do
|
||||
putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
|
||||
exitFailure
|
||||
| not storeLogExists -> do
|
||||
putStrLn $ storeLogFilePath <> " file does not exist."
|
||||
exitFailure
|
||||
| not lastNtfsExists -> do
|
||||
putStrLn $ defaultLastNtfsFile <> " file does not exist."
|
||||
exitFailure
|
||||
| otherwise -> do
|
||||
storeLogFile <- getRequiredStoreLogFile ini
|
||||
confirmOrExit
|
||||
("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
|
||||
"Notification server store not imported"
|
||||
stmStore <- newNtfSTMStore
|
||||
sl <- readWriteNtfSTMStore True storeLogFile stmStore
|
||||
closeStoreLog sl
|
||||
restoreServerLastNtfs stmStore defaultLastNtfsFile
|
||||
let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
|
||||
ps <- newNtfDbStore storeCfg
|
||||
(tCnt, sCnt, nCnt, serviceCnt) <- importNtfSTMStore ps stmStore skipTokens
|
||||
renameFile storeLogFile $ storeLogFile <> ".bak"
|
||||
putStrLn $ "Import completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show serviceCnt <> " service associations, " <> show nCnt <> " last token notifications."
|
||||
putStrLn "Configure database options in INI file."
|
||||
SCExport
|
||||
| schemaExists && storeLogExists -> exitConfigureNtfStore connstr schema
|
||||
| not schemaExists -> do
|
||||
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
||||
exitFailure
|
||||
| storeLogExists -> do
|
||||
putStrLn $ storeLogFilePath <> " file already exists."
|
||||
exitFailure
|
||||
| lastNtfsExists -> do
|
||||
putStrLn $ defaultLastNtfsFile <> " file already exists."
|
||||
exitFailure
|
||||
| otherwise -> do
|
||||
confirmOrExit
|
||||
("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
|
||||
"Notification server store not imported"
|
||||
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Just storeLogFilePath, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
|
||||
st <- newNtfDbStore storeCfg
|
||||
(tCnt, sCnt, nCnt) <- exportNtfDbStore st defaultLastNtfsFile
|
||||
putStrLn $ "Export completed: " <> show tCnt <> " tokens, " <> show sCnt <> " subscriptions, " <> show nCnt <> " last token notifications."
|
||||
where
|
||||
withIniFile a =
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError a
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
getRequiredStoreLogFile ini = do
|
||||
case enableStoreLog' ini $> storeLogFilePath of
|
||||
Just storeLogFile -> do
|
||||
ifM
|
||||
(doesFileExist storeLogFile)
|
||||
(pure storeLogFile)
|
||||
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
|
||||
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
|
||||
iniFile = combine cfgPath "ntf-server.ini"
|
||||
serverVersion = "SMP notifications server v" <> simplexMQVersion
|
||||
defaultServerPort = "443"
|
||||
executableName = "ntf-server"
|
||||
storeLogFilePath = combine logPath "ntf-server-store.log"
|
||||
initializeServer InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn} = do
|
||||
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
|
||||
clearDirIfExists cfgPath
|
||||
clearDirIfExists logPath
|
||||
createDirectoryIfMissing True cfgPath
|
||||
@@ -162,10 +87,9 @@ ntfServerCLI cfgPath logPath =
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Database connection settings for PostgreSQL database.\n"
|
||||
<> iniDbOpts dbOptions defaultNtfDBOpts
|
||||
<> "Time to retain deleted entities in the database, days.\n"
|
||||
<> ("# db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
|
||||
<> "# Last notifications are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "log_stats: off\n\n\
|
||||
\[AUTH]\n\
|
||||
\# control_port_admin_password:\n\
|
||||
@@ -195,37 +119,31 @@ ntfServerCLI cfgPath logPath =
|
||||
\# socks_mode: onion\n\n\
|
||||
\# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
|
||||
\# own_server_domains: \n\n\
|
||||
\# User service subscriptions with server certificate\n\n\
|
||||
\# use_service_credentials: off\n\n\
|
||||
\[INACTIVE_CLIENTS]\n\
|
||||
\# TTL and interval to check inactive clients\n\
|
||||
\disconnect: off\n"
|
||||
<> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
|
||||
enableStoreLog' = settingIsOn "STORE_LOG" "enable"
|
||||
runServer startOptions ini = do
|
||||
setLogLevel $ logLevel startOptions
|
||||
runServer ini = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@NtfServerConfig {transports} = serverConfig
|
||||
cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
|
||||
srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
|
||||
printServiceInfo serverVersion srv
|
||||
printNtfServerConfig transports dbStoreConfig
|
||||
printServerConfig transports storeLogFile
|
||||
runNtfServer cfg
|
||||
where
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
dbStoreLogPath = enableStoreLog' ini $> storeLogFilePath
|
||||
dbStoreConfig =
|
||||
PostgresStoreCfg
|
||||
{ dbOpts = iniDBOptions ini defaultNtfDBOpts,
|
||||
dbStoreLogPath,
|
||||
confirmMigrations = MCYesUp,
|
||||
deletedTTL = iniDeletedTTL ini
|
||||
}
|
||||
restoreLastNtfsFile path = case iniOnOff "STORE_LOG" "restore_last_notifications" ini of
|
||||
Just True -> Just path
|
||||
Just False -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> enableStoreLog $> path
|
||||
serverConfig =
|
||||
NtfServerConfig
|
||||
{ transports = iniTransports ini,
|
||||
@@ -235,7 +153,8 @@ ntfServerCLI cfgPath logPath =
|
||||
subIdBytes = 24,
|
||||
regCodeBytes = 32,
|
||||
clientQSize = 64,
|
||||
pushQSize = 32768,
|
||||
subQSize = 512,
|
||||
pushQSize = 1048,
|
||||
smpAgentCfg =
|
||||
defaultSMPClientAgentConfig
|
||||
{ smpCfg =
|
||||
@@ -246,7 +165,6 @@ ntfServerCLI cfgPath logPath =
|
||||
socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
|
||||
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
|
||||
requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
|
||||
smpWebPortServers = SWPOff,
|
||||
smpPingInterval = 60_000_000 -- 1 minute
|
||||
}
|
||||
},
|
||||
@@ -261,110 +179,57 @@ ntfServerCLI cfgPath logPath =
|
||||
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
|
||||
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
||||
},
|
||||
dbStoreConfig,
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
storeLastNtfsFile = restoreLastNtfsFile $ combine logPath "ntf-server-last-notifications.log",
|
||||
ntfCredentials =
|
||||
ServerCredentials
|
||||
{ caCertificateFile = Just $ c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile
|
||||
},
|
||||
useServiceCreds = fromMaybe False $ iniOnOff "SUBSCRIBER" "use_service_credentials" ini,
|
||||
periodicNtfsInterval = 5 * 60, -- 5 minutes
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
|
||||
prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
|
||||
prometheusMetricsFile = combine logPath "ntf-server-metrics.txt",
|
||||
ntfServerVRange = supportedServerNTFVRange,
|
||||
transportConfig =
|
||||
mkTransportServerConfig
|
||||
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
|
||||
(Just alpnSupportedNTFHandshakes)
|
||||
False,
|
||||
startOptions
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
}
|
||||
}
|
||||
iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
|
||||
defaultLastNtfsFile = combine logPath "ntf-server-last-notifications.log"
|
||||
exitConfigureNtfStore connstr schema = do
|
||||
putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
|
||||
putStrLn "Configure notification server storage."
|
||||
exitFailure
|
||||
|
||||
printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
|
||||
printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
|
||||
B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
|
||||
printServerConfig "NTF" transports dbStoreLogPath
|
||||
|
||||
data CliCommand
|
||||
= Init InitOptions
|
||||
| OnlineCert CertOptions
|
||||
| Start StartOptions
|
||||
| Start
|
||||
| Delete
|
||||
| Database StoreCmd DBOpts
|
||||
|
||||
data StoreCmd = SCImport (Set NtfTokenId) | SCExport
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
dbOptions :: DBOpts,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
ip :: HostName,
|
||||
fqdn :: Maybe HostName
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
defaultNtfDBOpts :: DBOpts
|
||||
defaultNtfDBOpts =
|
||||
DBOpts
|
||||
{ connstr = "postgresql://ntf@/ntf_server_store",
|
||||
schema = "ntf_server",
|
||||
poolSize = 10,
|
||||
createSchema = False
|
||||
}
|
||||
|
||||
-- time to retain deleted tokens and subscriptions in the database (days), for debugging
|
||||
defaultDeletedTTL :: Int64
|
||||
defaultDeletedTTL = 21
|
||||
|
||||
cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
|
||||
cliCommandP cfgPath logPath iniFile =
|
||||
hsubparser
|
||||
( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
|
||||
<> 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 "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
|
||||
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
|
||||
<> command "database" (info (Database <$> databaseCmdP <*> dbOptsP defaultNtfDBOpts) (progDesc "Import/export notifications server store to/from PostgreSQL database"))
|
||||
)
|
||||
where
|
||||
databaseCmdP =
|
||||
hsubparser
|
||||
( command "import" (info (SCImport <$> skipTokensP) (progDesc $ "Import store logs into a new PostgreSQL database schema"))
|
||||
<> command "export" (info (pure SCExport) (progDesc $ "Export PostgreSQL database schema to store logs"))
|
||||
)
|
||||
skipTokensP :: Parser (Set NtfTokenId)
|
||||
skipTokensP =
|
||||
option
|
||||
strParse
|
||||
( long "skip-tokens"
|
||||
<> help "Skip tokens during import"
|
||||
<> value S.empty
|
||||
)
|
||||
initP :: Parser InitOptions
|
||||
initP = do
|
||||
enableStoreLog <-
|
||||
flag' False
|
||||
( long "disable-store-log"
|
||||
<> help "Disable store log for persistence (enabled by default)"
|
||||
initP =
|
||||
InitOptions
|
||||
<$> switch
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
<|> flag True True
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence (DEPRECATED, enabled by default)"
|
||||
)
|
||||
dbOptions <- dbOptsP defaultNtfDBOpts
|
||||
signAlgorithm <-
|
||||
option
|
||||
<*> option
|
||||
(maybeReader readMaybe)
|
||||
( long "sign-algorithm"
|
||||
<> short 'a'
|
||||
@@ -373,8 +238,7 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> showDefault
|
||||
<> metavar "ALG"
|
||||
)
|
||||
ip <-
|
||||
strOption
|
||||
<*> strOption
|
||||
( long "ip"
|
||||
<> help
|
||||
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
|
||||
@@ -382,12 +246,10 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> showDefault
|
||||
<> metavar "IP"
|
||||
)
|
||||
fqdn <-
|
||||
(optional . strOption)
|
||||
<*> (optional . strOption)
|
||||
( long "fqdn"
|
||||
<> short 'n'
|
||||
<> help "Server FQDN used as Common Name for TLS online certificate"
|
||||
<> showDefault
|
||||
<> metavar "FQDN"
|
||||
)
|
||||
pure InitOptions {enableStoreLog, dbOptions, signAlgorithm, ip, fqdn}
|
||||
|
||||
@@ -1,285 +0,0 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Prometheus where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), diffUTCTime)
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Numeric.Natural (Natural)
|
||||
import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
|
||||
data NtfServerMetrics = NtfServerMetrics
|
||||
{ statsData :: NtfServerStatsData,
|
||||
activeTokensCounts :: PeriodStatCounts,
|
||||
activeSubsCounts :: PeriodStatCounts,
|
||||
tokenCount :: Int64,
|
||||
approxSubCount :: Int64,
|
||||
lastNtfCount :: Int64,
|
||||
rtsOptions :: Text
|
||||
}
|
||||
|
||||
rtsOptionsEnv :: Text
|
||||
rtsOptionsEnv = "NTF_RTS_OPTIONS"
|
||||
|
||||
data NtfRealTimeMetrics = NtfRealTimeMetrics
|
||||
{ threadsCount :: Int,
|
||||
srvSubscribers :: NtfSMPWorkerMetrics,
|
||||
srvClients :: NtfSMPWorkerMetrics,
|
||||
srvSubWorkers :: NtfSMPWorkerMetrics,
|
||||
ntfActiveServiceSubs :: NtfSMPSubMetrics,
|
||||
ntfActiveQueueSubs :: NtfSMPSubMetrics,
|
||||
ntfPendingServiceSubs :: NtfSMPSubMetrics,
|
||||
ntfPendingQueueSubs :: NtfSMPSubMetrics,
|
||||
smpSessionCount :: Int,
|
||||
apnsPushQLength :: Natural
|
||||
}
|
||||
|
||||
data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int}
|
||||
|
||||
data NtfSMPSubMetrics = NtfSMPSubMetrics {ownSrvSubs :: M.Map Text Int, otherServers :: Int, otherSrvSubCount :: Int}
|
||||
|
||||
{-# FOURMOLU_DISABLE\n#-}
|
||||
ntfPrometheusMetrics :: NtfServerMetrics -> NtfRealTimeMetrics -> UTCTime -> Text
|
||||
ntfPrometheusMetrics sm rtm ts =
|
||||
time <> tokens <> subscriptions <> notifications <> info
|
||||
where
|
||||
NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm
|
||||
NtfRealTimeMetrics
|
||||
{ threadsCount,
|
||||
srvSubscribers,
|
||||
srvClients,
|
||||
srvSubWorkers,
|
||||
ntfActiveServiceSubs,
|
||||
ntfActiveQueueSubs,
|
||||
ntfPendingServiceSubs,
|
||||
ntfPendingQueueSubs,
|
||||
smpSessionCount,
|
||||
apnsPushQLength
|
||||
} = rtm
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfReceivedAuth,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfReceivedOwn,
|
||||
_ntfReceivedAuthOwn,
|
||||
_ntfDeliveredOwn,
|
||||
_ntfFailedOwn,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn
|
||||
} = statsData
|
||||
time =
|
||||
"# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
|
||||
\# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\
|
||||
\\n"
|
||||
tokens =
|
||||
"# Tokens\n\
|
||||
\# ------\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_created Created tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_created counter\n\
|
||||
\simplex_ntf_tokens_created " <> mshow _tknCreated <> "\n# tknCreated\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_verified Verified tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_verified counter\n\
|
||||
\simplex_ntf_tokens_verified " <> mshow _tknVerified <> "\n# tknVerified\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_deleted Deleted tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_deleted counter\n\
|
||||
\simplex_ntf_tokens_deleted " <> mshow _tknDeleted <> "\n# tknDeleted\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_replaced Deleted tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_replaced counter\n\
|
||||
\simplex_ntf_tokens_replaced " <> mshow _tknReplaced <> "\n# tknReplaced\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_count_daily Daily active tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_count_daily gauge\n\
|
||||
\simplex_ntf_tokens_count_daily " <> mstr (dayCount psTkns) <> "\n# dayCountTkn\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_count_weekly Weekly active tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_count_weekly gauge\n\
|
||||
\simplex_ntf_tokens_count_weekly " <> mstr (weekCount psTkns) <> "\n# weekCountTkn\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_count_monthly Monthly active tokens\n\
|
||||
\# TYPE simplex_ntf_tokens_count_monthly gauge\n\
|
||||
\simplex_ntf_tokens_count_monthly " <> mstr (monthCount psTkns) <> "\n# monthCountTkn\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_tokens_total Total number of tokens stored.\n\
|
||||
\# TYPE simplex_ntf_tokens_total gauge\n\
|
||||
\simplex_ntf_tokens_total " <> mshow tokenCount <> "\n# tokenCount\n\
|
||||
\\n"
|
||||
subscriptions =
|
||||
"# Subscriptions\n\
|
||||
\# -------------\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_created Created subscriptions\n\
|
||||
\# TYPE simplex_ntf_subscriptions_created counter\n\
|
||||
\simplex_ntf_subscriptions_created " <> mshow _subCreated <> "\n# subCreated\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_deleted Deleted subscriptions\n\
|
||||
\# TYPE simplex_ntf_subscriptions_deleted counter\n\
|
||||
\simplex_ntf_subscriptions_deleted " <> mshow _subDeleted <> "\n# subDeleted\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_count_daily Daily subscriptions count\n\
|
||||
\# TYPE simplex_ntf_subscriptions_count_daily gauge\n\
|
||||
\simplex_ntf_subscriptions_count_daily " <> mstr (dayCount psSubs) <> "\n# dayCountSub\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_count_weekly Weekly subscriptions count\n\
|
||||
\# TYPE simplex_ntf_subscriptions_count_weekly gauge\n\
|
||||
\simplex_ntf_subscriptions_count_weekly " <> mstr (weekCount psSubs) <> "\n# weekCountSub\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_count_monthly Monthly subscriptions count\n\
|
||||
\# TYPE simplex_ntf_subscriptions_count_monthly gauge\n\
|
||||
\simplex_ntf_subscriptions_count_monthly " <> mstr (monthCount psSubs) <> "\n# monthCountSub\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_subscriptions_approx_total Approximate total number of subscriptions stored.\n\
|
||||
\# TYPE simplex_ntf_subscriptions_approx_total gauge\n\
|
||||
\simplex_ntf_subscriptions_approx_total " <> mshow approxSubCount <> "\n# approxSubCount\n\
|
||||
\\n"
|
||||
<> showSubMetric ntfActiveServiceSubs "simplex_ntf_smp_service_subscription_active_" "Active"
|
||||
<> showSubMetric ntfActiveQueueSubs "simplex_ntf_smp_subscription_active_" "Active"
|
||||
<> showSubMetric ntfPendingServiceSubs "simplex_ntf_smp_service_subscription_pending_" "Pending"
|
||||
<> showSubMetric ntfPendingQueueSubs "simplex_ntf_smp_subscription_pending_" "Pending"
|
||||
notifications =
|
||||
"# Notifications\n\
|
||||
\# -------------\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_received Received notifications\n\
|
||||
\# TYPE simplex_ntf_notifications_received counter\n\
|
||||
\simplex_ntf_notifications_received " <> mshow _ntfReceived <> "\n# ntfReceived\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_received_auth Received notifications without token or subscription (AUTH error)\n\
|
||||
\# TYPE simplex_ntf_notifications_received_auth counter\n\
|
||||
\simplex_ntf_notifications_received_auth " <> mshow _ntfReceivedAuth <> "\n# ntfReceivedAuth\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_delivered Delivered notifications\n\
|
||||
\# TYPE simplex_ntf_notifications_delivered counter\n\
|
||||
\simplex_ntf_notifications_delivered " <> mshow _ntfDelivered <> "\n# ntfDelivered\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_failed Failed notifications\n\
|
||||
\# TYPE simplex_ntf_notifications_failed counter\n\
|
||||
\simplex_ntf_notifications_failed " <> mshow _ntfFailed <> "\n# ntfFailed\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_periodic_delivered Delivered periodic notifications\n\
|
||||
\# TYPE simplex_ntf_notifications_periodic_delivered counter\n\
|
||||
\simplex_ntf_notifications_periodic_delivered " <> mshow _ntfCronDelivered <> "\n# ntfCronDelivered\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_periodic_failed Failed periodic notifications\n\
|
||||
\# TYPE simplex_ntf_notifications_periodic_failed counter\n\
|
||||
\simplex_ntf_notifications_periodic_failed " <> mshow _ntfCronFailed <> "\n# ntfCronFailed\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_verification_queued Token verifications queued\n\
|
||||
\# TYPE simplex_ntf_notifications_verification_queued counter\n\
|
||||
\simplex_ntf_notifications_verification_queued " <> mshow _ntfVrfQueued <> "\n# ntfVrfQueued\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_verification_delivered Delivered token verifications\n\
|
||||
\# TYPE simplex_ntf_notifications_verification_delivered counter\n\
|
||||
\simplex_ntf_notifications_verification_delivered " <> mshow _ntfVrfDelivered <> "\n# ntfVrfDelivered\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_verification_failed Failed token verification deliveries\n\
|
||||
\# TYPE simplex_ntf_notifications_verification_failed counter\n\
|
||||
\simplex_ntf_notifications_verification_failed " <> mshow _ntfVrfFailed <> "\n# ntfVrfFailed\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_verification_invalid_tkn Invalid token errors while delivering verifications\n\
|
||||
\# TYPE simplex_ntf_notifications_verification_invalid_tkn counter\n\
|
||||
\simplex_ntf_notifications_verification_invalid_tkn " <> mshow _ntfVrfInvalidTkn <> "\n# ntfVrfInvalidTkn\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_notifications_total Total number of last notifications stored.\n\
|
||||
\# TYPE simplex_ntf_notifications_total gauge\n\
|
||||
\simplex_ntf_notifications_total " <> mshow lastNtfCount <> "\n# lastNtfCount\n\
|
||||
\\n"
|
||||
<> showNtfsByServer _ntfReceivedOwn "simplex_ntf_notifications_received_own" "Received notifications" "ntfReceivedOwn"
|
||||
<> showNtfsByServer _ntfReceivedAuthOwn "simplex_ntf_notifications_received_auth_own" "Received notifications without token or subscription (AUTH error)" "ntfReceivedAuthOwn"
|
||||
<> showNtfsByServer _ntfDeliveredOwn "simplex_ntf_notifications_delivered_own" "Delivered notifications" "ntfDeliveredOwn"
|
||||
<> showNtfsByServer _ntfFailedOwn "simplex_ntf_notifications_failed_own" "Failed notifications" "ntfFailedOwn"
|
||||
info =
|
||||
"# Info\n\
|
||||
\# ----\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_info Server information. RTS options have to be passed via " <> rtsOptionsEnv <> " env var\n\
|
||||
\# TYPE simplex_ntf_info gauge\n\
|
||||
\simplex_ntf_info{version=\"" <> T.pack simplexMQVersion <> "\",rts_options=\"" <> rtsOptions <> "\"} 1\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_threads_total Thread count\n\
|
||||
\# TYPE simplex_ntf_threads_total gauge\n\
|
||||
\simplex_ntf_threads_total " <> mshow threadsCount <> "\n# threadsCount\n\
|
||||
\\n"
|
||||
<> showWorkerMetric srvSubscribers "simplex_ntf_smp_subscribers_" "SMP subcscribers"
|
||||
<> showWorkerMetric srvClients "simplex_ntf_smp_agent_clients_" "SMP agent clients"
|
||||
<> showWorkerMetric srvSubWorkers "simplex_ntf_smp_agent_sub_workers_" "SMP agent subscription workers"
|
||||
<> "# HELP simplex_ntf_smp_sessions_count SMP sessions count\n\
|
||||
\# TYPE simplex_ntf_smp_sessions_count gauge\n\
|
||||
\simplex_ntf_smp_sessions_count " <> mshow smpSessionCount <> "\n# smpSessionCount\n\
|
||||
\\n\
|
||||
\# HELP simplex_ntf_apns_push_queue_length Count of notifications in push queue\n\
|
||||
\# TYPE simplex_ntf_apns_push_queue_length gauge\n\
|
||||
\simplex_ntf_apns_push_queue_length " <> mshow apnsPushQLength <> "\n# apnsPushQLength\n\
|
||||
\\n"
|
||||
showSubMetric NtfSMPSubMetrics {ownSrvSubs, otherServers, otherSrvSubCount} mPfx descrPfx =
|
||||
showOwnSrvSubs <> showOtherSrvSubs
|
||||
where
|
||||
showOwnSrvSubs
|
||||
| M.null ownSrvSubs = ""
|
||||
| otherwise =
|
||||
gaugeMetrics (mPfx <> "server_count_own") srvMetrics (descrPfx <> " SMP subscriptions, own server count") "ownSrvSubs server"
|
||||
<> gaugeMetrics (mPfx <> "sub_count_own") subMetrics (descrPfx <> " SMP subscriptions count for own servers") "ownSrvSubs count"
|
||||
where
|
||||
subs = M.assocs ownSrvSubs
|
||||
srvMetrics = map (\(host, _) -> (metricHost host, 1)) subs
|
||||
subMetrics = map (\(host, cnt) -> (metricHost host, cnt)) subs
|
||||
showOtherSrvSubs =
|
||||
gaugeMetrics (mPfx <> "server_count_other") [("", otherServers)] (descrPfx <> " SMP subscriptions, other server count") "otherServers"
|
||||
<> gaugeMetrics (mPfx <> "sub_count_other") [("", otherSrvSubCount)] (descrPfx <> " SMP subscriptions count for other servers") "otherSrvSubCount"
|
||||
showNtfsByServer (StatsByServerData srvNtfs) mName descr varName
|
||||
| null srvNtfs = ""
|
||||
| otherwise =
|
||||
"# HELP " <> mName <> " " <> descr <> "\n\
|
||||
\# TYPE " <> mName <> " counter\n"
|
||||
<> showNtfMetrics
|
||||
<> "# " <> varName <> "\n\n"
|
||||
where
|
||||
showNtfMetrics = T.concat $ map (\(host, value) -> mName <> metricHost host <> " " <> mshow value <> "\n") srvNtfs
|
||||
showWorkerMetric NtfSMPWorkerMetrics {ownServers, otherServers} mPfx descrPfx =
|
||||
showOwnServers <> showOtherServers
|
||||
where
|
||||
showOwnServers
|
||||
| null ownServers = ""
|
||||
| otherwise = gaugeMetrics (mPfx <> "count_own") subMetrics (descrPfx <> " count for own servers") "ownServers"
|
||||
where
|
||||
subMetrics = map (\host -> (metricHost host, 1)) ownServers
|
||||
showOtherServers = gaugeMetrics (mPfx <> "count_other") [("", otherServers)] (descrPfx <> " count for other servers") "otherServers"
|
||||
gaugeMetrics :: Text -> [(Text, Int)] -> Text -> Text -> Text
|
||||
gaugeMetrics name subMetrics descr codeRef =
|
||||
"# HELP " <> name <> " " <> descr <> "\n\
|
||||
\# TYPE " <> name <> " gauge\n"
|
||||
<> T.concat (map (\(param, value) -> name <> param <> " " <> mshow value <> "\n") subMetrics)
|
||||
<> "# " <> codeRef <> "\n\n"
|
||||
metricHost host = "{server=\"" <> host <> "\"}"
|
||||
mstr a = a <> " " <> tsEpoch
|
||||
mshow :: Show a => a -> Text
|
||||
mshow = mstr . tshow
|
||||
tsEpoch = tshow @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
|
||||
epoch = UTCTime systemEpochDay 0
|
||||
{-# FOURMOLU_ENABLE\n#-}
|
||||
@@ -33,19 +33,15 @@ import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Builder (lazyByteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Clock.System
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.CertificateStore as XS
|
||||
import Network.HPACK.Token as HT
|
||||
import Network.HTTP.Types (Status)
|
||||
import qualified Network.HTTP.Types as N
|
||||
import Network.HTTP2.Client (Request)
|
||||
@@ -54,7 +50,7 @@ import Network.Socket (HostName, ServiceName)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
|
||||
import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -267,8 +263,8 @@ disconnectApnsHTTP2Client APNSPushClient {https2Client} =
|
||||
ntfCategoryCheckMessage :: Text
|
||||
ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
|
||||
|
||||
apnsNotification :: NtfTknRec -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
|
||||
apnsNotification NtfTknRec {tknDhSecret} nonce paddedLen = \case
|
||||
apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
|
||||
apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
|
||||
PNVerification (NtfRegCode code) ->
|
||||
encrypt code $ \code' ->
|
||||
apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
|
||||
@@ -312,12 +308,12 @@ data PushProviderError
|
||||
= PPConnection HTTP2ClientError
|
||||
| PPCryptoError C.CryptoError
|
||||
| PPResponseError (Maybe Status) Text
|
||||
| PPTokenInvalid NTInvalidReason
|
||||
| PPTokenInvalid
|
||||
| PPRetryLater
|
||||
| PPPermanentError
|
||||
deriving (Show, Exception)
|
||||
|
||||
type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
|
||||
type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
|
||||
|
||||
-- this is not a newtype on purpose to have a correct JSON encoding as a record
|
||||
data APNSErrorResponse = APNSErrorResponse {reason :: Text}
|
||||
@@ -325,7 +321,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text}
|
||||
$(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse)
|
||||
|
||||
apnsPushProviderClient :: APNSPushClient -> PushProviderClient
|
||||
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do
|
||||
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
|
||||
http2 <- liftHTTPS2 $ getApnsHTTP2Client c
|
||||
nonce <- atomically $ C.randomCbNonce nonceDrg
|
||||
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
|
||||
@@ -334,34 +330,26 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token
|
||||
HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
|
||||
let status = H.responseStatus response
|
||||
reason' = maybe "" reason $ J.decodeStrict' bodyHead
|
||||
if status == Just N.ok200
|
||||
then logDebug $ "APNS response: ok" <> apnsIds response
|
||||
else logWarn $ "APNS error: " <> T.pack (show status) <> " " <> reason' <> apnsIds response
|
||||
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
|
||||
result status reason'
|
||||
where
|
||||
apnsIds response = headerStr "apns-id" <> headerStr "apns-unique-id"
|
||||
where
|
||||
headerStr name =
|
||||
maybe "" (\(_, v) -> ", " <> name <> ": " <> safeDecodeUtf8 v) $
|
||||
find (\(t, _) -> HT.tokenKey t == CI.mk (encodeUtf8 name)) (fst (H.responseHeaders response))
|
||||
result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
result status reason'
|
||||
| status == Just N.ok200 = pure ()
|
||||
| status == Just N.badRequest400 =
|
||||
throwE $ case reason' of
|
||||
"BadDeviceToken" -> PPTokenInvalid NTIRBadToken
|
||||
"DeviceTokenNotForTopic" -> PPTokenInvalid NTIRTokenNotForTopic
|
||||
"TopicDisallowed" -> PPPermanentError
|
||||
_ -> PPResponseError status reason'
|
||||
| status == Just N.forbidden403 = throwE $ case reason' of
|
||||
"ExpiredProviderToken" -> PPPermanentError -- there should be no point retrying it as the token was refreshed
|
||||
"InvalidProviderToken" -> PPPermanentError
|
||||
_ -> PPResponseError status reason'
|
||||
| status == Just N.gone410 = throwE $ case reason' of
|
||||
"ExpiredToken" -> PPTokenInvalid NTIRExpiredToken
|
||||
"Unregistered" -> PPTokenInvalid NTIRUnregistered
|
||||
_ -> PPRetryLater
|
||||
case reason' of
|
||||
"BadDeviceToken" -> throwE PPTokenInvalid
|
||||
"DeviceTokenNotForTopic" -> throwE PPTokenInvalid
|
||||
"TopicDisallowed" -> throwE PPPermanentError
|
||||
_ -> err status reason'
|
||||
| status == Just N.forbidden403 = case reason' of
|
||||
"ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed
|
||||
"InvalidProviderToken" -> throwE PPPermanentError
|
||||
_ -> err status reason'
|
||||
| status == Just N.gone410 = throwE PPTokenInvalid
|
||||
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater
|
||||
-- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
|
||||
| otherwise = throwE $ PPResponseError status reason'
|
||||
| otherwise = err status reason'
|
||||
err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
err s r = throwE $ PPResponseError s r
|
||||
liftHTTPS2 a = ExceptT $ first PPConnection <$> a
|
||||
|
||||
@@ -4,41 +4,23 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Stats where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Applicative (optional)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.IORef
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
|
||||
data NtfServerStats = NtfServerStats
|
||||
{ fromTime :: IORef UTCTime,
|
||||
tknCreated :: IORef Int,
|
||||
tknVerified :: IORef Int,
|
||||
tknDeleted :: IORef Int,
|
||||
tknReplaced :: IORef Int,
|
||||
subCreated :: IORef Int,
|
||||
subDeleted :: IORef Int,
|
||||
ntfReceived :: IORef Int,
|
||||
ntfReceivedAuth :: IORef Int,
|
||||
ntfDelivered :: IORef Int,
|
||||
ntfFailed :: IORef Int,
|
||||
ntfReceivedOwn :: StatsByServer,
|
||||
ntfReceivedAuthOwn :: StatsByServer,
|
||||
ntfDeliveredOwn :: StatsByServer,
|
||||
ntfFailedOwn :: StatsByServer,
|
||||
ntfCronDelivered :: IORef Int,
|
||||
ntfCronFailed :: IORef Int,
|
||||
ntfVrfQueued :: IORef Int,
|
||||
ntfVrfDelivered :: IORef Int,
|
||||
ntfVrfFailed :: IORef Int,
|
||||
ntfVrfInvalidTkn :: IORef Int,
|
||||
activeTokens :: PeriodStats,
|
||||
activeSubs :: PeriodStats
|
||||
}
|
||||
@@ -48,23 +30,10 @@ data NtfServerStatsData = NtfServerStatsData
|
||||
_tknCreated :: Int,
|
||||
_tknVerified :: Int,
|
||||
_tknDeleted :: Int,
|
||||
_tknReplaced :: Int,
|
||||
_subCreated :: Int,
|
||||
_subDeleted :: Int,
|
||||
_ntfReceived :: Int,
|
||||
_ntfReceivedAuth :: Int,
|
||||
_ntfDelivered :: Int,
|
||||
_ntfFailed :: Int,
|
||||
_ntfReceivedOwn :: StatsByServerData,
|
||||
_ntfReceivedAuthOwn :: StatsByServerData,
|
||||
_ntfDeliveredOwn :: StatsByServerData,
|
||||
_ntfFailedOwn :: StatsByServerData,
|
||||
_ntfCronDelivered :: Int,
|
||||
_ntfCronFailed :: Int,
|
||||
_ntfVrfQueued :: Int,
|
||||
_ntfVrfDelivered :: Int,
|
||||
_ntfVrfFailed :: Int,
|
||||
_ntfVrfInvalidTkn :: Int,
|
||||
_activeTokens :: PeriodStatsData,
|
||||
_activeSubs :: PeriodStatsData
|
||||
}
|
||||
@@ -75,51 +44,13 @@ newNtfServerStats ts = do
|
||||
tknCreated <- newIORef 0
|
||||
tknVerified <- newIORef 0
|
||||
tknDeleted <- newIORef 0
|
||||
tknReplaced <- newIORef 0
|
||||
subCreated <- newIORef 0
|
||||
subDeleted <- newIORef 0
|
||||
ntfReceived <- newIORef 0
|
||||
ntfReceivedAuth <- newIORef 0
|
||||
ntfDelivered <- newIORef 0
|
||||
ntfFailed <- newIORef 0
|
||||
ntfReceivedOwn <- TM.emptyIO
|
||||
ntfReceivedAuthOwn <- TM.emptyIO
|
||||
ntfDeliveredOwn <- TM.emptyIO
|
||||
ntfFailedOwn <- TM.emptyIO
|
||||
ntfCronDelivered <- newIORef 0
|
||||
ntfCronFailed <- newIORef 0
|
||||
ntfVrfQueued <- newIORef 0
|
||||
ntfVrfDelivered <- newIORef 0
|
||||
ntfVrfFailed <- newIORef 0
|
||||
ntfVrfInvalidTkn <- newIORef 0
|
||||
activeTokens <- newPeriodStats
|
||||
activeSubs <- newPeriodStats
|
||||
pure
|
||||
NtfServerStats
|
||||
{ fromTime,
|
||||
tknCreated,
|
||||
tknVerified,
|
||||
tknDeleted,
|
||||
tknReplaced,
|
||||
subCreated,
|
||||
subDeleted,
|
||||
ntfReceived,
|
||||
ntfReceivedAuth,
|
||||
ntfDelivered,
|
||||
ntfFailed,
|
||||
ntfReceivedOwn,
|
||||
ntfReceivedAuthOwn,
|
||||
ntfDeliveredOwn,
|
||||
ntfFailedOwn,
|
||||
ntfCronDelivered,
|
||||
ntfCronFailed,
|
||||
ntfVrfQueued,
|
||||
ntfVrfDelivered,
|
||||
ntfVrfFailed,
|
||||
ntfVrfInvalidTkn,
|
||||
activeTokens,
|
||||
activeSubs
|
||||
}
|
||||
pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
|
||||
|
||||
getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData
|
||||
getNtfServerStatsData s@NtfServerStats {fromTime} = do
|
||||
@@ -127,51 +58,13 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
|
||||
_tknCreated <- readIORef $ tknCreated s
|
||||
_tknVerified <- readIORef $ tknVerified s
|
||||
_tknDeleted <- readIORef $ tknDeleted s
|
||||
_tknReplaced <- readIORef $ tknReplaced s
|
||||
_subCreated <- readIORef $ subCreated s
|
||||
_subDeleted <- readIORef $ subDeleted s
|
||||
_ntfReceived <- readIORef $ ntfReceived s
|
||||
_ntfReceivedAuth <- readIORef $ ntfReceivedAuth s
|
||||
_ntfDelivered <- readIORef $ ntfDelivered s
|
||||
_ntfFailed <- readIORef $ ntfFailed s
|
||||
_ntfReceivedOwn <- getStatsByServer $ ntfReceivedOwn s
|
||||
_ntfReceivedAuthOwn <- getStatsByServer $ ntfReceivedAuthOwn s
|
||||
_ntfDeliveredOwn <- getStatsByServer $ ntfDeliveredOwn s
|
||||
_ntfFailedOwn <- getStatsByServer $ ntfFailedOwn s
|
||||
_ntfCronDelivered <- readIORef $ ntfCronDelivered s
|
||||
_ntfCronFailed <- readIORef $ ntfCronFailed s
|
||||
_ntfVrfQueued <- readIORef $ ntfVrfQueued s
|
||||
_ntfVrfDelivered <- readIORef $ ntfVrfDelivered s
|
||||
_ntfVrfFailed <- readIORef $ ntfVrfFailed s
|
||||
_ntfVrfInvalidTkn <- readIORef $ ntfVrfInvalidTkn s
|
||||
_activeTokens <- getPeriodStatsData $ activeTokens s
|
||||
_activeSubs <- getPeriodStatsData $ activeSubs s
|
||||
pure
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfReceivedAuth,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfReceivedOwn,
|
||||
_ntfReceivedAuthOwn,
|
||||
_ntfDeliveredOwn,
|
||||
_ntfFailedOwn,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
}
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO ()
|
||||
@@ -180,75 +73,24 @@ setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} =
|
||||
writeIORef (tknCreated s) $! _tknCreated d
|
||||
writeIORef (tknVerified s) $! _tknVerified d
|
||||
writeIORef (tknDeleted s) $! _tknDeleted d
|
||||
writeIORef (tknReplaced s) $! _tknReplaced d
|
||||
writeIORef (subCreated s) $! _subCreated d
|
||||
writeIORef (subDeleted s) $! _subDeleted d
|
||||
writeIORef (ntfReceived s) $! _ntfReceived d
|
||||
writeIORef (ntfReceivedAuth s) $! _ntfReceivedAuth d
|
||||
writeIORef (ntfDelivered s) $! _ntfDelivered d
|
||||
writeIORef (ntfFailed s) $! _ntfFailed d
|
||||
setStatsByServer (ntfReceivedOwn s) $! _ntfReceivedOwn d
|
||||
setStatsByServer (ntfReceivedAuthOwn s) $! _ntfReceivedAuthOwn d
|
||||
setStatsByServer (ntfDeliveredOwn s) $! _ntfDeliveredOwn d
|
||||
setStatsByServer (ntfFailedOwn s) $! _ntfFailedOwn d
|
||||
writeIORef (ntfCronDelivered s) $! _ntfCronDelivered d
|
||||
writeIORef (ntfCronFailed s) $! _ntfCronFailed d
|
||||
writeIORef (ntfVrfQueued s) $! _ntfVrfQueued d
|
||||
writeIORef (ntfVrfDelivered s) $! _ntfVrfDelivered d
|
||||
writeIORef (ntfVrfFailed s) $! _ntfVrfFailed d
|
||||
writeIORef (ntfVrfInvalidTkn s) $! _ntfVrfInvalidTkn d
|
||||
setPeriodStats (activeTokens s) (_activeTokens d)
|
||||
setPeriodStats (activeSubs s) (_activeSubs d)
|
||||
|
||||
instance StrEncoding NtfServerStatsData where
|
||||
strEncode
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfReceivedAuth,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfReceivedOwn,
|
||||
_ntfReceivedAuthOwn,
|
||||
_ntfDeliveredOwn,
|
||||
_ntfFailedOwn,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
} =
|
||||
strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
|
||||
B.unlines
|
||||
[ "fromTime=" <> strEncode _fromTime,
|
||||
"tknCreated=" <> strEncode _tknCreated,
|
||||
"tknVerified=" <> strEncode _tknVerified,
|
||||
"tknDeleted=" <> strEncode _tknDeleted,
|
||||
"tknReplaced=" <> strEncode _tknReplaced,
|
||||
"subCreated=" <> strEncode _subCreated,
|
||||
"subDeleted=" <> strEncode _subDeleted,
|
||||
"ntfReceived=" <> strEncode _ntfReceived,
|
||||
"ntfReceivedAuth=" <> strEncode _ntfReceivedAuth,
|
||||
"ntfDelivered=" <> strEncode _ntfDelivered,
|
||||
"ntfFailed=" <> strEncode _ntfFailed,
|
||||
"ntfReceivedOwn=" <> strEncode _ntfReceivedOwn,
|
||||
"ntfReceivedAuthOwn=" <> strEncode _ntfReceivedAuthOwn,
|
||||
"ntfDeliveredOwn=" <> strEncode _ntfDeliveredOwn,
|
||||
"ntfFailedOwn=" <> strEncode _ntfFailedOwn,
|
||||
"ntfCronDelivered=" <> strEncode _ntfCronDelivered,
|
||||
"ntfCronFailed=" <> strEncode _ntfCronFailed,
|
||||
"ntfVrfQueued=" <> strEncode _ntfVrfQueued,
|
||||
"ntfVrfDelivered=" <> strEncode _ntfVrfDelivered,
|
||||
"ntfVrfFailed=" <> strEncode _ntfVrfFailed,
|
||||
"ntfVrfInvalidTkn=" <> strEncode _ntfVrfInvalidTkn,
|
||||
"activeTokens:",
|
||||
strEncode _activeTokens,
|
||||
"activeSubs:",
|
||||
@@ -259,75 +101,12 @@ instance StrEncoding NtfServerStatsData where
|
||||
_tknCreated <- "tknCreated=" *> strP <* A.endOfLine
|
||||
_tknVerified <- "tknVerified=" *> strP <* A.endOfLine
|
||||
_tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
|
||||
_tknReplaced <- opt "tknReplaced="
|
||||
_subCreated <- "subCreated=" *> strP <* A.endOfLine
|
||||
_subDeleted <- "subDeleted=" *> strP <* A.endOfLine
|
||||
_ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
|
||||
_ntfReceivedAuth <- opt "ntfReceivedAuth="
|
||||
_ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
|
||||
_ntfFailed <- opt "ntfFailed="
|
||||
_ntfReceivedOwn <- statByServerP "ntfReceivedOwn="
|
||||
_ntfReceivedAuthOwn <- statByServerP "ntfReceivedAuthOwn="
|
||||
_ntfDeliveredOwn <- statByServerP "ntfDeliveredOwn="
|
||||
_ntfFailedOwn <- statByServerP "ntfFailedOwn="
|
||||
_ntfCronDelivered <- opt "ntfCronDelivered="
|
||||
_ntfCronFailed <- opt "ntfCronFailed="
|
||||
_ntfVrfQueued <- opt "ntfVrfQueued="
|
||||
_ntfVrfDelivered <- opt "ntfVrfDelivered="
|
||||
_ntfVrfFailed <- opt "ntfVrfFailed="
|
||||
_ntfVrfInvalidTkn <- opt "ntfVrfInvalidTkn="
|
||||
_ <- "activeTokens:" <* A.endOfLine
|
||||
_activeTokens <- strP <* A.endOfLine
|
||||
_ <- "activeSubs:" <* A.endOfLine
|
||||
_activeSubs <- strP <* optional A.endOfLine
|
||||
pure
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfReceivedAuth,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfReceivedOwn,
|
||||
_ntfReceivedAuthOwn,
|
||||
_ntfDeliveredOwn,
|
||||
_ntfFailedOwn,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
}
|
||||
where
|
||||
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
|
||||
statByServerP s = A.string s *> strP <* A.endOfLine <|> pure (StatsByServerData [])
|
||||
|
||||
type StatsByServer = TMap Text (TVar Int)
|
||||
|
||||
newtype StatsByServerData = StatsByServerData [(Text, Int)]
|
||||
|
||||
instance StrEncoding StatsByServerData where
|
||||
strEncode (StatsByServerData d) = strEncodeList d
|
||||
strP = StatsByServerData <$> serverP `A.sepBy'` A.char ','
|
||||
where
|
||||
serverP = (,) <$> strP_ <*> A.decimal
|
||||
|
||||
getStatsByServer :: TMap Text (TVar Int) -> IO StatsByServerData
|
||||
getStatsByServer s = readTVarIO s >>= fmap (StatsByServerData . M.toList) . mapM readTVarIO
|
||||
|
||||
setStatsByServer :: TMap Text (TVar Int) -> StatsByServerData -> IO ()
|
||||
setStatsByServer s (StatsByServerData d) = mapM newTVarIO (M.fromList d) >>= atomically . writeTVar s
|
||||
|
||||
-- double lookup avoids STM transaction with a shared map in most cases
|
||||
incServerStat :: Text -> TMap Text (TVar Int) -> IO ()
|
||||
incServerStat h s = TM.lookupIO h s >>= atomically . maybe newServerStat (`modifyTVar'` (+ 1))
|
||||
where
|
||||
newServerStat = TM.lookup h s >>= maybe (TM.insertM h (newTVar 1) s) (`modifyTVar'` (+ 1))
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
|
||||
@@ -24,70 +24,71 @@ import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
|
||||
import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (whenM, ($>>=))
|
||||
|
||||
data NtfSTMStore = NtfSTMStore
|
||||
data NtfStore = NtfStore
|
||||
{ tokens :: TMap NtfTokenId NtfTknData,
|
||||
-- multiple registrations exist to protect from malicious registrations if token is compromised
|
||||
tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
|
||||
subscriptions :: TMap NtfSubscriptionId NtfSubData,
|
||||
tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
|
||||
subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
|
||||
tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData)),
|
||||
ntfServices :: TMap SMPServer ServiceId
|
||||
tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
|
||||
}
|
||||
|
||||
newNtfSTMStore :: IO NtfSTMStore
|
||||
newNtfSTMStore = do
|
||||
newNtfStore :: IO NtfStore
|
||||
newNtfStore = do
|
||||
tokens <- TM.emptyIO
|
||||
tokenRegistrations <- TM.emptyIO
|
||||
subscriptions <- TM.emptyIO
|
||||
tokenSubscriptions <- TM.emptyIO
|
||||
subscriptionLookup <- TM.emptyIO
|
||||
tokenLastNtfs <- TM.emptyIO
|
||||
ntfServices <- TM.emptyIO
|
||||
pure NtfSTMStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs, ntfServices}
|
||||
pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
|
||||
|
||||
data NtfTknData = NtfTknData
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
token :: DeviceToken,
|
||||
tknStatus :: TVar NtfTknStatus,
|
||||
tknVerifyKey :: NtfPublicAuthKey,
|
||||
tknDhKeys :: C.KeyPairX25519,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: TVar Word16,
|
||||
tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
|
||||
tknCronInterval :: TVar Word16
|
||||
}
|
||||
|
||||
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPairX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
|
||||
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
|
||||
tknStatus <- newTVarIO NTRegistered
|
||||
tknCronInterval <- newTVarIO 0
|
||||
tknUpdatedAt <- newTVarIO $ Just ts
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
|
||||
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
|
||||
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
|
||||
tknStatus <- newTVar NTRegistered
|
||||
tknCronInterval <- newTVar 0
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
data NtfSubData = NtfSubData
|
||||
{ ntfSubId :: NtfSubscriptionId,
|
||||
smpQueue :: SMPQueueNtf,
|
||||
notifierKey :: NtfPrivateAuthKey,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: TVar NtfSubStatus,
|
||||
ntfServiceAssoc :: TVar Bool
|
||||
subStatus :: TVar NtfSubStatus
|
||||
}
|
||||
|
||||
ntfSubServer :: NtfSubData -> SMPServer
|
||||
ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
|
||||
|
||||
stmGetNtfTokenIO :: NtfSTMStore -> NtfTokenId -> IO (Maybe NtfTknData)
|
||||
stmGetNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
|
||||
data NtfEntityRec (e :: NtfEntity) where
|
||||
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
|
||||
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
|
||||
|
||||
stmAddNtfToken :: NtfSTMStore -> NtfTokenId -> NtfTknData -> STM ()
|
||||
stmAddNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
|
||||
getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
|
||||
getNtfToken st tknId = TM.lookup tknId (tokens st)
|
||||
|
||||
getNtfTokenIO :: NtfStore -> NtfTokenId -> IO (Maybe NtfTknData)
|
||||
getNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
|
||||
|
||||
addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
|
||||
addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
|
||||
TM.insert tknId tkn $ tokens st
|
||||
TM.lookup token regs >>= \case
|
||||
Just tIds -> TM.insert regKey tknId tIds
|
||||
@@ -98,8 +99,16 @@ stmAddNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
|
||||
regs = tokenRegistrations st
|
||||
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
|
||||
|
||||
stmRemoveInactiveTokenRegistrations :: NtfSTMStore -> NtfTknData -> STM [NtfTokenId]
|
||||
stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
|
||||
getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
|
||||
getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
|
||||
TM.lookup token (tokenRegistrations st)
|
||||
$>>= TM.lookup regKey
|
||||
$>>= (`TM.lookup` tokens st)
|
||||
where
|
||||
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
|
||||
|
||||
removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
|
||||
removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
|
||||
TM.lookup token (tokenRegistrations st)
|
||||
>>= maybe (pure []) removeRegs
|
||||
where
|
||||
@@ -113,8 +122,8 @@ stmRemoveInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
|
||||
void $ deleteTokenSubs st tId'
|
||||
pure $ map snd tIds
|
||||
|
||||
stmRemoveTokenRegistration :: NtfSTMStore -> NtfTknData -> STM ()
|
||||
stmRemoveTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
|
||||
removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
|
||||
removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
|
||||
TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
|
||||
where
|
||||
removeReg regs =
|
||||
@@ -122,8 +131,8 @@ stmRemoveTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
|
||||
>>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
|
||||
k = C.toPubKey C.pubKeyBytes tknVerifyKey
|
||||
|
||||
stmDeleteNtfToken :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
|
||||
stmDeleteNtfToken st tknId = do
|
||||
deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
|
||||
deleteNtfToken st tknId = do
|
||||
void $
|
||||
TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} ->
|
||||
TM.lookup token regs $>>= \tIds ->
|
||||
@@ -135,7 +144,7 @@ stmDeleteNtfToken st tknId = do
|
||||
regs = tokenRegistrations st
|
||||
regKey = C.toPubKey C.pubKeyBytes
|
||||
|
||||
deleteTokenSubs :: NtfSTMStore -> NtfTokenId -> STM [SMPQueueNtf]
|
||||
deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
|
||||
deleteTokenSubs st tknId = do
|
||||
qs <-
|
||||
TM.lookupDelete tknId (tokenSubscriptions st)
|
||||
@@ -147,11 +156,33 @@ deleteTokenSubs st tknId = do
|
||||
$>>= \NtfSubData {smpQueue} ->
|
||||
TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
|
||||
|
||||
stmGetNtfSubscriptionIO :: NtfSTMStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
|
||||
stmGetNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
|
||||
getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
|
||||
getNtfSubscription st subId =
|
||||
TM.lookup subId (subscriptions st)
|
||||
|
||||
stmAddNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
|
||||
stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
|
||||
findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
|
||||
findNtfSubscription st smpQueue = do
|
||||
TM.lookup smpQueue (subscriptionLookup st)
|
||||
$>>= \subId -> TM.lookup subId (subscriptions st)
|
||||
|
||||
findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
|
||||
findNtfSubscriptionToken st smpQueue = do
|
||||
findNtfSubscription st smpQueue
|
||||
$>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
|
||||
|
||||
getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
|
||||
getActiveNtfToken st tknId =
|
||||
getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
|
||||
tStatus <- readTVar tknStatus
|
||||
pure $ if tStatus == NTActive then Just tkn else Nothing
|
||||
|
||||
mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
|
||||
mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
|
||||
subStatus <- newTVar NSNew
|
||||
pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
|
||||
|
||||
addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
|
||||
addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
|
||||
TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
|
||||
where
|
||||
newTokenSub = do
|
||||
@@ -165,8 +196,8 @@ stmAddNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
|
||||
-- return Nothing if subscription existed before
|
||||
pure $ Just ()
|
||||
|
||||
stmDeleteNtfSubscription :: NtfSTMStore -> NtfSubscriptionId -> STM ()
|
||||
stmDeleteNtfSubscription st subId = do
|
||||
deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
|
||||
deleteNtfSubscription st subId = do
|
||||
TM.lookupDelete subId (subscriptions st)
|
||||
>>= mapM_
|
||||
( \NtfSubData {smpQueue, tokenId} -> do
|
||||
@@ -175,10 +206,32 @@ stmDeleteNtfSubscription st subId = do
|
||||
forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
|
||||
)
|
||||
|
||||
addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData)
|
||||
addTokenLastNtf st tknId newNtf =
|
||||
TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf)
|
||||
where
|
||||
maybeNewTokenLastNtfs =
|
||||
TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf
|
||||
newTokenLastNtfs = do
|
||||
v <- newTVar [newNtf]
|
||||
TM.insert tknId v $ tokenLastNtfs st
|
||||
pure [newNtf]
|
||||
addNtf v =
|
||||
stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs')
|
||||
where
|
||||
rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData
|
||||
rebuildList = foldr keepPrevNtf [newNtf]
|
||||
where
|
||||
PNMessageData {smpQueue = newNtfQ} = newNtf
|
||||
keepPrevNtf ntf@PNMessageData {smpQueue} ntfs
|
||||
| smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs
|
||||
| otherwise = ntfs
|
||||
maxNtfs = 6
|
||||
|
||||
-- This function is expected to be called after store log is read,
|
||||
-- as it checks for token existence when adding last notification.
|
||||
stmStoreTokenLastNtf :: NtfSTMStore -> NtfTokenId -> PNMessageData -> IO ()
|
||||
stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
|
||||
storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO ()
|
||||
storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do
|
||||
TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|))
|
||||
where
|
||||
newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|))
|
||||
@@ -186,10 +239,6 @@ stmStoreTokenLastNtf (NtfSTMStore {tokens, tokenLastNtfs}) tknId ntf = do
|
||||
whenM (TM.member tknId tokens) $
|
||||
TM.insertM tknId (newTVar [ntf]) tokenLastNtfs
|
||||
|
||||
stmSetNtfService :: NtfSTMStore -> SMPServer -> Maybe ServiceId -> STM ()
|
||||
stmSetNtfService (NtfSTMStore {ntfServices}) srv serviceId =
|
||||
maybe (TM.delete srv) (TM.insert srv) serviceId ntfServices
|
||||
|
||||
data TokenNtfMessageRecord = TNMRv1 NtfTokenId PNMessageData
|
||||
|
||||
instance StrEncoding TokenNtfMessageRecord where
|
||||
|
||||
@@ -1,106 +0,0 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Store.Migrations where
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Messaging.Agent.Store.Shared
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
ntfServerSchemaMigrations :: [(String, Text, Maybe Text)]
|
||||
ntfServerSchemaMigrations =
|
||||
[ ("20250417_initial", m20250417_initial, Nothing),
|
||||
("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
ntfServerMigrations :: [Migration]
|
||||
ntfServerMigrations = sortOn name $ map migration ntfServerSchemaMigrations
|
||||
where
|
||||
migration (name, up, down) = Migration {name, up, down = down}
|
||||
|
||||
m20250417_initial :: Text
|
||||
m20250417_initial =
|
||||
T.pack
|
||||
[r|
|
||||
CREATE TABLE tokens(
|
||||
token_id BYTEA NOT NULL,
|
||||
push_provider TEXT NOT NULL,
|
||||
push_provider_token BYTEA NOT NULL,
|
||||
status TEXT NOT NULL,
|
||||
verify_key BYTEA NOT NULL,
|
||||
dh_priv_key BYTEA NOT NULL,
|
||||
dh_secret BYTEA NOT NULL,
|
||||
reg_code BYTEA NOT NULL,
|
||||
cron_interval BIGINT NOT NULL, -- minutes
|
||||
cron_sent_at BIGINT, -- seconds
|
||||
updated_at BIGINT,
|
||||
PRIMARY KEY (token_id)
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_tokens_push_provider_token ON tokens(push_provider, push_provider_token, verify_key);
|
||||
CREATE INDEX idx_tokens_status_cron_interval_sent_at ON tokens(status, cron_interval, (cron_sent_at + cron_interval * 60));
|
||||
|
||||
CREATE TABLE smp_servers(
|
||||
smp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
smp_host TEXT NOT NULL,
|
||||
smp_port TEXT NOT NULL,
|
||||
smp_keyhash BYTEA NOT NULL
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_smp_servers ON smp_servers(smp_host, smp_port, smp_keyhash);
|
||||
|
||||
CREATE TABLE subscriptions(
|
||||
subscription_id BYTEA NOT NULL,
|
||||
token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
|
||||
smp_server_id BIGINT REFERENCES smp_servers ON DELETE RESTRICT ON UPDATE RESTRICT,
|
||||
smp_notifier_id BYTEA NOT NULL,
|
||||
smp_notifier_key BYTEA NOT NULL,
|
||||
status TEXT NOT NULL,
|
||||
PRIMARY KEY (subscription_id)
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON subscriptions(smp_server_id, smp_notifier_id);
|
||||
CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
|
||||
CREATE INDEX idx_subscriptions_token_id ON subscriptions(token_id);
|
||||
|
||||
CREATE TABLE last_notifications(
|
||||
token_ntf_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
token_id BYTEA NOT NULL REFERENCES tokens ON DELETE CASCADE ON UPDATE RESTRICT,
|
||||
subscription_id BYTEA NOT NULL REFERENCES subscriptions ON DELETE CASCADE ON UPDATE RESTRICT,
|
||||
sent_at TIMESTAMPTZ NOT NULL,
|
||||
nmsg_nonce BYTEA NOT NULL,
|
||||
nmsg_data BYTEA NOT NULL
|
||||
);
|
||||
|
||||
CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token_id, sent_at);
|
||||
CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id);
|
||||
|
||||
CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id);
|
||||
|]
|
||||
|
||||
m20250517_service_cert :: Text
|
||||
m20250517_service_cert =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE smp_servers ADD COLUMN ntf_service_id BYTEA;
|
||||
|
||||
ALTER TABLE subscriptions ADD COLUMN ntf_service_assoc BOOLEAN NOT NULL DEFAULT FALSE;
|
||||
|
||||
DROP INDEX idx_subscriptions_smp_server_id_status;
|
||||
CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON subscriptions(smp_server_id, ntf_service_assoc, status);
|
||||
|]
|
||||
|
||||
down_m20250517_service_cert :: Text
|
||||
down_m20250517_service_cert =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_subscriptions_smp_server_id_ntf_service_status;
|
||||
CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_id, status);
|
||||
|
||||
ALTER TABLE smp_servers DROP COLUMN ntf_service_id;
|
||||
|
||||
ALTER TABLE subscriptions DROP COLUMN ntf_service_assoc;
|
||||
|]
|
||||
@@ -1,931 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Store.Postgres where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable (bimapM)
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Containers.ListUtils (nubOrd)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (findIndex, foldl')
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime, utcToSystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), Query, ToRow, (:.) (..))
|
||||
import qualified Database.PostgreSQL.Simple as DB
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Agent.Store.AgentStore ()
|
||||
import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Common
|
||||
import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Migrations
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (EntityId (..), EncNMsgMeta, ErrorType (..), NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer, ServiceId, pattern SMPServer)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres (handleDuplicate, withLog_)
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
|
||||
import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (anyM, firstRow, maybeFirstRow, toChunks, tshow)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (IOMode (..), hFlush, stdout, withFile)
|
||||
import Text.Hex (decodeHex)
|
||||
|
||||
#if !defined(dbPostgres)
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
#endif
|
||||
|
||||
data NtfPostgresStore = NtfPostgresStore
|
||||
{ dbStore :: DBStore,
|
||||
dbStoreLog :: Maybe (StoreLog 'WriteMode),
|
||||
deletedTTL :: Int64
|
||||
}
|
||||
|
||||
mkNtfTknRec :: NtfTokenId -> NewNtfEntity 'Token -> C.PrivateKeyX25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> NtfTknRec
|
||||
mkNtfTknRec ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhPrivKey tknDhSecret tknRegCode ts =
|
||||
NtfTknRec {ntfTknId, token, tknStatus = NTRegistered, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval = 0, tknUpdatedAt = Just ts}
|
||||
|
||||
ntfSubServer' :: NtfSubRec -> SMPServer
|
||||
ntfSubServer' NtfSubRec {smpQueue = SMPQueueNtf {smpServer}} = smpServer
|
||||
|
||||
data NtfEntityRec (e :: NtfEntity) where
|
||||
NtfTkn :: NtfTknRec -> NtfEntityRec 'Token
|
||||
NtfSub :: NtfSubRec -> NtfEntityRec 'Subscription
|
||||
|
||||
newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
|
||||
newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
|
||||
dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
|
||||
dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
|
||||
pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
|
||||
where
|
||||
err e = do
|
||||
logError $ "STORE: newNtfStore, error opening PostgreSQL database, " <> tshow e
|
||||
exitFailure
|
||||
|
||||
closeNtfDbStore :: NtfPostgresStore -> IO ()
|
||||
closeNtfDbStore NtfPostgresStore {dbStore, dbStoreLog} = do
|
||||
closeDBStore dbStore
|
||||
mapM_ closeStoreLog dbStoreLog
|
||||
|
||||
addNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
|
||||
addNtfToken st tkn =
|
||||
withFastDB "addNtfToken" st $ \db ->
|
||||
E.try (DB.execute db insertNtfTknQuery $ ntfTknToRow tkn)
|
||||
>>= bimapM handleDuplicate (\_ -> withLog "addNtfToken" st (`logCreateToken` tkn))
|
||||
|
||||
insertNtfTknQuery :: Query
|
||||
insertNtfTknQuery =
|
||||
[sql|
|
||||
INSERT INTO tokens
|
||||
(token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
|
||||
replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
|
||||
replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} =
|
||||
withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do
|
||||
ExceptT $ assertUpdated <$>
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE tokens
|
||||
SET push_provider = ?, push_provider_token = ?, status = ?, reg_code = ?
|
||||
WHERE token_id = ?
|
||||
|]
|
||||
(pp, Binary ppToken, tknStatus, Binary regCode, ntfTknId)
|
||||
withLog "replaceNtfToken" st $ \sl -> logUpdateToken sl ntfTknId token code
|
||||
|
||||
ntfTknToRow :: NtfTknRec -> NtfTknRow
|
||||
ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
|
||||
let DeviceToken pp ppToken = token
|
||||
NtfRegCode regCode = tknRegCode
|
||||
in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)
|
||||
|
||||
getNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType NtfTknRec)
|
||||
getNtfToken st tknId =
|
||||
(maybe (Left AUTH) Right =<<) <$>
|
||||
getNtfToken_ st " WHERE token_id = ?" (Only tknId)
|
||||
|
||||
findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec))
|
||||
findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) =
|
||||
getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey)
|
||||
|
||||
getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec))
|
||||
getNtfToken_ st cond params =
|
||||
withFastDB' "getNtfToken" st $ \db -> do
|
||||
tkn_ <- maybeFirstRow rowToNtfTkn $ DB.query db (ntfTknQuery <> cond) params
|
||||
mapM_ (updateTokenDate st db) tkn_
|
||||
pure tkn_
|
||||
|
||||
updateTokenDate :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> IO ()
|
||||
updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do
|
||||
ts <- getSystemDate
|
||||
when (maybe True (ts /=) tknUpdatedAt) $ do
|
||||
void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId)
|
||||
withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts
|
||||
|
||||
type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe RoundedSystemTime)
|
||||
|
||||
ntfTknQuery :: Query
|
||||
ntfTknQuery =
|
||||
[sql|
|
||||
SELECT token_id, push_provider, push_provider_token, status, verify_key, dh_priv_key, dh_secret, reg_code, cron_interval, updated_at
|
||||
FROM tokens
|
||||
|]
|
||||
|
||||
rowToNtfTkn :: NtfTknRow -> NtfTknRec
|
||||
rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) =
|
||||
let token = DeviceToken pp ppToken
|
||||
tknRegCode = NtfRegCode regCode
|
||||
in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
|
||||
|
||||
deleteNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType [(SMPServer, [NotifierId])])
|
||||
deleteNtfToken st tknId =
|
||||
withFastDB "deleteNtfToken" st $ \db -> runExceptT $ do
|
||||
-- This SELECT obtains exclusive lock on token row and prevents any inserts
|
||||
-- into other tables for this token ID until the deletion completes.
|
||||
_ <- ExceptT $ firstRow (fromOnly @Int) AUTH $
|
||||
DB.query db "SELECT 1 FROM tokens WHERE token_id = ? FOR UPDATE" (Only tknId)
|
||||
subs <-
|
||||
liftIO $ map toServerSubs <$>
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT p.smp_host, p.smp_port, p.smp_keyhash,
|
||||
string_agg(s.smp_notifier_id :: TEXT, ',') AS notifier_ids
|
||||
FROM smp_servers p
|
||||
JOIN subscriptions s ON s.smp_server_id = p.smp_server_id
|
||||
WHERE s.token_id = ?
|
||||
GROUP BY p.smp_host, p.smp_port, p.smp_keyhash;
|
||||
|]
|
||||
(Only tknId)
|
||||
liftIO $ void $ DB.execute db "DELETE FROM tokens WHERE token_id = ?" (Only tknId)
|
||||
withLog "deleteNtfToken" st (`logDeleteToken` tknId)
|
||||
pure subs
|
||||
where
|
||||
toServerSubs :: SMPServerRow :. Only Text -> (SMPServer, [NotifierId])
|
||||
toServerSubs (srv :. Only nIdsStr) = (rowToSrv srv, parseByteaString nIdsStr)
|
||||
parseByteaString :: Text -> [NotifierId]
|
||||
parseByteaString s = mapMaybe (fmap EntityId . decodeHex . T.drop 2) $ T.splitOn "," s -- drop 2 to remove "\\x"
|
||||
|
||||
type SMPServerRow = (NonEmpty TransportHost, ServiceName, C.KeyHash)
|
||||
|
||||
type SMPQueueNtfRow = (NonEmpty TransportHost, ServiceName, C.KeyHash, NotifierId)
|
||||
|
||||
rowToSrv :: SMPServerRow -> SMPServer
|
||||
rowToSrv (host, port, kh) = SMPServer host port kh
|
||||
|
||||
srvToRow :: SMPServer -> SMPServerRow
|
||||
srvToRow (SMPServer host port kh) = (host, port, kh)
|
||||
|
||||
smpQueueToRow :: SMPQueueNtf -> SMPQueueNtfRow
|
||||
smpQueueToRow (SMPQueueNtf (SMPServer host port kh) nId) = (host, port, kh, nId)
|
||||
|
||||
rowToSMPQueue :: SMPQueueNtfRow -> SMPQueueNtf
|
||||
rowToSMPQueue (host, port, kh, nId) = SMPQueueNtf (SMPServer host port kh) nId
|
||||
|
||||
updateTknCronInterval :: NtfPostgresStore -> NtfTokenId -> Word16 -> IO (Either ErrorType ())
|
||||
updateTknCronInterval st tknId cronInt =
|
||||
withFastDB "updateTknCronInterval" st $ \db -> runExceptT $ do
|
||||
ExceptT $ assertUpdated <$>
|
||||
DB.execute db "UPDATE tokens SET cron_interval = ? WHERE token_id = ?" (cronInt, tknId)
|
||||
withLog "updateTknCronInterval" st $ \sl -> logTokenCron sl tknId 0
|
||||
|
||||
-- Reads servers that have subscriptions that need subscribing.
|
||||
-- It is executed on server start, and it is supposed to crash on database error
|
||||
getUsedSMPServers :: NtfPostgresStore -> IO [(SMPServer, Int64, Maybe (ServiceId, Int64))]
|
||||
getUsedSMPServers st =
|
||||
withTransaction (dbStore st) $ \db ->
|
||||
map rowToSrvSubs <$>
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
p.smp_host, p.smp_port, p.smp_keyhash, p.smp_server_id, p.ntf_service_id,
|
||||
SUM(CASE WHEN s.ntf_service_assoc THEN s.subs_count ELSE 0 END) :: BIGINT as service_subs_count
|
||||
FROM smp_servers p
|
||||
JOIN (
|
||||
SELECT
|
||||
smp_server_id,
|
||||
ntf_service_assoc,
|
||||
COUNT(1) as subs_count
|
||||
FROM subscriptions
|
||||
WHERE status IN ?
|
||||
GROUP BY smp_server_id, ntf_service_assoc
|
||||
) s ON s.smp_server_id = p.smp_server_id
|
||||
GROUP BY p.smp_host, p.smp_port, p.smp_keyhash, p.smp_server_id, p.ntf_service_id
|
||||
|]
|
||||
(Only (In [NSNew, NSPending, NSActive, NSInactive]))
|
||||
where
|
||||
rowToSrvSubs :: SMPServerRow :. (Int64, Maybe ServiceId, Int64) -> (SMPServer, Int64, Maybe (ServiceId, Int64))
|
||||
rowToSrvSubs ((host, port, kh) :. (srvId, serviceId_, subsCount)) =
|
||||
(SMPServer host port kh, srvId, (,subsCount) <$> serviceId_)
|
||||
|
||||
getServerNtfSubscriptions :: NtfPostgresStore -> Int64 -> Maybe NtfSubscriptionId -> Int -> IO (Either ErrorType [ServerNtfSub])
|
||||
getServerNtfSubscriptions st srvId afterSubId_ count =
|
||||
withDB' "getServerNtfSubscriptions" st $ \db -> do
|
||||
subs <-
|
||||
map toServerNtfSub <$> case afterSubId_ of
|
||||
Nothing ->
|
||||
DB.query db (query <> orderLimit) (srvId, statusIn, count)
|
||||
Just afterSubId ->
|
||||
DB.query db (query <> " AND subscription_id > ?" <> orderLimit) (srvId, statusIn, afterSubId, count)
|
||||
void $
|
||||
DB.executeMany
|
||||
db
|
||||
[sql|
|
||||
UPDATE subscriptions s
|
||||
SET status = upd.status
|
||||
FROM (VALUES(?, ?)) AS upd(status, subscription_id)
|
||||
WHERE s.subscription_id = (upd.subscription_id :: BYTEA)
|
||||
AND s.status != upd.status
|
||||
|]
|
||||
(map ((NSPending,) . fst) subs)
|
||||
pure subs
|
||||
where
|
||||
query =
|
||||
[sql|
|
||||
SELECT subscription_id, smp_notifier_id, smp_notifier_key
|
||||
FROM subscriptions
|
||||
WHERE smp_server_id = ? AND NOT ntf_service_assoc AND status IN ?
|
||||
|]
|
||||
orderLimit = " ORDER BY subscription_id LIMIT ?"
|
||||
statusIn = In [NSNew, NSPending, NSActive, NSInactive]
|
||||
toServerNtfSub (ntfSubId, notifierId, notifierKey) = (ntfSubId, (notifierId, notifierKey))
|
||||
|
||||
-- Returns token and subscription.
|
||||
-- If subscription exists but belongs to another token, returns Left AUTH
|
||||
findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec))
|
||||
findNtfSubscription st tknId q =
|
||||
withFastDB "findNtfSubscription" st $ \db -> runExceptT $ do
|
||||
tkn@NtfTknRec {ntfTknId, tknStatus} <- ExceptT $ getNtfToken st tknId
|
||||
unless (allowNtfSubCommands tknStatus) $ throwE AUTH
|
||||
liftIO $ updateTokenDate st db tkn
|
||||
sub_ <-
|
||||
liftIO $ maybeFirstRow (rowToNtfSub q) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc
|
||||
FROM subscriptions s
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ?
|
||||
AND s.smp_notifier_id = ?
|
||||
|]
|
||||
(smpQueueToRow q)
|
||||
forM_ sub_ $ \NtfSubRec {tokenId} -> unless (ntfTknId == tokenId) $ throwE AUTH
|
||||
pure (tkn, sub_)
|
||||
|
||||
getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec))
|
||||
getNtfSubscription st subId =
|
||||
withFastDB "getNtfSubscription" st $ \db -> runExceptT $ do
|
||||
r@(tkn@NtfTknRec {tknStatus}, _) <-
|
||||
ExceptT $ firstRow rowToNtfTknSub AUTH $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at,
|
||||
s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc,
|
||||
p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id
|
||||
FROM subscriptions s
|
||||
JOIN tokens t ON t.token_id = s.token_id
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
WHERE s.subscription_id = ?
|
||||
|]
|
||||
(Only subId)
|
||||
liftIO $ updateTokenDate st db tkn
|
||||
unless (allowNtfSubCommands tknStatus) $ throwE AUTH
|
||||
pure r
|
||||
|
||||
type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus, NtfAssociatedService)
|
||||
|
||||
rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec)
|
||||
rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow) =
|
||||
let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow
|
||||
smpQueue = rowToSMPQueue qRow
|
||||
in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc})
|
||||
|
||||
rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec
|
||||
rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc)) =
|
||||
NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
|
||||
|
||||
mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec
|
||||
mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) =
|
||||
NtfSubRec {ntfSubId, tokenId, smpQueue, subStatus = NSNew, notifierKey, ntfServiceAssoc = False}
|
||||
|
||||
updateTknStatus :: NtfPostgresStore -> NtfTknRec -> NtfTknStatus -> IO (Either ErrorType ())
|
||||
updateTknStatus st tkn status =
|
||||
withFastDB' "updateTknStatus" st $ \db -> updateTknStatus_ st db tkn status
|
||||
|
||||
updateTknStatus_ :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> NtfTknStatus -> IO ()
|
||||
updateTknStatus_ st db NtfTknRec {ntfTknId} status = do
|
||||
updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ?" (status, ntfTknId, status)
|
||||
when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId status
|
||||
|
||||
-- unless it was already active
|
||||
setTknStatusConfirmed :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
|
||||
setTknStatusConfirmed st NtfTknRec {ntfTknId} =
|
||||
withFastDB' "updateTknStatus" st $ \db -> do
|
||||
updated <- DB.execute db "UPDATE tokens SET status = ? WHERE token_id = ? AND status != ? AND status != ?" (NTConfirmed, ntfTknId, NTConfirmed, NTActive)
|
||||
when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed
|
||||
|
||||
setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
|
||||
setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} =
|
||||
withFastDB' "setTokenActive" st $ \db -> do
|
||||
updateTknStatus_ st db tkn NTActive
|
||||
-- this removes other instances of the same token, e.g. because of repeated token registration attempts
|
||||
tknIds <-
|
||||
liftIO $ map fromOnly <$>
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM tokens
|
||||
WHERE push_provider = ? AND push_provider_token = ? AND token_id != ?
|
||||
RETURNING token_id
|
||||
|]
|
||||
(pp, Binary ppToken, ntfTknId)
|
||||
withLog "deleteNtfToken" st $ \sl -> mapM_ (logDeleteToken sl) tknIds
|
||||
|
||||
withPeriodicNtfTokens :: NtfPostgresStore -> Int64 -> (NtfTknRec -> IO ()) -> IO Int
|
||||
withPeriodicNtfTokens st now notify =
|
||||
fmap (fromRight 0) $ withDB' "withPeriodicNtfTokens" st $ \db ->
|
||||
DB.fold db (ntfTknQuery <> " WHERE status = ? AND cron_interval != 0 AND (cron_sent_at + cron_interval * 60) < ?") (NTActive, now) 0 $ \ !n row -> do
|
||||
notify (rowToNtfTkn row) $> (n + 1)
|
||||
|
||||
updateTokenCronSentAt :: NtfPostgresStore -> NtfTokenId -> Int64 -> IO (Either ErrorType ())
|
||||
updateTokenCronSentAt st tknId now =
|
||||
withDB' "updateTokenCronSentAt" st $ \db ->
|
||||
void $ DB.execute db "UPDATE tokens t SET cron_sent_at = ? WHERE token_id = ?" (now, tknId)
|
||||
|
||||
addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType (Int64, Bool))
|
||||
addNtfSubscription st sub =
|
||||
withFastDB "addNtfSubscription" st $ \db -> runExceptT $ do
|
||||
srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub
|
||||
n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub
|
||||
withLog "addNtfSubscription" st (`logCreateSubscription` sub)
|
||||
pure (srvId, n > 0)
|
||||
where
|
||||
-- It is possible to combine these two statements into one with CTEs,
|
||||
-- to reduce roundtrips in case of `insert`, but it would be making 2 queries in all cases.
|
||||
-- With 2 statements it will succeed on the first `select` in most cases.
|
||||
upsertServer db srv = getServer >>= maybe insertServer (pure . Right)
|
||||
where
|
||||
getServer =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT smp_server_id
|
||||
FROM smp_servers
|
||||
WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
|
||||
|]
|
||||
(srvToRow srv)
|
||||
insertServer =
|
||||
firstRow fromOnly (STORE "error inserting SMP server when adding subscription") $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?)
|
||||
ON CONFLICT (smp_host, smp_port, smp_keyhash)
|
||||
DO UPDATE SET smp_host = EXCLUDED.smp_host
|
||||
RETURNING smp_server_id
|
||||
|]
|
||||
(srvToRow srv)
|
||||
|
||||
insertNtfSubQuery :: Query
|
||||
insertNtfSubQuery =
|
||||
[sql|
|
||||
INSERT INTO subscriptions (token_id, smp_server_id, smp_notifier_id, subscription_id, smp_notifier_key, status, ntf_service_assoc)
|
||||
VALUES (?,?,?,?,?,?,?)
|
||||
|]
|
||||
|
||||
ntfSubToRow :: Int64 -> NtfSubRec -> (NtfTokenId, Int64, NotifierId) :. NtfSubRow
|
||||
ntfSubToRow srvId NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf _ nId, notifierKey, subStatus, ntfServiceAssoc} =
|
||||
(tokenId, srvId, nId) :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc)
|
||||
|
||||
deleteNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType ())
|
||||
deleteNtfSubscription st subId =
|
||||
withFastDB "deleteNtfSubscription" st $ \db -> runExceptT $ do
|
||||
ExceptT $ assertUpdated <$>
|
||||
DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId)
|
||||
withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId)
|
||||
|
||||
updateSubStatus :: NtfPostgresStore -> Int64 -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ())
|
||||
updateSubStatus st srvId nId status =
|
||||
withFastDB' "updateSubStatus" st $ \db -> do
|
||||
sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
UPDATE subscriptions SET status = ?
|
||||
WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ?
|
||||
RETURNING subscription_id, ntf_service_assoc
|
||||
|]
|
||||
(status, srvId, nId, status)
|
||||
forM_ sub_ $ \(subId, serviceAssoc) ->
|
||||
withLog "updateSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
|
||||
|
||||
updateSrvSubStatus :: NtfPostgresStore -> SMPQueueNtf -> NtfSubStatus -> IO (Either ErrorType ())
|
||||
updateSrvSubStatus st q status =
|
||||
withFastDB' "updateSrvSubStatus" st $ \db -> do
|
||||
sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <-
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
UPDATE subscriptions s
|
||||
SET status = ?
|
||||
FROM smp_servers p
|
||||
WHERE p.smp_server_id = s.smp_server_id
|
||||
AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ?
|
||||
AND s.status != ?
|
||||
RETURNING s.subscription_id, s.ntf_service_assoc
|
||||
|]
|
||||
(Only status :. smpQueueToRow q :. Only status)
|
||||
forM_ sub_ $ \(subId, serviceAssoc) ->
|
||||
withLog "updateSrvSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc)
|
||||
|
||||
batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> Maybe ServiceId -> NonEmpty NotifierId -> NtfSubStatus -> IO Int
|
||||
batchUpdateSrvSubStatus st srv newServiceId nIds status =
|
||||
fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubStatus" st $ \db -> runExceptT $ do
|
||||
(srvId :: Int64, currServiceId) <- ExceptT $ getSMPServerService db
|
||||
unless (currServiceId == newServiceId) $ liftIO $ void $
|
||||
DB.execute db "UPDATE smp_servers SET ntf_service_id = ? WHERE smp_server_id = ?" (newServiceId, srvId)
|
||||
let params = L.toList $ L.map (srvId,isJust newServiceId,status,) nIds
|
||||
liftIO $ fromIntegral <$> DB.executeMany db updateSubStatusQuery params
|
||||
where
|
||||
getSMPServerService db =
|
||||
firstRow id AUTH $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT smp_server_id, ntf_service_id
|
||||
FROM smp_servers
|
||||
WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
|
||||
FOR UPDATE
|
||||
|]
|
||||
(srvToRow srv)
|
||||
|
||||
batchUpdateSrvSubErrors :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int
|
||||
batchUpdateSrvSubErrors st srv subs =
|
||||
fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubErrors" st $ \db -> runExceptT $ do
|
||||
srvId :: Int64 <- ExceptT $ getSMPServerId db
|
||||
let params = map (\(nId, status) -> (srvId, False, status, nId)) $ L.toList subs
|
||||
subs' <- liftIO $ DB.returning db (updateSubStatusQuery <> " RETURNING s.subscription_id, s.status, s.ntf_service_assoc") params
|
||||
withLog "batchUpdateStatus_" st $ forM_ subs' . logSubscriptionStatus
|
||||
pure $ length subs'
|
||||
where
|
||||
getSMPServerId db =
|
||||
firstRow fromOnly AUTH $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT smp_server_id
|
||||
FROM smp_servers
|
||||
WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
|
||||
|]
|
||||
(srvToRow srv)
|
||||
|
||||
updateSubStatusQuery :: Query
|
||||
updateSubStatusQuery =
|
||||
[sql|
|
||||
UPDATE subscriptions s
|
||||
SET status = upd.status, ntf_service_assoc = upd.ntf_service_assoc
|
||||
FROM (VALUES(?, ?, ?, ?)) AS upd(smp_server_id, ntf_service_assoc, status, smp_notifier_id)
|
||||
WHERE s.smp_server_id = upd.smp_server_id
|
||||
AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA)
|
||||
AND (s.status != upd.status OR s.ntf_service_assoc != upd.ntf_service_assoc)
|
||||
|]
|
||||
|
||||
removeServiceAssociation :: NtfPostgresStore -> SMPServer -> IO (Either ErrorType (Int64, Int))
|
||||
removeServiceAssociation st srv = do
|
||||
withDB "removeServiceAssociation" st $ \db -> runExceptT $ do
|
||||
srvId <- ExceptT $ removeServerService db
|
||||
subs <-
|
||||
liftIO $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
UPDATE subscriptions s
|
||||
SET status = ?, ntf_service_assoc = FALSE
|
||||
WHERE smp_server_id = ?
|
||||
AND (s.status != ? OR s.ntf_service_assoc != FALSE)
|
||||
RETURNING s.subscription_id, s.status, s.ntf_service_assoc
|
||||
|]
|
||||
(NSInactive, srvId, NSInactive)
|
||||
withLog "removeServiceAssociation" st $ forM_ subs . logSubscriptionStatus
|
||||
pure (srvId, length subs)
|
||||
where
|
||||
removeServerService db =
|
||||
firstRow fromOnly AUTH $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
UPDATE smp_servers
|
||||
SET ntf_service_id = NULL
|
||||
WHERE smp_host = ? AND smp_port = ? AND smp_keyhash = ?
|
||||
RETURNING smp_server_id
|
||||
|]
|
||||
(srvToRow srv)
|
||||
|
||||
addTokenLastNtf :: NtfPostgresStore -> PNMessageData -> IO (Either ErrorType (NtfTknRec, NonEmpty PNMessageData))
|
||||
addTokenLastNtf st newNtf =
|
||||
withFastDB "addTokenLastNtf" st $ \db -> runExceptT $ do
|
||||
(tkn@NtfTknRec {ntfTknId = tId, tknStatus}, sId) <-
|
||||
ExceptT $ firstRow toTokenSubId AUTH $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at,
|
||||
s.subscription_id
|
||||
FROM tokens t
|
||||
JOIN subscriptions s ON s.token_id = t.token_id
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? AND s.smp_notifier_id = ?
|
||||
FOR UPDATE OF t, s
|
||||
|]
|
||||
(smpQueueToRow q)
|
||||
unless (tknStatus == NTActive) $ throwE AUTH
|
||||
lastNtfs_ <-
|
||||
liftIO $ map toLastNtf <$>
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
WITH new AS (
|
||||
INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data)
|
||||
VALUES (?,?,?,?,?)
|
||||
ON CONFLICT (token_id, subscription_id)
|
||||
DO UPDATE SET
|
||||
sent_at = EXCLUDED.sent_at,
|
||||
nmsg_nonce = EXCLUDED.nmsg_nonce,
|
||||
nmsg_data = EXCLUDED.nmsg_data
|
||||
RETURNING subscription_id, sent_at, nmsg_nonce, nmsg_data
|
||||
),
|
||||
last AS (
|
||||
SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data
|
||||
FROM last_notifications
|
||||
WHERE token_id = ? AND subscription_id != (SELECT subscription_id FROM new)
|
||||
UNION
|
||||
SELECT subscription_id, sent_at, nmsg_nonce, nmsg_data
|
||||
FROM new
|
||||
ORDER BY sent_at DESC
|
||||
LIMIT ?
|
||||
),
|
||||
delete AS (
|
||||
DELETE FROM last_notifications
|
||||
WHERE token_id = ?
|
||||
AND sent_at < (SELECT min(sent_at) FROM last)
|
||||
)
|
||||
SELECT p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id,
|
||||
l.sent_at, l.nmsg_nonce, l.nmsg_data
|
||||
FROM last l
|
||||
JOIN subscriptions s ON s.subscription_id = l.subscription_id
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
ORDER BY sent_at ASC
|
||||
|]
|
||||
(tId, sId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta, tId, maxNtfs, tId)
|
||||
let lastNtfs = fromMaybe (newNtf :| []) (L.nonEmpty lastNtfs_)
|
||||
pure (tkn, lastNtfs)
|
||||
where
|
||||
maxNtfs = 6 :: Int
|
||||
PNMessageData {smpQueue = q, ntfTs, nmsgNonce, encNMsgMeta} = newNtf
|
||||
toTokenSubId :: NtfTknRow :. Only NtfSubscriptionId -> (NtfTknRec, NtfSubscriptionId)
|
||||
toTokenSubId (tknRow :. Only sId) = (rowToNtfTkn tknRow, sId)
|
||||
|
||||
toLastNtf :: SMPQueueNtfRow :. (UTCTime, C.CbNonce, Binary EncNMsgMeta) -> PNMessageData
|
||||
toLastNtf (qRow :. (ts, nonce, Binary encMeta)) =
|
||||
let ntfTs = MkSystemTime (systemSeconds $ utcToSystemTime ts) 0
|
||||
in PNMessageData {smpQueue = rowToSMPQueue qRow, ntfTs, nmsgNonce = nonce, encNMsgMeta = encMeta}
|
||||
|
||||
getEntityCounts :: NtfPostgresStore -> IO (Int64, Int64, Int64)
|
||||
getEntityCounts st =
|
||||
fmap (fromRight (0, 0, 0)) $ withDB' "getEntityCounts" st $ \db -> do
|
||||
tCnt <- count <$> DB.query_ db "SELECT count(1) FROM tokens"
|
||||
sCnt <- count <$> DB.query_ db "SELECT reltuples::BIGINT FROM pg_class WHERE relname = 'subscriptions' AND relkind = 'r'"
|
||||
nCnt <- count <$> DB.query_ db "SELECT count(1) FROM last_notifications"
|
||||
pure (tCnt, sCnt, nCnt)
|
||||
where
|
||||
count (Only n : _) = n
|
||||
count [] = 0
|
||||
|
||||
importNtfSTMStore :: NtfPostgresStore -> NtfSTMStore -> S.Set NtfTokenId -> IO (Int64, Int64, Int64, Int64)
|
||||
importNtfSTMStore NtfPostgresStore {dbStore = s} stmStore skipTokens = do
|
||||
(tIds, tCnt) <- importTokens
|
||||
subLookup <- readTVarIO $ subscriptionLookup stmStore
|
||||
sCnt <- importSubscriptions tIds subLookup
|
||||
nCnt <- importLastNtfs tIds subLookup
|
||||
serviceCnt <- importNtfServiceIds
|
||||
pure (tCnt, sCnt, nCnt, serviceCnt)
|
||||
where
|
||||
importTokens = do
|
||||
allTokens <- M.elems <$> readTVarIO (tokens stmStore)
|
||||
tokens <- filterTokens allTokens
|
||||
let skipped = length allTokens - length tokens
|
||||
when (skipped /= 0) $ putStrLn $ "Total skipped tokens " <> show skipped
|
||||
-- uncomment this line instead of the next two to import tokens one by one.
|
||||
-- tCnt <- withConnection s $ \db -> foldM (importTkn db) 0 tokens
|
||||
-- token interval is reset to 0 to only send notifications to devices with periodic mode,
|
||||
-- and before clients are upgraded - to all active devices.
|
||||
tRows <- mapM (fmap (ntfTknToRow . (\t -> t {tknCronInterval = 0} :: NtfTknRec)) . mkTknRec) tokens
|
||||
tCnt <- withConnection s $ \db -> DB.executeMany db insertNtfTknQuery tRows
|
||||
let tokenIds = S.fromList $ map (\NtfTknData {ntfTknId} -> ntfTknId) tokens
|
||||
(tokenIds,) <$> checkCount "token" (length tokens) tCnt
|
||||
where
|
||||
filterTokens tokens = do
|
||||
let deviceTokens = foldl' (\m t -> M.alter (Just . (t :) . fromMaybe []) (tokenKey t) m) M.empty tokens
|
||||
tokenSubs <- readTVarIO (tokenSubscriptions stmStore)
|
||||
filterM (keepTokenRegistration deviceTokens tokenSubs) tokens
|
||||
tokenKey NtfTknData {token, tknVerifyKey} = strEncode token <> ":" <> C.toPubKey C.pubKeyBytes tknVerifyKey
|
||||
keepTokenRegistration deviceTokens tokenSubs tkn@NtfTknData {ntfTknId, tknStatus} =
|
||||
case M.lookup (tokenKey tkn) deviceTokens of
|
||||
Just ts
|
||||
| length ts < 2 -> pure True
|
||||
| ntfTknId `S.member` skipTokens -> False <$ putStrLn ("Skipped token " <> enc ntfTknId <> " from --skip-tokens")
|
||||
| otherwise ->
|
||||
readTVarIO tknStatus >>= \case
|
||||
NTConfirmed -> do
|
||||
hasSubs <- maybe (pure False) (\v -> not . S.null <$> readTVarIO v) $ M.lookup ntfTknId tokenSubs
|
||||
if hasSubs
|
||||
then pure True
|
||||
else do
|
||||
anyBetterToken <- anyM $ map (\NtfTknData {tknStatus = tknStatus'} -> activeOrInvalid <$> readTVarIO tknStatus') ts
|
||||
if anyBetterToken
|
||||
then False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId)
|
||||
else case findIndex (\NtfTknData {ntfTknId = tId} -> tId == ntfTknId) ts of
|
||||
Just 0 -> pure True -- keeping the first token
|
||||
Just _ -> False <$ putStrLn ("Skipped duplicate inactive token " <> enc ntfTknId <> " (no active token)")
|
||||
Nothing -> True <$ putStrLn "Error: no device token in the list"
|
||||
_ -> pure True
|
||||
Nothing -> True <$ putStrLn "Error: no device token in lookup map"
|
||||
activeOrInvalid = \case
|
||||
NTActive -> True
|
||||
NTInvalid _ -> True
|
||||
_ -> False
|
||||
-- importTkn db !n tkn@NtfTknData {ntfTknId} = do
|
||||
-- tknRow <- ntfTknToRow <$> mkTknRec tkn
|
||||
-- (DB.execute db insertNtfTknQuery tknRow >>= pure . (n + )) `E.catch` \(e :: E.SomeException) ->
|
||||
-- putStrLn ("Error inserting token " <> enc ntfTknId <> " " <> show e) $> n
|
||||
importSubscriptions :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64
|
||||
importSubscriptions tIds subLookup = do
|
||||
subs <- filterSubs . M.elems =<< readTVarIO (subscriptions stmStore)
|
||||
srvIds <- importServers subs
|
||||
putStrLn $ "Importing " <> show (length subs) <> " subscriptions..."
|
||||
-- uncomment this line instead of the next to import subs one by one.
|
||||
-- (sCnt, errTkns) <- withConnection s $ \db -> foldM (importSub db srvIds) (0, M.empty) subs
|
||||
sCnt <- foldM (importSubs srvIds) 0 $ toChunks 500000 subs
|
||||
checkCount "subscription" (length subs) sCnt
|
||||
where
|
||||
filterSubs allSubs = do
|
||||
let subs = filter (\NtfSubData {tokenId} -> S.member tokenId tIds) allSubs
|
||||
skipped = length allSubs - length subs
|
||||
when (skipped /= 0) $ putStrLn $ "Skipped " <> show skipped <> " subscriptions of missing tokens"
|
||||
let (removedSubTokens, removeSubs, dupQueues) = foldl' addSubToken (S.empty, S.empty, S.empty) subs
|
||||
unless (null removeSubs) $ putStrLn $ "Skipped " <> show (S.size removeSubs) <> " duplicate subscriptions of " <> show (S.size removedSubTokens) <> " tokens for " <> show (S.size dupQueues) <> " queues"
|
||||
pure $ filter (\NtfSubData {ntfSubId} -> S.notMember ntfSubId removeSubs) subs
|
||||
where
|
||||
addSubToken acc@(!stIds, !sIds, !qs) NtfSubData {ntfSubId, smpQueue, tokenId} =
|
||||
case M.lookup smpQueue subLookup of
|
||||
Just sId | sId /= ntfSubId ->
|
||||
(S.insert tokenId stIds, S.insert ntfSubId sIds, S.insert smpQueue qs)
|
||||
_ -> acc
|
||||
importSubs srvIds !n subs = do
|
||||
rows <- mapM (ntfSubRow srvIds) subs
|
||||
cnt <- withConnection s $ \db -> DB.executeMany db insertNtfSubQuery $ L.toList rows
|
||||
let n' = n + cnt
|
||||
putStr $ "Imported " <> show n' <> " subscriptions" <> "\r"
|
||||
hFlush stdout
|
||||
pure n'
|
||||
-- importSub db srvIds (!n, !errTkns) sub@NtfSubData {ntfSubId = sId, tokenId} = do
|
||||
-- subRow <- ntfSubRow srvIds sub
|
||||
-- E.try (DB.execute db insertNtfSubQuery subRow) >>= \case
|
||||
-- Right i -> do
|
||||
-- let n' = n + i
|
||||
-- when (n' `mod` 100000 == 0) $ do
|
||||
-- putStr $ "Imported " <> show n' <> " subscriptions" <> "\r"
|
||||
-- hFlush stdout
|
||||
-- pure (n', errTkns)
|
||||
-- Left (e :: E.SomeException) -> do
|
||||
-- when (n `mod` 100000 == 0) $ putStrLn ""
|
||||
-- putStrLn $ "Error inserting subscription " <> enc sId <> " for token " <> enc tokenId <> " " <> show e
|
||||
-- pure (n, M.alter (Just . maybe [sId] (sId :)) tokenId errTkns)
|
||||
ntfSubRow srvIds sub = case M.lookup srv srvIds of
|
||||
Just sId -> ntfSubToRow sId <$> mkSubRec sub
|
||||
Nothing -> E.throwIO $ userError $ "no matching server ID for server " <> show srv
|
||||
where
|
||||
srv = ntfSubServer sub
|
||||
importServers subs = do
|
||||
sIds <- withConnection s $ \db -> map fromOnly <$> DB.returning db srvQuery (map srvToRow srvs)
|
||||
void $ checkCount "server" (length srvs) (length sIds)
|
||||
pure $ M.fromList $ zip srvs sIds
|
||||
where
|
||||
srvQuery = "INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash) VALUES (?, ?, ?) RETURNING smp_server_id"
|
||||
srvs = nubOrd $ map ntfSubServer subs
|
||||
importLastNtfs :: S.Set NtfTokenId -> M.Map SMPQueueNtf NtfSubscriptionId -> IO Int64
|
||||
importLastNtfs tIds subLookup = do
|
||||
ntfs <- readTVarIO (tokenLastNtfs stmStore)
|
||||
ntfRows <- filterLastNtfRows ntfs
|
||||
nCnt <- withConnection s $ \db -> DB.executeMany db lastNtfQuery ntfRows
|
||||
checkCount "last notification" (length ntfRows) nCnt
|
||||
where
|
||||
lastNtfQuery = "INSERT INTO last_notifications(token_id, subscription_id, sent_at, nmsg_nonce, nmsg_data) VALUES (?,?,?,?,?)"
|
||||
filterLastNtfRows ntfs = do
|
||||
(skippedTkns, ntfCnt, (skippedQueues, ntfRows)) <- foldM lastNtfRows (S.empty, 0, (S.empty, [])) $ M.assocs ntfs
|
||||
let skipped = ntfCnt - length ntfRows
|
||||
when (skipped /= 0) $ putStrLn $ "Skipped last notifications " <> show skipped <> " for " <> show (S.size skippedTkns) <> " missing tokens and " <> show (S.size skippedQueues) <> " missing subscriptions with token present"
|
||||
pure ntfRows
|
||||
lastNtfRows (!stIds, !cnt, !acc) (tId, ntfVar) = do
|
||||
ntfs <- L.toList <$> readTVarIO ntfVar
|
||||
let cnt' = cnt + length ntfs
|
||||
pure $
|
||||
if S.member tId tIds
|
||||
then (stIds, cnt', foldl' ntfRow acc ntfs)
|
||||
else (S.insert tId stIds, cnt', acc)
|
||||
where
|
||||
ntfRow (!qs, !rows) PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = case M.lookup smpQueue subLookup of
|
||||
Just ntfSubId ->
|
||||
let row = (tId, ntfSubId, systemToUTCTime ntfTs, nmsgNonce, Binary encNMsgMeta)
|
||||
in (qs, row : rows)
|
||||
Nothing -> (S.insert smpQueue qs, rows)
|
||||
importNtfServiceIds = do
|
||||
ss <- M.assocs <$> readTVarIO (ntfServices stmStore)
|
||||
withConnection s $ \db -> DB.executeMany db serviceQuery $ map serviceToRow ss
|
||||
where
|
||||
serviceQuery =
|
||||
[sql|
|
||||
INSERT INTO smp_servers (smp_host, smp_port, smp_keyhash, ntf_service_id)
|
||||
VALUES (?, ?, ?, ?)
|
||||
ON CONFLICT (smp_host, smp_port, smp_keyhash)
|
||||
DO UPDATE SET ntf_service_id = EXCLUDED.ntf_service_id
|
||||
|]
|
||||
serviceToRow (srv, serviceId) = srvToRow srv :. Only serviceId
|
||||
checkCount name expected inserted
|
||||
| fromIntegral expected == inserted = do
|
||||
putStrLn $ "Imported " <> show inserted <> " " <> name <> "s."
|
||||
pure inserted
|
||||
| otherwise = do
|
||||
putStrLn $ "Incorrect " <> name <> " count: expected " <> show expected <> ", imported " <> show inserted
|
||||
putStrLn "Import aborted, fix data and repeat"
|
||||
exitFailure
|
||||
enc = B.unpack . B64.encode . unEntityId
|
||||
|
||||
exportNtfDbStore :: NtfPostgresStore -> FilePath -> IO (Int, Int, Int)
|
||||
exportNtfDbStore NtfPostgresStore {dbStoreLog = Nothing} _ =
|
||||
putStrLn "Internal error: export requires store log" >> exitFailure
|
||||
exportNtfDbStore NtfPostgresStore {dbStore = s, dbStoreLog = Just sl} lastNtfsFile =
|
||||
(,,) <$> exportTokens <*> exportSubscriptions <*> exportLastNtfs
|
||||
where
|
||||
exportTokens = do
|
||||
tCnt <- withConnection s $ \db -> DB.fold_ db ntfTknQuery 0 $ \ !i tkn ->
|
||||
logCreateToken sl (rowToNtfTkn tkn) $> (i + 1)
|
||||
putStrLn $ "Exported " <> show tCnt <> " tokens"
|
||||
pure tCnt
|
||||
exportSubscriptions = do
|
||||
sCnt <- withConnection s $ \db -> DB.fold_ db ntfSubQuery 0 $ \ !i sub -> do
|
||||
let i' = i + 1
|
||||
logCreateSubscription sl (toNtfSub sub)
|
||||
when (i' `mod` 500000 == 0) $ do
|
||||
putStr $ "Exported " <> show i' <> " subscriptions" <> "\r"
|
||||
hFlush stdout
|
||||
pure i'
|
||||
putStrLn $ "Exported " <> show sCnt <> " subscriptions"
|
||||
pure sCnt
|
||||
where
|
||||
ntfSubQuery =
|
||||
[sql|
|
||||
SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status, s.ntf_service_assoc,
|
||||
p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id
|
||||
FROM subscriptions s
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
|]
|
||||
toNtfSub :: Only NtfTokenId :. NtfSubRow :. SMPQueueNtfRow -> NtfSubRec
|
||||
toNtfSub (Only tokenId :. (ntfSubId, notifierKey, subStatus, ntfServiceAssoc) :. qRow) =
|
||||
let smpQueue = rowToSMPQueue qRow
|
||||
in NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus, ntfServiceAssoc}
|
||||
exportLastNtfs =
|
||||
withFile lastNtfsFile WriteMode $ \h ->
|
||||
withConnection s $ \db -> DB.fold_ db lastNtfsQuery 0 $ \ !i (Only tknId :. ntfRow) ->
|
||||
B.hPutStr h (encodeLastNtf tknId $ toLastNtf ntfRow) $> (i + 1)
|
||||
where
|
||||
-- Note that the order here is ascending, to be compatible with how it is imported
|
||||
lastNtfsQuery =
|
||||
[sql|
|
||||
SELECT s.token_id, p.smp_host, p.smp_port, p.smp_keyhash, s.smp_notifier_id,
|
||||
n.sent_at, n.nmsg_nonce, n.nmsg_data
|
||||
FROM last_notifications n
|
||||
JOIN subscriptions s ON s.subscription_id = n.subscription_id
|
||||
JOIN smp_servers p ON p.smp_server_id = s.smp_server_id
|
||||
ORDER BY token_ntf_id ASC
|
||||
|]
|
||||
encodeLastNtf tknId ntf = strEncode (TNMRv1 tknId ntf) `B.snoc` '\n'
|
||||
|
||||
withFastDB' :: Text -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
|
||||
withFastDB' op st action = withFastDB op st $ fmap Right . action
|
||||
{-# INLINE withFastDB' #-}
|
||||
|
||||
withDB' :: Text -> NtfPostgresStore -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
|
||||
withDB' op st action = withDB op st $ fmap Right . action
|
||||
{-# INLINE withDB' #-}
|
||||
|
||||
withFastDB :: forall a. Text -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
|
||||
withFastDB op st = withDB_ op st True
|
||||
{-# INLINE withFastDB #-}
|
||||
|
||||
withDB :: forall a. Text -> NtfPostgresStore -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
|
||||
withDB op st = withDB_ op st False
|
||||
{-# INLINE withDB #-}
|
||||
|
||||
withDB_ :: forall a. Text -> NtfPostgresStore -> Bool -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
|
||||
withDB_ op st priority action =
|
||||
E.uninterruptibleMask_ $ E.try (withTransactionPriority (dbStore st) priority action) >>= either logErr pure
|
||||
where
|
||||
logErr :: E.SomeException -> IO (Either ErrorType a)
|
||||
logErr e = logError ("STORE: " <> err) $> Left (STORE err)
|
||||
where
|
||||
err = op <> ", withDB, " <> tshow e
|
||||
|
||||
withLog :: MonadIO m => Text -> NtfPostgresStore -> (StoreLog 'WriteMode -> IO ()) -> m ()
|
||||
withLog op NtfPostgresStore {dbStoreLog} = withLog_ op dbStoreLog
|
||||
{-# INLINE withLog #-}
|
||||
|
||||
assertUpdated :: Int64 -> Either ErrorType ()
|
||||
assertUpdated 0 = Left AUTH
|
||||
assertUpdated _ = Right ()
|
||||
|
||||
instance FromField NtfSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
|
||||
|
||||
instance ToField NtfSubStatus where toField = toField . decodeLatin1 . smpEncode
|
||||
|
||||
#if !defined(dbPostgres)
|
||||
instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
|
||||
|
||||
instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
|
||||
|
||||
instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
|
||||
|
||||
instance FromField (C.PrivateKey 'C.X25519) where fromField = blobFieldDecoder C.decodePrivKey
|
||||
|
||||
instance ToField (C.PrivateKey 'C.X25519) where toField = toField . Binary . C.encodePrivKey
|
||||
|
||||
instance FromField C.APrivateAuthKey where fromField = blobFieldDecoder C.decodePrivKey
|
||||
|
||||
instance ToField C.APrivateAuthKey where toField = toField . Binary . C.encodePrivKey
|
||||
|
||||
instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
|
||||
|
||||
instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
instance FromField C.KeyHash where fromField = blobFieldDecoder $ parseAll strP
|
||||
|
||||
instance ToField C.KeyHash where toField = toField . Binary . strEncode
|
||||
|
||||
instance FromField C.CbNonce where fromField = blobFieldDecoder $ parseAll smpP
|
||||
|
||||
instance ToField C.CbNonce where toField = toField . Binary . smpEncode
|
||||
#endif
|
||||
@@ -1,119 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Store.Types where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Concurrent.STM
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf)
|
||||
import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..))
|
||||
import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
|
||||
|
||||
data NtfTknRec = NtfTknRec
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
token :: DeviceToken,
|
||||
tknStatus :: NtfTknStatus,
|
||||
tknVerifyKey :: NtfPublicAuthKey,
|
||||
tknDhPrivKey :: C.PrivateKeyX25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: Word16,
|
||||
tknUpdatedAt :: Maybe RoundedSystemTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
mkTknData :: NtfTknRec -> IO NtfTknData
|
||||
mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
|
||||
tknStatus <- newTVarIO status
|
||||
tknCronInterval <- newTVarIO cronInt
|
||||
tknUpdatedAt <- newTVarIO updatedAt
|
||||
let tknDhKeys = (C.publicKey pk, pk)
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
|
||||
|
||||
mkTknRec :: NtfTknData -> IO NtfTknRec
|
||||
mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys = (_, tknDhPrivKey), tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
|
||||
tknStatus <- readTVarIO status
|
||||
tknCronInterval <- readTVarIO cronInt
|
||||
tknUpdatedAt <- readTVarIO updatedAt
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
|
||||
|
||||
instance StrEncoding NtfTknRec where
|
||||
strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey = pk, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
|
||||
B.unwords
|
||||
[ "tknId=" <> strEncode ntfTknId,
|
||||
"token=" <> strEncode token,
|
||||
"tokenStatus=" <> strEncode tknStatus,
|
||||
"verifyKey=" <> strEncode tknVerifyKey,
|
||||
"dhKeys=" <> strEncode (C.publicKey pk, pk),
|
||||
"dhSecret=" <> strEncode tknDhSecret,
|
||||
"regCode=" <> strEncode tknRegCode,
|
||||
"cron=" <> strEncode tknCronInterval
|
||||
]
|
||||
<> maybe "" updatedAtStr tknUpdatedAt
|
||||
where
|
||||
updatedAtStr t = " updatedAt=" <> strEncode t
|
||||
strP = do
|
||||
ntfTknId <- "tknId=" *> strP_
|
||||
token <- "token=" *> strP_
|
||||
tknStatus <- "tokenStatus=" *> strP_
|
||||
tknVerifyKey <- "verifyKey=" *> strP_
|
||||
(_ :: C.PublicKeyX25519, tknDhPrivKey) <- "dhKeys=" *> strP_
|
||||
tknDhSecret <- "dhSecret=" *> strP_
|
||||
tknRegCode <- "regCode=" *> strP_
|
||||
tknCronInterval <- "cron=" *> strP
|
||||
tknUpdatedAt <- optional $ " updatedAt=" *> strP
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
|
||||
|
||||
data NtfSubRec = NtfSubRec
|
||||
{ ntfSubId :: NtfSubscriptionId,
|
||||
smpQueue :: SMPQueueNtf,
|
||||
notifierKey :: NtfPrivateAuthKey,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: NtfSubStatus,
|
||||
ntfServiceAssoc :: NtfAssociatedService -- Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type ServerNtfSub = (NtfSubscriptionId, (NotifierId, NtfPrivateAuthKey))
|
||||
|
||||
type NtfAssociatedService = Bool
|
||||
|
||||
mkSubData :: NtfSubRec -> IO NtfSubData
|
||||
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
|
||||
subStatus <- newTVarIO status
|
||||
ntfServiceAssoc <- newTVarIO serviceAssoc
|
||||
pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
|
||||
|
||||
mkSubRec :: NtfSubData -> IO NtfSubRec
|
||||
mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status, ntfServiceAssoc = serviceAssoc} = do
|
||||
subStatus <- readTVarIO status
|
||||
ntfServiceAssoc <- readTVarIO serviceAssoc
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
|
||||
|
||||
instance StrEncoding NtfSubRec where
|
||||
strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc} =
|
||||
B.unwords
|
||||
[ "subId=" <> strEncode ntfSubId,
|
||||
"smpQueue=" <> strEncode smpQueue,
|
||||
"notifierKey=" <> strEncode notifierKey,
|
||||
"tknId=" <> strEncode tokenId,
|
||||
"subStatus=" <> strEncode subStatus,
|
||||
"serviceAssoc=" <> strEncode ntfServiceAssoc
|
||||
]
|
||||
strP = do
|
||||
ntfSubId <- "subId=" *> strP_
|
||||
smpQueue <- "smpQueue=" *> strP_
|
||||
notifierKey <- "notifierKey=" *> strP_
|
||||
tokenId <- "tknId=" *> strP_
|
||||
subStatus <- "subStatus=" *> strP
|
||||
ntfServiceAssoc <- fromMaybe False <$> optional (" serviceAssoc=" *> strP)
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus, ntfServiceAssoc}
|
||||
@@ -1,180 +0,0 @@
|
||||
|
||||
|
||||
SET statement_timeout = 0;
|
||||
SET lock_timeout = 0;
|
||||
SET idle_in_transaction_session_timeout = 0;
|
||||
SET client_encoding = 'UTF8';
|
||||
SET standard_conforming_strings = on;
|
||||
SELECT pg_catalog.set_config('search_path', '', false);
|
||||
SET check_function_bodies = false;
|
||||
SET xmloption = content;
|
||||
SET client_min_messages = warning;
|
||||
SET row_security = off;
|
||||
|
||||
|
||||
CREATE SCHEMA ntf_server;
|
||||
|
||||
|
||||
SET default_table_access_method = heap;
|
||||
|
||||
|
||||
CREATE TABLE ntf_server.last_notifications (
|
||||
token_ntf_id bigint NOT NULL,
|
||||
token_id bytea NOT NULL,
|
||||
subscription_id bytea NOT NULL,
|
||||
sent_at timestamp with time zone NOT NULL,
|
||||
nmsg_nonce bytea NOT NULL,
|
||||
nmsg_data bytea NOT NULL
|
||||
);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ntf_server.last_notifications ALTER COLUMN token_ntf_id ADD GENERATED ALWAYS AS IDENTITY (
|
||||
SEQUENCE NAME ntf_server.last_notifications_token_ntf_id_seq
|
||||
START WITH 1
|
||||
INCREMENT BY 1
|
||||
NO MINVALUE
|
||||
NO MAXVALUE
|
||||
CACHE 1
|
||||
);
|
||||
|
||||
|
||||
|
||||
CREATE TABLE ntf_server.migrations (
|
||||
name text NOT NULL,
|
||||
ts timestamp without time zone NOT NULL,
|
||||
down text
|
||||
);
|
||||
|
||||
|
||||
|
||||
CREATE TABLE ntf_server.smp_servers (
|
||||
smp_server_id bigint NOT NULL,
|
||||
smp_host text NOT NULL,
|
||||
smp_port text NOT NULL,
|
||||
smp_keyhash bytea NOT NULL,
|
||||
ntf_service_id bytea
|
||||
);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ntf_server.smp_servers ALTER COLUMN smp_server_id ADD GENERATED ALWAYS AS IDENTITY (
|
||||
SEQUENCE NAME ntf_server.smp_servers_smp_server_id_seq
|
||||
START WITH 1
|
||||
INCREMENT BY 1
|
||||
NO MINVALUE
|
||||
NO MAXVALUE
|
||||
CACHE 1
|
||||
);
|
||||
|
||||
|
||||
|
||||
CREATE TABLE ntf_server.subscriptions (
|
||||
subscription_id bytea NOT NULL,
|
||||
token_id bytea NOT NULL,
|
||||
smp_server_id bigint,
|
||||
smp_notifier_id bytea NOT NULL,
|
||||
smp_notifier_key bytea NOT NULL,
|
||||
status text NOT NULL,
|
||||
ntf_service_assoc boolean DEFAULT false NOT NULL
|
||||
);
|
||||
|
||||
|
||||
|
||||
CREATE TABLE ntf_server.tokens (
|
||||
token_id bytea NOT NULL,
|
||||
push_provider text NOT NULL,
|
||||
push_provider_token bytea NOT NULL,
|
||||
status text NOT NULL,
|
||||
verify_key bytea NOT NULL,
|
||||
dh_priv_key bytea NOT NULL,
|
||||
dh_secret bytea NOT NULL,
|
||||
reg_code bytea NOT NULL,
|
||||
cron_interval bigint NOT NULL,
|
||||
cron_sent_at bigint,
|
||||
updated_at bigint
|
||||
);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.last_notifications
|
||||
ADD CONSTRAINT last_notifications_pkey PRIMARY KEY (token_ntf_id);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.migrations
|
||||
ADD CONSTRAINT migrations_pkey PRIMARY KEY (name);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.smp_servers
|
||||
ADD CONSTRAINT smp_servers_pkey PRIMARY KEY (smp_server_id);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.subscriptions
|
||||
ADD CONSTRAINT subscriptions_pkey PRIMARY KEY (subscription_id);
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.tokens
|
||||
ADD CONSTRAINT tokens_pkey PRIMARY KEY (token_id);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_last_notifications_token_id_sent_at ON ntf_server.last_notifications USING btree (token_id, sent_at);
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON ntf_server.last_notifications USING btree (token_id, subscription_id);
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_smp_servers ON ntf_server.smp_servers USING btree (smp_host, smp_port, smp_keyhash);
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_subscriptions_smp_server_id_notifier_id ON ntf_server.subscriptions USING btree (smp_server_id, smp_notifier_id);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON ntf_server.subscriptions USING btree (smp_server_id, ntf_service_assoc, status);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_subscriptions_token_id ON ntf_server.subscriptions USING btree (token_id);
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_tokens_push_provider_token ON ntf_server.tokens USING btree (push_provider, push_provider_token, verify_key);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_tokens_status_cron_interval_sent_at ON ntf_server.tokens USING btree (status, cron_interval, ((cron_sent_at + (cron_interval * 60))));
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.last_notifications
|
||||
ADD CONSTRAINT last_notifications_subscription_id_fkey FOREIGN KEY (subscription_id) REFERENCES ntf_server.subscriptions(subscription_id) ON UPDATE RESTRICT ON DELETE CASCADE;
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.last_notifications
|
||||
ADD CONSTRAINT last_notifications_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE;
|
||||
|
||||
|
||||
|
||||
ALTER TABLE ONLY ntf_server.subscriptions
|
||||
ADD CONSTRAINT subscriptions_smp_server_id_fkey FOREIGN KEY (smp_server_id) REFERENCES ntf_server.smp_servers(smp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT;
|
||||
|
||||
|
||||
|
||||
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;
|
||||
|
||||
|
||||
|
||||
@@ -10,13 +10,12 @@
|
||||
module Simplex.Messaging.Notifications.Server.StoreLog
|
||||
( StoreLog,
|
||||
NtfStoreLogRecord (..),
|
||||
readWriteNtfSTMStore,
|
||||
readWriteNtfStore,
|
||||
logCreateToken,
|
||||
logTokenStatus,
|
||||
logUpdateToken,
|
||||
logTokenCron,
|
||||
logDeleteToken,
|
||||
logUpdateTokenTime,
|
||||
logCreateSubscription,
|
||||
logSubscriptionStatus,
|
||||
logDeleteSubscription,
|
||||
@@ -24,23 +23,21 @@ module Simplex.Messaging.Notifications.Server.StoreLog
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.Text as T
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types
|
||||
import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
|
||||
import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import System.IO
|
||||
|
||||
data NtfStoreLogRecord
|
||||
@@ -49,13 +46,54 @@ data NtfStoreLogRecord
|
||||
| UpdateToken NtfTokenId DeviceToken NtfRegCode
|
||||
| TokenCron NtfTokenId Word16
|
||||
| DeleteToken NtfTokenId
|
||||
| UpdateTokenTime NtfTokenId RoundedSystemTime
|
||||
| CreateSubscription NtfSubRec
|
||||
| SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
|
||||
| SubscriptionStatus NtfSubscriptionId NtfSubStatus
|
||||
| DeleteSubscription NtfSubscriptionId
|
||||
| SetNtfService SMPServer (Maybe ServiceId)
|
||||
deriving (Show)
|
||||
|
||||
data NtfTknRec = NtfTknRec
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
token :: DeviceToken,
|
||||
tknStatus :: NtfTknStatus,
|
||||
tknVerifyKey :: C.APublicAuthKey,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: Word16
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
mkTknData :: NtfTknRec -> STM NtfTknData
|
||||
mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
|
||||
tknStatus <- newTVar status
|
||||
tknCronInterval <- newTVar cronInt
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
mkTknRec :: NtfTknData -> STM NtfTknRec
|
||||
mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
|
||||
tknStatus <- readTVar status
|
||||
tknCronInterval <- readTVar cronInt
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
data NtfSubRec = NtfSubRec
|
||||
{ ntfSubId :: NtfSubscriptionId,
|
||||
smpQueue :: SMPQueueNtf,
|
||||
notifierKey :: NtfPrivateAuthKey,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: NtfSubStatus
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
mkSubData :: NtfSubRec -> STM NtfSubData
|
||||
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
|
||||
subStatus <- newTVar status
|
||||
pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
mkSubRec :: NtfSubData -> STM NtfSubRec
|
||||
mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
|
||||
subStatus <- readTVar status
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
instance StrEncoding NtfStoreLogRecord where
|
||||
strEncode = \case
|
||||
CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
|
||||
@@ -63,13 +101,9 @@ instance StrEncoding NtfStoreLogRecord where
|
||||
UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
|
||||
TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
|
||||
DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
|
||||
UpdateTokenTime tknId ts -> strEncode (Str "TTIME", tknId, ts)
|
||||
CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
|
||||
SubscriptionStatus subId subStatus serviceAssoc -> strEncode (Str "SSTATUS", subId, subStatus) <> serviceStr
|
||||
where
|
||||
serviceStr = if serviceAssoc then " service=" <> strEncode True else ""
|
||||
SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
|
||||
DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
|
||||
SetNtfService srv serviceId -> strEncode (Str "SERVICE", srv) <> " service=" <> maybe "off" strEncode serviceId
|
||||
strP =
|
||||
A.choice
|
||||
[ "TCREATE " *> (CreateToken <$> strP),
|
||||
@@ -77,19 +111,57 @@ instance StrEncoding NtfStoreLogRecord where
|
||||
"TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
|
||||
"TCRON " *> (TokenCron <$> strP_ <*> strP),
|
||||
"TDELETE " *> (DeleteToken <$> strP),
|
||||
"TTIME " *> (UpdateTokenTime <$> strP_ <*> strP),
|
||||
"SCREATE " *> (CreateSubscription <$> strP),
|
||||
"SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP <*> (fromMaybe False <$> optional (" service=" *> strP))),
|
||||
"SDELETE " *> (DeleteSubscription <$> strP),
|
||||
"SERVICE " *> (SetNtfService <$> strP <* " service=" <*> ("off" $> Nothing <|> strP))
|
||||
"SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
|
||||
"SDELETE " *> (DeleteSubscription <$> strP)
|
||||
]
|
||||
|
||||
instance StrEncoding NtfTknRec where
|
||||
strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} =
|
||||
B.unwords
|
||||
[ "tknId=" <> strEncode ntfTknId,
|
||||
"token=" <> strEncode token,
|
||||
"tokenStatus=" <> strEncode tknStatus,
|
||||
"verifyKey=" <> strEncode tknVerifyKey,
|
||||
"dhKeys=" <> strEncode tknDhKeys,
|
||||
"dhSecret=" <> strEncode tknDhSecret,
|
||||
"regCode=" <> strEncode tknRegCode,
|
||||
"cron=" <> strEncode tknCronInterval
|
||||
]
|
||||
strP = do
|
||||
ntfTknId <- "tknId=" *> strP_
|
||||
token <- "token=" *> strP_
|
||||
tknStatus <- "tokenStatus=" *> strP_
|
||||
tknVerifyKey <- "verifyKey=" *> strP_
|
||||
tknDhKeys <- "dhKeys=" *> strP_
|
||||
tknDhSecret <- "dhSecret=" *> strP_
|
||||
tknRegCode <- "regCode=" *> strP_
|
||||
tknCronInterval <- "cron=" *> strP
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
instance StrEncoding NtfSubRec where
|
||||
strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
|
||||
B.unwords
|
||||
[ "subId=" <> strEncode ntfSubId,
|
||||
"smpQueue=" <> strEncode smpQueue,
|
||||
"notifierKey=" <> strEncode notifierKey,
|
||||
"tknId=" <> strEncode tokenId,
|
||||
"subStatus=" <> strEncode subStatus
|
||||
]
|
||||
strP = do
|
||||
ntfSubId <- "subId=" *> strP_
|
||||
smpQueue <- "smpQueue=" *> strP_
|
||||
notifierKey <- "notifierKey=" *> strP_
|
||||
tokenId <- "tknId=" *> strP_
|
||||
subStatus <- "subStatus=" *> strP
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
|
||||
logNtfStoreRecord = writeStoreLogRecord
|
||||
{-# INLINE logNtfStoreRecord #-}
|
||||
|
||||
logCreateToken :: StoreLog 'WriteMode -> NtfTknRec -> IO ()
|
||||
logCreateToken s = logNtfStoreRecord s . CreateToken
|
||||
logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
|
||||
logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
|
||||
|
||||
logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
|
||||
logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
|
||||
@@ -103,75 +175,55 @@ logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
|
||||
logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
|
||||
logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
|
||||
|
||||
logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
|
||||
logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
|
||||
logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
|
||||
logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
|
||||
|
||||
logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()
|
||||
logCreateSubscription s = logNtfStoreRecord s . CreateSubscription
|
||||
|
||||
logSubscriptionStatus :: StoreLog 'WriteMode -> (NtfSubscriptionId, NtfSubStatus, NtfAssociatedService) -> IO ()
|
||||
logSubscriptionStatus s (subId, subStatus, serviceAssoc) = logNtfStoreRecord s $ SubscriptionStatus subId subStatus serviceAssoc
|
||||
logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
|
||||
logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
|
||||
|
||||
logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
|
||||
logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
|
||||
|
||||
logSetNtfService :: StoreLog 'WriteMode -> SMPServer -> Maybe ServiceId -> IO ()
|
||||
logSetNtfService s srv serviceId = logNtfStoreRecord s $ SetNtfService srv serviceId
|
||||
readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
|
||||
readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore
|
||||
|
||||
readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
|
||||
readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore
|
||||
|
||||
readNtfStore :: Bool -> FilePath -> NtfSTMStore -> IO ()
|
||||
readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
|
||||
readNtfStore :: FilePath -> NtfStore -> IO ()
|
||||
readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
|
||||
where
|
||||
processLine s = either printError procNtfLogRecord (strDecode s)
|
||||
where
|
||||
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> B.take 100 s
|
||||
procNtfLogRecord = \case
|
||||
CreateToken r@NtfTknRec {ntfTknId} -> do
|
||||
tkn <- mkTknData r
|
||||
atomically $ stmAddNtfToken st ntfTknId tkn
|
||||
TokenStatus tknId status -> do
|
||||
tkn_ <- stmGetNtfTokenIO st tknId
|
||||
forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
|
||||
atomically $ writeTVar tknStatus status
|
||||
when (status == NTActive) $ void $ atomically $ stmRemoveInactiveTokenRegistrations st tkn
|
||||
UpdateToken tknId token' tknRegCode -> do
|
||||
stmGetNtfTokenIO st tknId
|
||||
>>= mapM_
|
||||
( \tkn@NtfTknData {tknStatus} -> do
|
||||
atomically $ stmRemoveTokenRegistration st tkn
|
||||
atomically $ writeTVar tknStatus NTRegistered
|
||||
atomically $ stmAddNtfToken st tknId tkn {token = token', tknRegCode}
|
||||
)
|
||||
TokenCron tknId cronInt ->
|
||||
stmGetNtfTokenIO st tknId
|
||||
>>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
|
||||
DeleteToken tknId ->
|
||||
atomically $ void $ stmDeleteNtfToken st tknId
|
||||
UpdateTokenTime tknId t ->
|
||||
stmGetNtfTokenIO st tknId
|
||||
>>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
|
||||
CreateSubscription r@NtfSubRec {tokenId, ntfSubId} -> do
|
||||
sub <- mkSubData r
|
||||
atomically (stmAddNtfSubscription st ntfSubId sub) >>= \case
|
||||
Just () -> pure ()
|
||||
Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId
|
||||
where
|
||||
enc = B64.encode . unEntityId
|
||||
SubscriptionStatus subId status serviceAssoc -> do
|
||||
stmGetNtfSubscriptionIO st subId >>= mapM_ update
|
||||
where
|
||||
update NtfSubData {subStatus, ntfServiceAssoc} = atomically $ do
|
||||
writeTVar subStatus status
|
||||
writeTVar ntfServiceAssoc serviceAssoc
|
||||
DeleteSubscription subId ->
|
||||
atomically $ stmDeleteNtfSubscription st subId
|
||||
SetNtfService srv serviceId ->
|
||||
atomically $ stmSetNtfService st srv serviceId
|
||||
addNtfLogRecord s = case strDecode s of
|
||||
Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
|
||||
Right lr -> atomically $ case lr of
|
||||
CreateToken r@NtfTknRec {ntfTknId} -> do
|
||||
tkn <- mkTknData r
|
||||
addNtfToken st ntfTknId tkn
|
||||
TokenStatus tknId status -> do
|
||||
tkn_ <- getNtfToken st tknId
|
||||
forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
|
||||
writeTVar tknStatus status
|
||||
when (status == NTActive) $ void $ removeInactiveTokenRegistrations st tkn
|
||||
UpdateToken tknId token' tknRegCode ->
|
||||
getNtfToken st tknId
|
||||
>>= mapM_
|
||||
( \tkn@NtfTknData {tknStatus} -> do
|
||||
removeTokenRegistration st tkn
|
||||
writeTVar tknStatus NTRegistered
|
||||
addNtfToken st tknId tkn {token = token', tknRegCode}
|
||||
)
|
||||
TokenCron tknId cronInt ->
|
||||
getNtfToken st tknId
|
||||
>>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
|
||||
DeleteToken tknId ->
|
||||
void $ deleteNtfToken st tknId
|
||||
CreateSubscription r@NtfSubRec {ntfSubId} -> do
|
||||
sub <- mkSubData r
|
||||
void $ addNtfSubscription st ntfSubId sub
|
||||
SubscriptionStatus subId status ->
|
||||
getNtfSubscription st subId
|
||||
>>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
|
||||
DeleteSubscription subId ->
|
||||
deleteNtfSubscription st subId
|
||||
|
||||
writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO ()
|
||||
writeNtfStore s NtfSTMStore {tokens, subscriptions, ntfServices} = do
|
||||
mapM_ (logCreateToken s <=< mkTknRec) =<< readTVarIO tokens
|
||||
mapM_ (logCreateSubscription s <=< mkSubRec) =<< readTVarIO subscriptions
|
||||
mapM_ (\(srv, serviceId) -> logSetNtfService s srv $ Just serviceId) . M.assocs =<< readTVarIO ntfServices
|
||||
writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
|
||||
writeNtfStore s NtfStore {tokens, subscriptions} = do
|
||||
mapM_ (logCreateToken s) =<< readTVarIO tokens
|
||||
mapM_ (logCreateSubscription s) =<< readTVarIO subscriptions
|
||||
|
||||
@@ -44,14 +44,11 @@ initialNTFVersion = VersionNTF 1
|
||||
authBatchCmdsNTFVersion :: VersionNTF
|
||||
authBatchCmdsNTFVersion = VersionNTF 2
|
||||
|
||||
invalidReasonNTFVersion :: VersionNTF
|
||||
invalidReasonNTFVersion = VersionNTF 3
|
||||
|
||||
currentClientNTFVersion :: VersionNTF
|
||||
currentClientNTFVersion = VersionNTF 3
|
||||
currentClientNTFVersion = VersionNTF 2
|
||||
|
||||
currentServerNTFVersion :: VersionNTF
|
||||
currentServerNTFVersion = VersionNTF 3
|
||||
currentServerNTFVersion = VersionNTF 2
|
||||
|
||||
supportedClientNTFVRange :: VersionRangeNTF
|
||||
supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
|
||||
@@ -62,8 +59,8 @@ legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion
|
||||
supportedServerNTFVRange :: VersionRangeNTF
|
||||
supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
|
||||
|
||||
alpnSupportedNTFHandshakes :: [ALPN]
|
||||
alpnSupportedNTFHandshakes = ["ntf/1"]
|
||||
supportedNTFHandshakes :: [ALPN]
|
||||
supportedNTFHandshakes = ["ntf/1"]
|
||||
|
||||
type THandleNTF c p = THandle NTFVersion c p
|
||||
|
||||
@@ -110,7 +107,7 @@ instance Encoding NtfClientHandshake where
|
||||
pure NtfClientHandshake {ntfVersion, keyHash}
|
||||
|
||||
-- | Notifcations server transport handshake.
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
|
||||
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
|
||||
let sk = C.signX509 serverSignKey $ C.publicToX509 k
|
||||
@@ -126,8 +123,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
|
||||
Nothing -> throwE TEVersion
|
||||
|
||||
-- | Notifcations server client transport handshake.
|
||||
ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleNTF c 'TClient)
|
||||
ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
|
||||
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
|
||||
ntfClientHandshake c keyHash ntfVRange _proxyServer = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
|
||||
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
|
||||
if sessionId /= sessId
|
||||
@@ -137,7 +134,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
|
||||
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey signedKey
|
||||
(,CertChainPubKey (getPeerCertChain c) signedKey) <$> C.x509ToPublic' pubKey
|
||||
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
let v = maxVersion vr
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
pure $ ntfThHandleClient th v vr ck_
|
||||
@@ -145,13 +142,12 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
|
||||
|
||||
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
|
||||
ntfThHandleServer th v vr pk =
|
||||
let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
|
||||
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
|
||||
in ntfThHandle_ th v vr (Just thAuth)
|
||||
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient th v vr ck_ =
|
||||
let thAuth = clientTHParams <$> ck_
|
||||
clientTHParams (k, ck) = THAuthClient {peerServerPubKey = k, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
|
||||
in ntfThHandle_ th v vr thAuth
|
||||
|
||||
ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> VersionRangeNTF -> Maybe (THandleAuth p) -> THandleNTF c p
|
||||
@@ -161,7 +157,7 @@ ntfThHandle_ th@THandle {params} v vr thAuth =
|
||||
params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
|
||||
in (th :: THandleNTF c p) {params = params'}
|
||||
|
||||
ntfTHandle :: Transport c => c p -> THandleNTF c p
|
||||
ntfTHandle :: Transport c => c -> THandleNTF c p
|
||||
ntfTHandle c = THandle {connection = c, params}
|
||||
where
|
||||
v = VersionNTF 0
|
||||
@@ -174,6 +170,5 @@ ntfTHandle c = THandle {connection = c, params}
|
||||
thAuth = Nothing,
|
||||
implySessId = False,
|
||||
encryptBlock = Nothing,
|
||||
batch = False,
|
||||
serviceAuth = False
|
||||
batch = False
|
||||
}
|
||||
|
||||
@@ -10,10 +10,11 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time (UTCTime)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
|
||||
|
||||
data NtfTknAction
|
||||
@@ -52,7 +53,7 @@ data NtfToken = NtfToken
|
||||
-- | key used by the ntf client to sign transmissions
|
||||
ntfPrivKey :: C.APrivateAuthKey,
|
||||
-- | client's DH keys (to repeat registration if necessary)
|
||||
ntfDhKeys :: C.KeyPairX25519,
|
||||
ntfDhKeys :: C.KeyPair 'C.X25519,
|
||||
-- | shared DH secret used to encrypt/decrypt notifications e2e
|
||||
ntfDhSecret :: Maybe C.DhSecretX25519,
|
||||
-- | token status
|
||||
@@ -63,7 +64,7 @@ data NtfToken = NtfToken
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
|
||||
newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
|
||||
NtfToken
|
||||
{ deviceToken,
|
||||
|
||||
@@ -16,11 +16,24 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAlphaNum, toLower)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.ISO8601 (parseISO8601)
|
||||
import Data.Typeable (Typeable)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
|
||||
import Text.Read (readMaybe)
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple (ResultError (..))
|
||||
import Database.PostgreSQL.Simple.FromField (FromField(..), FieldParser, returnError, Field (..))
|
||||
import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
#else
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FieldParser, returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
#endif
|
||||
|
||||
base64P :: Parser ByteString
|
||||
base64P = decode <$?> paddedBase64 rawBase64P
|
||||
@@ -70,6 +83,47 @@ wordEnd c = c == ' ' || c == '\n'
|
||||
parseString :: (ByteString -> Either String a) -> (String -> a)
|
||||
parseString p = either error id . p . B.pack
|
||||
|
||||
blobFieldParser :: Typeable k => Parser k -> FieldParser k
|
||||
blobFieldParser = blobFieldDecoder . parseAll
|
||||
|
||||
#if defined(dbPostgres)
|
||||
blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
blobFieldDecoder dec f val = do
|
||||
x <- fromField f val
|
||||
case dec x of
|
||||
Right k -> pure k
|
||||
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
|
||||
#else
|
||||
blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
blobFieldDecoder dec = \case
|
||||
f@(Field (SQLBlob b) _) ->
|
||||
case dec b of
|
||||
Right k -> Ok k
|
||||
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
|
||||
f -> returnError ConversionFailed f "expecting SQLBlob column type"
|
||||
#endif
|
||||
|
||||
-- TODO [postgres] review
|
||||
#if defined(dbPostgres)
|
||||
fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a
|
||||
fromTextField_ fromText f val =
|
||||
if typeOid f `elem` [textOid, varcharOid]
|
||||
then case val of
|
||||
Just t -> case fromText (TE.decodeUtf8 t) of
|
||||
Just x -> pure x
|
||||
_ -> returnError ConversionFailed f "invalid text value"
|
||||
Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field"
|
||||
else returnError Incompatible f "expecting TEXT or VARCHAR column type"
|
||||
#else
|
||||
fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
|
||||
fromTextField_ fromText = \case
|
||||
f@(Field (SQLText t) _) ->
|
||||
case fromText t of
|
||||
Just x -> Ok x
|
||||
_ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
|
||||
f -> returnError ConversionFailed f "expecting SQLText column type"
|
||||
#endif
|
||||
|
||||
fstToLower :: String -> String
|
||||
fstToLower "" = ""
|
||||
fstToLower (h : t) = toLower h : t
|
||||
|
||||
+126
-506
File diff suppressed because it is too large
Load Diff
+798
-1110
File diff suppressed because it is too large
Load Diff
@@ -12,7 +12,6 @@
|
||||
|
||||
module Simplex.Messaging.Server.CLI where
|
||||
|
||||
import Control.Logger.Simple (LogLevel (..))
|
||||
import Control.Monad
|
||||
import Data.ASN1.Types (asn1CharacterToString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -28,13 +27,9 @@ import qualified Data.X509.File as XF
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
|
||||
import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
|
||||
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, whenM)
|
||||
@@ -176,88 +171,6 @@ certOptionsP = do
|
||||
)
|
||||
pure CertOptions {signAlgorithm_, commonName_}
|
||||
|
||||
dbOptsP :: DBOpts -> Parser DBOpts
|
||||
dbOptsP DBOpts {connstr = defDBConnStr, schema = defDBSchema, poolSize = defDBPoolSize} = do
|
||||
connstr <-
|
||||
strOption
|
||||
( long "database"
|
||||
<> short 'd'
|
||||
<> metavar "DB_CONN"
|
||||
<> help "Database connection string"
|
||||
<> value defDBConnStr
|
||||
<> showDefault
|
||||
)
|
||||
schema <-
|
||||
strOption
|
||||
( long "schema"
|
||||
<> metavar "DB_SCHEMA"
|
||||
<> help "Database schema"
|
||||
<> value defDBSchema
|
||||
<> showDefault
|
||||
)
|
||||
poolSize <-
|
||||
option
|
||||
auto
|
||||
( long "pool-size"
|
||||
<> metavar "POOL_SIZE"
|
||||
<> help "Database pool size"
|
||||
<> value defDBPoolSize
|
||||
<> showDefault
|
||||
)
|
||||
pure DBOpts {connstr, schema, poolSize, createSchema = False}
|
||||
|
||||
startOptionsP :: Parser StartOptions
|
||||
startOptionsP = do
|
||||
maintenance <-
|
||||
switch
|
||||
( long "maintenance"
|
||||
<> short 'm'
|
||||
<> help "Do not start the server, only perform start and stop tasks"
|
||||
)
|
||||
compactLog <-
|
||||
switch
|
||||
( long "compact-log"
|
||||
<> help "Compact store log (always enabled with `memory` storage for queues)"
|
||||
)
|
||||
logLevel <-
|
||||
option
|
||||
parseLogLevel
|
||||
( long "log-level"
|
||||
<> metavar "LOG_LEVEL"
|
||||
<> help "Logging level"
|
||||
<> value LogInfo
|
||||
)
|
||||
skipWarnings <-
|
||||
switch
|
||||
( long "skip-warnings"
|
||||
<> help "Start the server with non-critical start warnings"
|
||||
)
|
||||
confirmMigrations <-
|
||||
option
|
||||
parseConfirmMigrations
|
||||
( long "confirm-migrations"
|
||||
<> metavar "CONFIRM_MIGRATIONS"
|
||||
<> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
|
||||
<> value MCConsole
|
||||
)
|
||||
pure StartOptions {maintenance, compactLog, logLevel, skipWarnings, confirmMigrations}
|
||||
where
|
||||
parseConfirmMigrations :: ReadM MigrationConfirmation
|
||||
parseConfirmMigrations = eitherReader $ \case
|
||||
"up" -> Right MCYesUp
|
||||
"down" -> Right MCYesUpDown
|
||||
_ -> Left "invalid migration confirmation, pass 'up' or 'down'"
|
||||
|
||||
parseLogLevel :: ReadM LogLevel
|
||||
parseLogLevel = eitherReader $ \case
|
||||
"trace" -> Right LogTrace
|
||||
"debug" -> Right LogDebug
|
||||
"info" -> Right LogInfo
|
||||
"note" -> Right LogNote
|
||||
"warn" -> Right LogWarn
|
||||
"error" -> Right LogError
|
||||
_ -> Left "Invalid log level"
|
||||
|
||||
genOnline :: FilePath -> CertOptions -> IO ()
|
||||
genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do
|
||||
(signAlgorithm, commonName) <-
|
||||
@@ -363,7 +276,7 @@ checkSavedFingerprint cfgPath x509cfg = do
|
||||
where
|
||||
c = combine cfgPath . ($ x509cfg)
|
||||
|
||||
iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
|
||||
iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
|
||||
iniTransports ini =
|
||||
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
|
||||
ws = strictIni "TRANSPORT" "websockets" ini
|
||||
@@ -373,45 +286,20 @@ iniTransports ini =
|
||||
| otherwise = ports ws \\ smpPorts
|
||||
in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
|
||||
where
|
||||
ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
|
||||
ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
|
||||
ts t = map (\port -> (port, t, webPort == Just port))
|
||||
webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
|
||||
ports = map T.unpack . T.splitOn ","
|
||||
|
||||
iniDBOptions :: Ini -> DBOpts -> DBOpts
|
||||
iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
|
||||
DBOpts
|
||||
{ connstr = either (const connstr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
|
||||
schema = either (const schema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
|
||||
poolSize = readIniDefault poolSize "STORE_LOG" "db_pool_size" ini,
|
||||
createSchema = False
|
||||
}
|
||||
|
||||
printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
|
||||
printServerConfig protocol transports logFile = do
|
||||
printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
|
||||
printServerConfig transports logFile = do
|
||||
putStrLn $ case logFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
printServerTransports protocol transports
|
||||
|
||||
printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
|
||||
printServerTransports protocol ts = do
|
||||
forM_ ts $ \(p, ATransport t, addHTTP) -> do
|
||||
forM_ transports $ \(p, ATransport t, addHTTP) -> do
|
||||
let descr = p <> " (" <> transportName t <> ")..."
|
||||
putStrLn $ "Serving " <> protocol <> " protocol on port " <> descr
|
||||
putStrLn $ "Serving SMP protocol on port " <> descr
|
||||
when addHTTP $ putStrLn $ "Serving static site on port " <> descr
|
||||
unless (any (\(p, _, _) -> p == "443") ts) $
|
||||
putStrLn
|
||||
"\nWARNING: the clients will use port 443 by default soon.\n\
|
||||
\Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
|
||||
|
||||
printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
|
||||
printSMPServerConfig transports = \case
|
||||
SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
|
||||
SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile
|
||||
SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
|
||||
B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
|
||||
printServerTransports "SMP" transports
|
||||
|
||||
deleteDirIfExists :: FilePath -> IO ()
|
||||
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
|
||||
|
||||
@@ -8,7 +8,7 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
|
||||
|
||||
data CPClientRole = CPRNone | CPRUser | CPRAdmin
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq)
|
||||
|
||||
data ControlProtocol
|
||||
= CPAuth BasicAuth
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user