mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 11:39:56 +00:00
Compare commits
6
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
a62f3336cf | ||
|
|
df1786213c | ||
|
|
50ee2df48d | ||
|
|
4a64061aab | ||
|
|
9edefb5a56 | ||
|
|
7079c70484 |
+1
-4
@@ -1,4 +1 @@
|
||||
* @epoberezkin @spaced4ndy
|
||||
/Dockerfile @shumvgolove
|
||||
/scripts/docker/ @shumvgolove
|
||||
/scripts/main/ @shumvgolove
|
||||
* @epoberezkin @efim-poberezkin
|
||||
|
||||
@@ -1,50 +0,0 @@
|
||||
name: Build and push Docker image to Docker Hub
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- "v*"
|
||||
|
||||
jobs:
|
||||
build-and-push:
|
||||
name: Build and push Docker image
|
||||
runs-on: ubuntu-latest
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
include:
|
||||
- app: smp-server
|
||||
app_port: 5223
|
||||
- app: xftp-server
|
||||
app_port: 443
|
||||
steps:
|
||||
- name: Clone project
|
||||
uses: actions/checkout@v3
|
||||
|
||||
- name: Log in to Docker Hub
|
||||
uses: docker/login-action@v2
|
||||
with:
|
||||
username: ${{ secrets.DOCKERHUB_USERNAME }}
|
||||
password: ${{ secrets.DOCKERHUB_PASSWORD }}
|
||||
|
||||
- name: Extract metadata for Docker image
|
||||
id: meta
|
||||
uses: docker/metadata-action@v4
|
||||
with:
|
||||
images: ${{ secrets.DOCKERHUB_USERNAME }}/${{ matrix.app }}
|
||||
flavor: |
|
||||
latest=auto
|
||||
tags: |
|
||||
type=semver,pattern=v{{version}}
|
||||
type=semver,pattern=v{{major}}.{{minor}}
|
||||
type=semver,pattern=v{{major}}
|
||||
|
||||
- name: Build and push Docker image
|
||||
uses: docker/build-push-action@v4
|
||||
with:
|
||||
push: true
|
||||
build-args: |
|
||||
APP=${{ matrix.app }}
|
||||
APP_PORT=${{ matrix.app_port }}
|
||||
tags: ${{ steps.meta.outputs.tags }}
|
||||
labels: ${{ steps.meta.outputs.labels }}
|
||||
@@ -7,7 +7,3 @@ dist-newstyle/
|
||||
|
||||
cabal.project.local
|
||||
cabal.project.local~
|
||||
|
||||
.hpc/
|
||||
*.tix
|
||||
.coverage
|
||||
|
||||
-62
@@ -1,62 +0,0 @@
|
||||
ARG TAG=22.04
|
||||
|
||||
FROM ubuntu:${TAG} AS build
|
||||
|
||||
### Build stage
|
||||
|
||||
# Install curl and git and simplexmq dependencies
|
||||
RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-12 llvm-12-dev libnuma-dev
|
||||
|
||||
# Specify bootstrap Haskell versions
|
||||
ENV BOOTSTRAP_HASKELL_GHC_VERSION=8.10.7
|
||||
ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.6.2.0
|
||||
|
||||
# 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 "${BOOTSTRAP_HASKELL_GHC_VERSION}" && \
|
||||
ghcup set cabal
|
||||
|
||||
COPY . /project
|
||||
WORKDIR /project
|
||||
|
||||
ARG APP
|
||||
ARG APP_PORT
|
||||
RUN if [ -z "$APP" ] || [ -z "$APP_PORT" ]; then printf "Please spcify \$APP and \$APP_PORT build-arg.\n"; exit 1; fi
|
||||
|
||||
# Compile app
|
||||
RUN cabal update
|
||||
RUN cabal build exe:$APP
|
||||
|
||||
# Create new path containing all files needed
|
||||
RUN mkdir /final
|
||||
WORKDIR /final
|
||||
|
||||
# Strip the binary from debug symbols to reduce size
|
||||
RUN bin=$(find /project/dist-newstyle -name "$APP" -type f -executable) && \
|
||||
mv "$bin" ./ && \
|
||||
strip ./"$APP" &&\
|
||||
mv /project/scripts/docker/entrypoint-"$APP" ./entrypoint
|
||||
|
||||
### Final stage
|
||||
FROM ubuntu:${TAG}
|
||||
|
||||
# Install OpenSSL dependency
|
||||
RUN apt-get update && apt-get install -y openssl libnuma-dev
|
||||
|
||||
# Copy compiled app from build stage
|
||||
COPY --from=build /final /usr/local/bin/
|
||||
|
||||
# Open app listening port
|
||||
ARG APP_PORT
|
||||
EXPOSE $APP_PORT
|
||||
|
||||
# simplexmq requires using SIGINT to correctly preserve undelivered messages and restore them on restart
|
||||
STOPSIGNAL SIGINT
|
||||
|
||||
# Finally, execute helper script
|
||||
ENTRYPOINT [ "/usr/local/bin/entrypoint" ]
|
||||
@@ -90,11 +90,11 @@ You can either run your own SMP server locally or deploy using [Linode StackScri
|
||||
|
||||
It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
|
||||
|
||||
## Deploy SMP/XFTP servers on Linux
|
||||
## Deploy SMP server on Linux
|
||||
|
||||
You can run your SMP/XFTP server as a Linux process, optionally using a service manager for booting and restarts.
|
||||
You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
|
||||
|
||||
Notice that `smp-server` and `xftp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
|
||||
Notice that `smp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
|
||||
|
||||
```sh
|
||||
# For Ubuntu
|
||||
@@ -105,53 +105,28 @@ apt update && apt install openssl
|
||||
|
||||
#### Using Docker
|
||||
|
||||
On Linux, you can deploy smp and xftp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat).
|
||||
On Linux, you can deploy smp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat/smp-server).
|
||||
|
||||
1. Create directories for persistent Docker configuration:
|
||||
1. Create `config` and `logs` directories:
|
||||
|
||||
```sh
|
||||
mkdir -p $HOME/simplex/{xftp,smp}/{config,logs} && mkdir -p $HOME/simplex/xftp/files
|
||||
mkdir -p ~/simplex/{config,logs}
|
||||
```
|
||||
|
||||
2. Run your Docker container.
|
||||
2. Run your Docker container. You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server:
|
||||
```sh
|
||||
docker run -d \
|
||||
-e "addr=your_ip_or_domain" \
|
||||
-e "pass=password" \
|
||||
-p 5223:5223 \
|
||||
-v $HOME/simplex/config:/etc/opt/simplex:z \
|
||||
-v $HOME/simplex/logs:/var/opt/simplex:z \
|
||||
simplexchat/smp-server:latest
|
||||
```
|
||||
|
||||
- `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 \
|
||||
-e "ADDR=your_ip_or_domain" \
|
||||
-e "PASS=password" \
|
||||
-p 5223:5223 \
|
||||
-v $HOME/simplex/smp/config:/etc/opt/simplex:z \
|
||||
-v $HOME/simplex/smp/logs:/var/opt/simplex:z \
|
||||
simplexchat/smp-server:latest
|
||||
```
|
||||
#### Ubuntu
|
||||
|
||||
- `xftp-server`
|
||||
|
||||
You must change **your_ip_or_domain** and **maximum_storage**.
|
||||
```sh
|
||||
docker run -d \
|
||||
-e "ADDR=your_ip_or_domain" \
|
||||
-e "QUOTA=maximum_storage" \
|
||||
-p 443:443 \
|
||||
-v $HOME/simplex/xftp/config:/etc/opt/simplex-xftp:z \
|
||||
-v $HOME/simplex/xftp/logs:/var/opt/simplex-xftp:z \
|
||||
-v $HOME/simplex/xftp/files:/srv/xftp:z \
|
||||
simplexchat/xftp-server:latest
|
||||
```
|
||||
|
||||
#### Using installation script
|
||||
|
||||
**Please note** that currently, only Ubuntu distribution is supported.
|
||||
|
||||
You can install and setup servers automatically using our script:
|
||||
|
||||
```sh
|
||||
curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
|
||||
&& if echo 'b8cf2be103f21f9461d9a500bcd3db06ab7d01d68871b07f4bd245195cbead1d simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
|
||||
```
|
||||
For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
|
||||
|
||||
### Build from source
|
||||
|
||||
@@ -161,50 +136,31 @@ curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-c
|
||||
|
||||
On Linux, you can build smp server using Docker.
|
||||
|
||||
1. Build your images:
|
||||
1. Build your `smp-server` image:
|
||||
|
||||
```sh
|
||||
git clone https://github.com/simplex-chat/simplexmq
|
||||
cd simplexmq
|
||||
git checkout stable
|
||||
DOCKER_BUILDKIT=1 docker build -t local/smp-server --build-arg APP="smp-server" --build-arg APP_PORT="5223" . # For xmp-server
|
||||
DOCKER_BUILDKIT=1 docker build -t local/xftp-server --build-arg APP="xftp-server" --build-arg APP_PORT="443" . # For xftp-server
|
||||
DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
|
||||
```
|
||||
|
||||
2. Create directories for persistent Docker configuration:
|
||||
2. Create `config` and `logs` directories:
|
||||
|
||||
```sh
|
||||
mkdir -p $HOME/simplex/{xftp,smp}/{config,logs} && mkdir -p $HOME/simplex/xftp/files
|
||||
mkdir -p ~/simplex/{config,logs}
|
||||
```
|
||||
|
||||
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 \
|
||||
-e "ADDR=your_ip_or_domain" \
|
||||
-e "PASS=password" \
|
||||
-p 5223:5223 \
|
||||
-v $HOME/simplex/smp/config:/etc/opt/simplex:z \
|
||||
-v $HOME/simplex/smp/logs:/var/opt/simplex:z \
|
||||
simplexchat/smp-server:latest
|
||||
```
|
||||
|
||||
- `xftp-server`
|
||||
|
||||
You must change **your_ip_or_domain** and **maximum_storage**.
|
||||
```sh
|
||||
docker run -d \
|
||||
-e "ADDR=your_ip_or_domain" \
|
||||
-e "QUOTA=maximum_storage" \
|
||||
-p 443:443 \
|
||||
-v $HOME/simplex/xftp/config:/etc/opt/simplex-xftp:z \
|
||||
-v $HOME/simplex/xftp/logs:/var/opt/simplex-xftp:z \
|
||||
-v $HOME/simplex/xftp/files:/srv/xftp:z \
|
||||
simplexchat/xftp-server:latest
|
||||
```
|
||||
3. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server::
|
||||
```sh
|
||||
docker run -d \
|
||||
-e "addr=your_ip_or_domain" \
|
||||
-e "pass=password" \
|
||||
-p 5223:5223 \
|
||||
-v $HOME/simplex/config:/etc/opt/simplex:z \
|
||||
-v $HOME/simplex/logs:/var/opt/simplex:z \
|
||||
smp-server
|
||||
```
|
||||
|
||||
#### Using your distribution
|
||||
|
||||
|
||||
@@ -0,0 +1,51 @@
|
||||
FROM ubuntu:22.04 AS final
|
||||
FROM ubuntu:22.04 AS build
|
||||
|
||||
### Build stage
|
||||
|
||||
# Install curl and git and smp-related dependencies
|
||||
RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-12 llvm-12-dev libnuma-dev
|
||||
|
||||
# Install ghcup
|
||||
RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=8.10.7 BOOTSTRAP_HASKELL_CABAL_VERSION=3.6.2.0 sh
|
||||
|
||||
# Adjust PATH
|
||||
ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
|
||||
|
||||
# Set both as default
|
||||
RUN ghcup set ghc 8.10.7 && \
|
||||
ghcup set cabal
|
||||
|
||||
COPY . /project
|
||||
WORKDIR /project
|
||||
|
||||
# Compile smp-server
|
||||
RUN cabal update
|
||||
RUN cabal build exe:smp-server
|
||||
|
||||
# Strip the binary from debug symbols to reduce size
|
||||
RUN smp=$(find ./dist-newstyle -name "smp-server" -type f -executable) && \
|
||||
mv "$smp" ./ && \
|
||||
strip ./smp-server
|
||||
|
||||
### Final stage
|
||||
|
||||
FROM final
|
||||
|
||||
# Install OpenSSL dependency
|
||||
RUN apt-get update && apt-get install -y openssl libnuma-dev
|
||||
|
||||
# Copy compiled smp-server from build stage
|
||||
COPY --from=build /project/smp-server /usr/bin/smp-server
|
||||
|
||||
# Copy our helper script
|
||||
COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
|
||||
|
||||
# Open smp-server listening port
|
||||
EXPOSE 5223
|
||||
|
||||
# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
|
||||
STOPSIGNAL SIGINT
|
||||
|
||||
# Finally, execute helper script
|
||||
ENTRYPOINT [ "/usr/bin/entrypoint" ]
|
||||
@@ -0,0 +1,22 @@
|
||||
FROM ubuntu:focal
|
||||
|
||||
# Install curl
|
||||
RUN apt-get update && apt-get install -y curl
|
||||
|
||||
ARG version=undefined
|
||||
|
||||
# Download latest smp-server release and assign executable permission
|
||||
RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64 -o /usr/bin/smp-server && \
|
||||
chmod +x /usr/bin/smp-server
|
||||
|
||||
# Copy our helper script
|
||||
COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
|
||||
|
||||
# Open smp-server listening port
|
||||
EXPOSE 5223
|
||||
|
||||
# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
|
||||
STOPSIGNAL SIGINT
|
||||
|
||||
# Finally, execute helper script
|
||||
ENTRYPOINT [ "/usr/bin/entrypoint" ]
|
||||
-144
@@ -1,144 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
# Links to scripts/configs
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
|
||||
|
||||
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"
|
||||
path_bin_smp="$path_bin/smp-server"
|
||||
path_bin_xftp="$path_bin/xftp-server"
|
||||
path_bin_update="$path_bin/simplex-servers-update"
|
||||
path_bin_uninstall="$path_bin/simplex-servers-uninstall"
|
||||
path_bin_stopscript="$path_bin/simplex-servers-stopscript"
|
||||
|
||||
path_conf_etc="/etc/opt"
|
||||
path_conf_var="/var/opt"
|
||||
path_conf_smp="$path_conf_etc/simplex $path_conf_var/simplex"
|
||||
path_conf_xftp="$path_conf_etc/simplex-xftp $path_conf_var/simplex-xftp /srv/xftp"
|
||||
|
||||
path_systemd="/etc/systemd/system"
|
||||
path_systemd_smp="$path_systemd/smp-server.service"
|
||||
path_systemd_xftp="$path_systemd/xftp-server.service"
|
||||
|
||||
# Defaut users
|
||||
user_smp="smp"
|
||||
user_xftp="xftp"
|
||||
|
||||
GRN='\033[0;32m'
|
||||
BLU='\033[1;34m'
|
||||
YLW='\033[1;33m'
|
||||
RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
|
||||
logo='
|
||||
____ _ _ __ __
|
||||
/ ___|(_)_ __ ___ _ __ | | ___\ \/ /
|
||||
\___ \| | '"'"'_ ` _ \| '"'"'_ \| |/ _ \\ /
|
||||
___) | | | | | | | |_) | | __// \
|
||||
|____/|_|_| |_| |_| .__/|_|\___/_/\_\
|
||||
|_|
|
||||
'
|
||||
|
||||
welcome="Welcome to SMP/XFTP installation script! Here's what we're going to do:
|
||||
${GRN}1.${NC} Install latest binaries from GitHub releases:
|
||||
- smp: ${YLW}${path_bin_smp}${NC}
|
||||
- xftp: ${YLW}${path_bin_xftp}${NC}
|
||||
${GRN}2.${NC} Create server directories:
|
||||
- smp: ${YLW}${path_conf_smp}${NC}
|
||||
- xftp: ${YLW}${path_conf_xftp}${NC}
|
||||
${GRN}3.${NC} Setup user for each server:
|
||||
- xmp: ${YLW}${user_smp}${NC}
|
||||
- xftp: ${YLW}${user_xftp}${NC}
|
||||
${GRN}4.${NC} Create systemd services:
|
||||
- smp: ${YLW}${path_systemd_smp}${NC}
|
||||
- xftp: ${YLW}${path_systemd_xftp}${NC}
|
||||
${GRN}5.${NC} Install stopscript (systemd), update and uninstallation script:
|
||||
- all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}, ${YLW}${path_bin_stopscript}${NC}
|
||||
|
||||
Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
|
||||
|
||||
end="Installtion is complete!
|
||||
|
||||
Please checkout our server guides:
|
||||
- smp: ${GRN}https://simplex.chat/docs/server.html${NC}
|
||||
- xftp: ${GRN}https://simplex.chat/docs/xftp-server.html${NC}
|
||||
|
||||
To uninstall with full clean-up, simply run: ${YLW}sudo /usr/local/bin/simplex-servers-uninstall${NC}
|
||||
"
|
||||
|
||||
setup_bins() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
}
|
||||
|
||||
setup_users() {
|
||||
useradd -M "$user_smp" 2> /dev/null || true
|
||||
useradd -M "$user_xftp" 2> /dev/null || true
|
||||
}
|
||||
|
||||
setup_dirs() {
|
||||
# Unquoted varibles, so field splitting can occur
|
||||
mkdir -p $path_conf_smp
|
||||
chown "$user_smp":"$user_smp" $path_conf_smp
|
||||
mkdir -p $path_conf_xftp
|
||||
chown "$user_xftp":"$user_xftp" $path_conf_xftp
|
||||
}
|
||||
|
||||
setup_systemd() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_systemd_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_systemd_xftp"
|
||||
}
|
||||
|
||||
setup_scripts() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_bin_update" && chmod +x "$path_bin_update"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_bin_uninstall" && chmod +x "$path_bin_uninstall"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_bin_stopscript" && chmod +x "$path_bin_stopscript"
|
||||
}
|
||||
|
||||
checks() {
|
||||
if [ "$(id -u)" -ne 0 ]; then
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo."
|
||||
exit 1
|
||||
fi
|
||||
}
|
||||
|
||||
main() {
|
||||
checks
|
||||
|
||||
printf "%b\n%b\n" "${BLU}$logo${NC}" "$welcome"
|
||||
read ans
|
||||
|
||||
printf "Installing binaries..."
|
||||
setup_bins
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating users..."
|
||||
setup_users
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating directories..."
|
||||
setup_dirs
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating systemd services..."
|
||||
setup_systemd
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Installing stopscript, update and uninstallation script..."
|
||||
setup_scripts
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "%b" "$end"
|
||||
}
|
||||
|
||||
main
|
||||
+1
-1
@@ -1,5 +1,5 @@
|
||||
name: simplexmq
|
||||
version: 5.1.2
|
||||
version: 5.0.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: |
|
||||
This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
|
||||
Executable
+28
@@ -0,0 +1,28 @@
|
||||
#!/usr/bin/env sh
|
||||
confd="/etc/opt/simplex"
|
||||
logd="/var/opt/simplex/"
|
||||
|
||||
# Check if server has been initialized
|
||||
if [ ! -f "$confd/smp-server.ini" ]; then
|
||||
# If not, determine ip or domain
|
||||
case $addr in
|
||||
'') printf "Please specify \$addr environment variable.\n"; exit 1 ;;
|
||||
*[a-zA-Z]*) set -- -n $addr ;;
|
||||
*) set -- --ip $addr ;;
|
||||
esac
|
||||
|
||||
case $pass in
|
||||
'') set -- "$@" --no-password ;;
|
||||
*) set -- "$@" --password $pass ;;
|
||||
esac
|
||||
|
||||
smp-server init -y -l "$@"
|
||||
fi
|
||||
|
||||
# backup store log
|
||||
[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log."$(date +'%FT%T')"
|
||||
|
||||
# Finally, run smp-sever. Notice that "exec" here is important:
|
||||
# smp-server replaces our helper script, so that it can catch INT signal
|
||||
exec smp-server start +RTS -N -RTS
|
||||
|
||||
@@ -1,48 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
confd='/etc/opt/simplex'
|
||||
logd='/var/opt/simplex/'
|
||||
|
||||
# Check if server has been initialized
|
||||
if [ ! -f "${confd}/smp-server.ini" ]; then
|
||||
# If not, determine ip or domain
|
||||
case "${ADDR}" in
|
||||
'') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;;
|
||||
*[a-zA-Z]*)
|
||||
case "${ADDR}" in
|
||||
*:*) set -- --ip "${ADDR}" ;;
|
||||
*) set -- -n "${ADDR}" ;;
|
||||
esac
|
||||
;;
|
||||
*) set -- --ip "${ADDR}" ;;
|
||||
esac
|
||||
|
||||
# Optionally, set password
|
||||
case "${PASS}" in
|
||||
'') set -- "$@" --no-password ;;
|
||||
*) set -- "$@" --password "${PASS}" ;;
|
||||
esac
|
||||
|
||||
# And init certificates and configs
|
||||
smp-server init -y -l "$@"
|
||||
fi
|
||||
|
||||
# Backup store log just in case
|
||||
#
|
||||
# Uses the UTC (universal) time zone and this
|
||||
# format: YYYY-mm-dd'T'HH:MM:SS
|
||||
# year, month, day, letter T, hour, minute, second
|
||||
#
|
||||
# This is the ISO 8601 format without the time zone at the end.
|
||||
#
|
||||
_file="${logd}/smp-server-store.log"
|
||||
if [ -f "${_file}" ]; then
|
||||
_backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')"
|
||||
cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}"
|
||||
unset -v _backup_extension
|
||||
fi
|
||||
unset -v _file
|
||||
|
||||
# Finally, run smp-sever. Notice that "exec" here is important:
|
||||
# smp-server replaces our helper script, so that it can catch INT signal
|
||||
exec smp-server start +RTS -N -RTS
|
||||
|
||||
@@ -1,48 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
confd='/etc/opt/simplex-xftp'
|
||||
logd='/var/opt/simplex-xftp'
|
||||
|
||||
# Check if server has been initialized
|
||||
if [ ! -f "${confd}/file-server.ini" ]; then
|
||||
# If not, determine ip or domain
|
||||
case "${ADDR}" in
|
||||
'') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;;
|
||||
*[a-zA-Z]*)
|
||||
case "${ADDR}" in
|
||||
*:*) set -- --ip "${ADDR}" ;;
|
||||
*) set -- -n "${ADDR}" ;;
|
||||
esac
|
||||
;;
|
||||
*) set -- --ip "${ADDR}" ;;
|
||||
esac
|
||||
|
||||
# Set quota
|
||||
case "${QUOTA}" in
|
||||
'') printf 'Please specify $QUOTA environment variable.\n'; exit 1 ;;
|
||||
*) set -- "$@" --quota "${QUOTA}" ;;
|
||||
esac
|
||||
|
||||
# Init the certificates and configs
|
||||
xftp-server init -l -p /srv/xftp "$@"
|
||||
fi
|
||||
|
||||
# Backup store log just in case
|
||||
#
|
||||
# Uses the UTC (universal) time zone and this
|
||||
# format: YYYY-mm-dd'T'HH:MM:SS
|
||||
# year, month, day, letter T, hour, minute, second
|
||||
#
|
||||
# This is the ISO 8601 format without the time zone at the end.
|
||||
#
|
||||
_file="${logd}/file-server-store.log"
|
||||
if [ -f "${_file}" ]; then
|
||||
_backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')"
|
||||
cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}"
|
||||
unset -v _backup_extension
|
||||
fi
|
||||
unset -v _file
|
||||
|
||||
# Finally, run xftp-sever. Notice that "exec" here is important:
|
||||
# smp-server replaces our helper script, so that it can catch INT signal
|
||||
exec xftp-server start +RTS -N -RTS
|
||||
|
||||
@@ -1,30 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
path_conf_var="/var/opt"
|
||||
path_conf_smp="$path_conf_var/simplex"
|
||||
path_conf_xftp="$path_conf_var/simplex-xftp"
|
||||
path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
|
||||
path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
|
||||
date="$(date -u '+%Y-%m-%dT%H:%M:%S')"
|
||||
|
||||
backup_smp() {
|
||||
if [ -e "$path_conf_storelog_smp" ]; then
|
||||
cp "$path_conf_storelog_smp" "${path_conf_storelog_smp}.${date:-date-failed}"
|
||||
fi
|
||||
}
|
||||
|
||||
backup_xftp() {
|
||||
if [ -e "$path_conf_storelog_xftp" ]; then
|
||||
cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
|
||||
fi
|
||||
}
|
||||
|
||||
if [ "$1" = 'smp-server' ]; then
|
||||
backup_smp
|
||||
elif [ "$1" = 'xftp-server' ]; then
|
||||
backup_xftp
|
||||
else
|
||||
backup_smp
|
||||
backup_xftp
|
||||
fi
|
||||
@@ -1,23 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
GRN='\033[0;32m'
|
||||
RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
|
||||
if [ "$(id -u)" -ne 0 ]; then
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
printf "${RED}This action will permanently remove all configs, directories, binaries from Installation Script. Please backup any relevant configs if they are needed.${NC}\n\nPress ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
|
||||
read ans
|
||||
|
||||
systemctl stop smp-server
|
||||
systemctl stop xftp-server
|
||||
|
||||
rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall
|
||||
|
||||
userdel smp && userdel xftp
|
||||
|
||||
printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"
|
||||
@@ -1,174 +0,0 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
# Links to scripts/configs
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
|
||||
|
||||
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"
|
||||
path_bin_smp="$path_bin/smp-server"
|
||||
path_bin_xftp="$path_bin/xftp-server"
|
||||
path_bin_update="$path_bin/simplex-servers-update"
|
||||
path_bin_uninstall="$path_bin/simplex-servers-uninstall"
|
||||
path_bin_stopscript="$path_bin/simplex-servers-stopscript"
|
||||
|
||||
path_systemd="/etc/systemd/system"
|
||||
path_systemd_smp="$path_systemd/smp-server.service"
|
||||
path_systemd_xftp="$path_systemd/xftp-server.service"
|
||||
|
||||
# Temporary paths
|
||||
path_tmp_bin="$(mktemp -d)"
|
||||
path_tmp_bin_update="$path_tmp_bin/simplex-servers-update"
|
||||
path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall"
|
||||
path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
|
||||
path_tmp_systemd_smp="$path_tmp_bin/smp-server.service"
|
||||
path_tmp_systemd_xftp="$path_tmp_bin/xftp-server.service"
|
||||
|
||||
GRN='\033[0;32m'
|
||||
BLU='\033[1;36m'
|
||||
YLW='\033[1;33m'
|
||||
RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
|
||||
# Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
|
||||
local_version="$($path_bin_smp -v | awk '{print $3}')"
|
||||
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}')"
|
||||
|
||||
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
|
||||
if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_stopscript"
|
||||
else
|
||||
printf -- "- Updating stopscript script..."
|
||||
mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
|
||||
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
|
||||
}
|
||||
|
||||
update_systemd() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_tmp_systemd_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_tmp_systemd_xftp"
|
||||
|
||||
if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}smp-server service is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_systemd_smp"
|
||||
else
|
||||
printf -- "- Updating smp-server service..."
|
||||
mv "$path_tmp_systemd_smp" "$path_systemd_smp"
|
||||
systemctl daemon-reload
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}xftp-server service is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_systemd_xftp"
|
||||
else
|
||||
printf -- "- Updating xftp-server service..."
|
||||
mv "$path_tmp_systemd_xftp" "$path_systemd_xftp"
|
||||
systemctl daemon-reload
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
}
|
||||
|
||||
update_bins() {
|
||||
if [ "$local_version" != "$remote_version" ]; then
|
||||
if systemctl is-active --quiet smp-server; then
|
||||
printf -- "- Stopping smp-server service..."
|
||||
systemctl stop smp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Updating smp-server bin to %s..." "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Starting smp-server service..."
|
||||
systemctl start smp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
else
|
||||
printf -- "- Updating smp-server bin..."
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
if systemctl is-active --quiet xftp-server; then
|
||||
printf -- "- Stopping xftp-server service..."
|
||||
systemctl stop xftp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Updating xftp-server bin to %s..." "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Starting xftp-server service..."
|
||||
systemctl start xftp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
else
|
||||
printf -- "- Updating xftp-server bin..."
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
else
|
||||
printf -- "- ${YLW}smp-server and xftp-server binaries is up-to-date${NC}.\n"
|
||||
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
|
||||
}
|
||||
|
||||
main() {
|
||||
checks
|
||||
|
||||
set +u
|
||||
if [ "$1" != "continue" ]; then
|
||||
set -u
|
||||
printf "Updating scripts...\n"
|
||||
update_scripts
|
||||
else
|
||||
set -u
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
printf "Updating systemd services...\n"
|
||||
update_systemd
|
||||
|
||||
printf "Updating simplex server binaries...\n"
|
||||
update_bins
|
||||
|
||||
rm -rf "$path_tmp_bin"
|
||||
}
|
||||
|
||||
main "$@"
|
||||
@@ -1,15 +0,0 @@
|
||||
[Unit]
|
||||
Description=SMP server
|
||||
|
||||
[Service]
|
||||
User=smp
|
||||
Group=smp
|
||||
Type=simple
|
||||
ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS
|
||||
ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
|
||||
LimitNOFILE=65535
|
||||
KillSignal=SIGINT
|
||||
TimeoutStopSec=infinity
|
||||
|
||||
[Install]
|
||||
WantedBy=multi-user.target
|
||||
@@ -1,16 +0,0 @@
|
||||
[Unit]
|
||||
Description=XFTP server
|
||||
|
||||
[Service]
|
||||
User=xftp
|
||||
Group=xftp
|
||||
Type=simple
|
||||
ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
|
||||
ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
|
||||
LimitNOFILE=65535
|
||||
KillSignal=SIGINT
|
||||
TimeoutStopSec=infinity
|
||||
AmbientCapabilities=CAP_NET_BIND_SERVICE
|
||||
|
||||
[Install]
|
||||
WantedBy=multi-user.target
|
||||
+1
-4
@@ -5,7 +5,7 @@ cabal-version: 1.12
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: simplexmq
|
||||
version: 5.1.2
|
||||
version: 5.0.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -80,9 +80,6 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
|
||||
Simplex.Messaging.Agent.TAsyncs
|
||||
Simplex.Messaging.Agent.TRcvQueues
|
||||
Simplex.Messaging.Client
|
||||
|
||||
@@ -390,6 +390,8 @@ runXFTPSndPrepareWorker c doWork = do
|
||||
else pure sndFile
|
||||
maxRecipients <- asks (xftpMaxRecipientsPerRequest . config)
|
||||
let numRecipients' = min numRecipients maxRecipients
|
||||
liftIO $ print "finished encrypting"
|
||||
threadDelay 10000000
|
||||
-- concurrently?
|
||||
forM_ (filter (not . chunkCreated) chunks) $ createChunk numRecipients'
|
||||
withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
|
||||
@@ -415,7 +417,7 @@ runXFTPSndPrepareWorker c doWork = do
|
||||
createChunk :: Int -> SndFileChunk -> m ()
|
||||
createChunk numRecipients' ch = do
|
||||
atomically $ assertAgentForeground c
|
||||
(replica, ProtoServerWithAuth srv _) <- tryCreate
|
||||
(replica, ProtoServerWithAuth srv _) <- agentOperationBracket c AOSndNetwork throwWhenInactive tryCreate
|
||||
withStore' c $ \db -> createSndFileReplica db ch replica
|
||||
addXFTPSndWorker c $ Just srv
|
||||
where
|
||||
@@ -445,7 +447,7 @@ runXFTPSndWorker c srv doWork = do
|
||||
forever $ do
|
||||
void . atomically $ readTMVar doWork
|
||||
atomically $ assertAgentForeground c
|
||||
runXFTPOperation
|
||||
agentOperationBracket c AOSndNetwork throwWhenInactive runXFTPOperation
|
||||
where
|
||||
noWorkToDo = void . atomically $ tryTakeTMVar doWork
|
||||
runXFTPOperation :: m ()
|
||||
@@ -463,6 +465,7 @@ runXFTPSndWorker c srv doWork = do
|
||||
`catchError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
|
||||
where
|
||||
retryLoop loop e replicaDelay = do
|
||||
liftIO $ print $ "replica " <> show sndChunkReplicaId <> " temporary error" <> show e
|
||||
flip catchError (\_ -> pure ()) $ do
|
||||
notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
|
||||
when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
|
||||
@@ -470,7 +473,9 @@ runXFTPSndWorker c srv doWork = do
|
||||
withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
|
||||
atomically $ assertAgentForeground c
|
||||
loop
|
||||
retryDone e = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e)
|
||||
retryDone e = do
|
||||
liftIO $ print $ "replica " <> show sndChunkReplicaId <> " permanent error" <> show e
|
||||
sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e)
|
||||
uploadFileChunk :: SndFileChunk -> SndFileChunkReplica -> m ()
|
||||
uploadFileChunk sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
|
||||
replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
|
||||
|
||||
@@ -9,6 +9,7 @@
|
||||
|
||||
module Simplex.FileTransfer.Client where
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.Except
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
@@ -135,23 +136,33 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
|
||||
xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
|
||||
let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
|
||||
reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
|
||||
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
|
||||
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
|
||||
-- TODO validate that the file ID is the same as in the request?
|
||||
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead
|
||||
case respOrErr of
|
||||
Right r -> case protocolError r of
|
||||
Just e -> throwError $ PCEProtocolError e
|
||||
_ -> pure (r, body)
|
||||
Left e -> throwError $ PCEResponseError e
|
||||
res <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
|
||||
case res of
|
||||
HTTP2RequestResponse HTTP2Response {respBody = body@HTTP2Body {bodyHead}} -> do
|
||||
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
|
||||
-- TODO validate that the file ID is the same as in the request?
|
||||
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead
|
||||
case respOrErr of
|
||||
Right r -> case protocolError r of
|
||||
Just e -> throwError $ PCEProtocolError e
|
||||
_ -> pure (r, body)
|
||||
Left e -> throwError $ PCEResponseError e
|
||||
HTTP2RequestError e -> do
|
||||
liftIO $ print $ "in sendXFTPCommand HTTP2RequestError" <> show e
|
||||
throwError $ PCEInternalError $ show e
|
||||
where
|
||||
streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
|
||||
streamBody t send done = do
|
||||
send $ byteString t
|
||||
forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
|
||||
withFile filePath ReadMode $ \h -> do
|
||||
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
|
||||
sendFile h send $ fromIntegral chunkSize
|
||||
do
|
||||
( withFile filePath ReadMode $ \h -> do
|
||||
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
|
||||
sendFile h send $ fromIntegral chunkSize
|
||||
)
|
||||
`E.catch` \(e :: SomeException) -> do
|
||||
print $ "in sendXFTPCommand streamBody " <> show e
|
||||
E.throw e
|
||||
done
|
||||
|
||||
createXFTPChunk ::
|
||||
|
||||
@@ -68,13 +68,10 @@ data XFTPEnv = XFTPEnv
|
||||
serverStats :: FileServerStats
|
||||
}
|
||||
|
||||
defFileExpirationHours :: Int64
|
||||
defFileExpirationHours = 48
|
||||
|
||||
defaultFileExpiration :: ExpirationConfig
|
||||
defaultFileExpiration =
|
||||
ExpirationConfig
|
||||
{ ttl = defFileExpirationHours * 3600, -- seconds
|
||||
{ ttl = 48 * 3600, -- seconds, 48 hours
|
||||
checkInterval = 2 * 3600 -- seconds, 2 hours
|
||||
}
|
||||
|
||||
|
||||
@@ -18,12 +18,11 @@ import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.FileTransfer.Description (FileSize (..), kb, mb)
|
||||
import Simplex.FileTransfer.Server (runXFTPServer)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defFileExpirationHours)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
@@ -31,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
xftpServerVersion :: String
|
||||
xftpServerVersion = "1.0.0"
|
||||
xftpServerVersion = "0.1.0"
|
||||
|
||||
xftpServerCLI :: FilePath -> FilePath -> IO ()
|
||||
xftpServerCLI cfgPath logPath = do
|
||||
@@ -77,8 +76,6 @@ xftpServerCLI cfgPath logPath = do
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Expire files after the specified number of hours.\n"
|
||||
<> ("expire_files_hours: " <> show defFileExpirationHours <> "\n\n")
|
||||
<> "log_stats: off\n\
|
||||
\\n\
|
||||
\[AUTH]\n\
|
||||
@@ -116,13 +113,10 @@ xftpServerCLI cfgPath logPath = do
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration} = do
|
||||
printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile} = do
|
||||
putStrLn $ case storeLogFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
putStrLn $ case fileExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
|
||||
_ -> "not expiring files"
|
||||
putStrLn $
|
||||
"Uploading new files "
|
||||
<> if allowNewFiles
|
||||
@@ -140,10 +134,7 @@ xftpServerCLI cfgPath logPath = do
|
||||
allowedChunkSizes = [kb 256, mb 1, mb 4],
|
||||
allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
|
||||
newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
|
||||
fileExpiration =
|
||||
Just defaultFileExpiration
|
||||
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
|
||||
},
|
||||
fileExpiration = Just defaultFileExpiration,
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile,
|
||||
|
||||
+71
-188
@@ -63,7 +63,6 @@ module Simplex.Messaging.Agent
|
||||
sendMessage,
|
||||
ackMessage,
|
||||
switchConnection,
|
||||
abortConnectionSwitch,
|
||||
suspendConnection,
|
||||
deleteConnection,
|
||||
deleteConnections,
|
||||
@@ -111,7 +110,7 @@ import Data.Composition ((.:), (.:.), (.::))
|
||||
import Data.Foldable (foldl')
|
||||
import Data.Functor (($>))
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
@@ -205,7 +204,7 @@ ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> Conn
|
||||
ackMessageAsync c = withAgentEnv c .:. ackMessageAsync' c
|
||||
|
||||
-- | Switch connection to the new receive queue
|
||||
switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
|
||||
switchConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> m ()
|
||||
switchConnectionAsync c = withAgentEnv c .: switchConnectionAsync' c
|
||||
|
||||
-- | Delete SMP agent connection (DEL command) asynchronously, no synchronous response
|
||||
@@ -269,10 +268,6 @@ ackMessage c = withAgentEnv c .: ackMessage' c
|
||||
switchConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
|
||||
switchConnection c = withAgentEnv c . switchConnection' c
|
||||
|
||||
-- | Abort switching connection to the new receive queue
|
||||
abortConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
|
||||
abortConnectionSwitch c = withAgentEnv c . abortConnectionSwitch' c
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command)
|
||||
suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
||||
suspendConnection c = withAgentEnv c . suspendConnection' c
|
||||
@@ -529,18 +524,11 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of
|
||||
deleteConnQueues c True rqs >> onSuccess
|
||||
|
||||
-- | Add connection to the new receive queue
|
||||
switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ConnectionStats
|
||||
switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ()
|
||||
switchConnectionAsync' c corrId connId =
|
||||
withConnLock c connId "switchConnectionAsync" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
|
||||
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
|
||||
| otherwise -> do
|
||||
rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
|
||||
let rqs' = updatedQs rq1 rqs
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
|
||||
newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
|
||||
newConn c userId connId enableNtfs cMode clientData =
|
||||
@@ -879,12 +867,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
|
||||
notify OK
|
||||
LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
|
||||
ACK msgId -> withServer' . tryCommand $ ackMessage' c connId msgId >> notify OK
|
||||
SWCH ->
|
||||
noServer . tryCommand . withConnLock c connId "switchConnection" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) ->
|
||||
switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
SWCH -> noServer $ tryCommand $ switchConnection' c connId >>= notify . SWITCH QDRcv SPStarted
|
||||
DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK
|
||||
_ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd)
|
||||
AInternalCommand cmd -> case cmd of
|
||||
@@ -904,24 +887,13 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
|
||||
enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
|
||||
-- ICDeleteConn is no longer used, but it can be present in old client databases
|
||||
ICDeleteConn -> withStore' c (`deleteCommand` cmdId)
|
||||
ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do
|
||||
rq <- withStore c (\db -> getDeletedRcvQueue db connId srv rId)
|
||||
deleteQueue c rq
|
||||
withStore' c (`deleteConnRcvQueue` rq)
|
||||
ICQSecure rId senderKey ->
|
||||
withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) ->
|
||||
case find (sameQueue (srv, rId)) rqs of
|
||||
Just rq'@RcvQueue {server, sndId, status, dbReplaceQueueId = Just replaceQId} ->
|
||||
case find ((replaceQId ==) . dbQId) rqs of
|
||||
Just rq1 -> when (status == Confirmed) $ do
|
||||
secureQueue c rq' senderKey
|
||||
withStore' c $ \db -> setRcvQueueStatus db rq' Secured
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
|
||||
rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 $ Just RSSendingQUSE
|
||||
let rqs' = updatedQs rq1' rqs
|
||||
conn' = DuplexConnection cData rqs' sqs
|
||||
notify . SWITCH QDRcv SPSecured $ connectionStats conn'
|
||||
_ -> internalErr "ICQSecure: no switching queue found"
|
||||
Just rq'@RcvQueue {server, sndId, status} -> when (status == Confirmed) $ do
|
||||
secureQueue c rq' senderKey
|
||||
withStore' c $ \db -> setRcvQueueStatus db rq' Secured
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
|
||||
_ -> internalErr "ICQSecure: queue address not found in connection"
|
||||
ICQDelete rId -> do
|
||||
withServer $ \srv -> tryWithLock "ICQDelete" . withDuplexConn $ \(DuplexConnection cData rqs sqs) -> do
|
||||
@@ -930,20 +902,13 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
|
||||
Just (rq'@RcvQueue {primary}, rq'' : rqs')
|
||||
| primary -> internalErr "ICQDelete: cannot delete primary rcv queue"
|
||||
| otherwise -> do
|
||||
checkRQSwchStatus rq' RSReceivedMessage
|
||||
tryError (deleteQueue c rq') >>= \case
|
||||
Right () -> finalizeSwitch
|
||||
Left e
|
||||
| temporaryOrHostError e -> throwError e
|
||||
| otherwise -> finalizeSwitch >> throwError e
|
||||
where
|
||||
finalizeSwitch = do
|
||||
withStore' c $ \db -> deleteConnRcvQueue db rq'
|
||||
when (enableNtfs cData) $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||
let conn' = DuplexConnection cData (rq'' :| rqs') sqs
|
||||
notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
|
||||
deleteQueue c rq'
|
||||
withStore' c $ \db -> deleteConnRcvQueue db rq'
|
||||
when (enableNtfs cData) $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||
let conn' = DuplexConnection cData (rq'' :| rqs') sqs
|
||||
notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
|
||||
_ -> internalErr "ICQDelete: cannot delete the only queue in connection"
|
||||
where
|
||||
ack srv rId srvMsgId = do
|
||||
@@ -1147,11 +1112,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
|
||||
AM_A_MSG_ -> notify $ SENT mId
|
||||
AM_QCONT_ -> pure ()
|
||||
AM_QADD_ -> pure ()
|
||||
AM_QKEY_ -> do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
notify . SWITCH QDSnd SPConfirmed $ connectionStats conn
|
||||
AM_QKEY_ -> pure ()
|
||||
AM_QUSE_ -> pure ()
|
||||
AM_QTEST_ -> withConnLock c connId "runSmpQueueMsgDelivery AM_QTEST_" $ do
|
||||
AM_QTEST_ -> do
|
||||
withStore' c $ \db -> setSndQueueStatus db sq Active
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
@@ -1162,10 +1125,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
|
||||
-- this is the same queue where this loop delivers messages to but with updated state
|
||||
Just SndQueue {dbReplaceQueueId = Just replacedId, primary} ->
|
||||
-- second part of this condition is a sanity check because dbReplaceQueueId cannot point to the same queue, see switchConnection'
|
||||
case removeQP (\sq' -> dbQId sq' == replacedId && not (sameQueue addr sq')) sqs of
|
||||
case removeQP (\sq'@SndQueue {dbQueueId} -> dbQueueId == replacedId && not (sameQueue addr sq')) sqs of
|
||||
Nothing -> internalErr msgId "sent QTEST: queue not found in connection"
|
||||
Just (sq', sq'' : sqs') -> do
|
||||
checkSQSwchStatus sq' SSSendingQTEST
|
||||
-- remove the delivery from the map to stop the thread when the delivery loop is complete
|
||||
atomically $ TM.delete (qAddress sq') $ smpQueueMsgQueues c
|
||||
withStore' c $ \db -> do
|
||||
@@ -1216,54 +1178,21 @@ ackMessage' c connId msgId = withConnLock c connId "ackMessage" $ do
|
||||
withStore' c $ \db -> deleteMsg db connId mId
|
||||
|
||||
switchConnection' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
|
||||
switchConnection' c connId =
|
||||
withConnLock c connId "switchConnection" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ conn@(DuplexConnection _ rqs@(rq :| _rqs) _)
|
||||
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
|
||||
| otherwise -> do
|
||||
rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
|
||||
switchDuplexConnection c conn rq'
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
|
||||
switchDuplexConnection :: AgentMonad m => AgentClient -> Connection 'CDuplex -> RcvQueue -> m ConnectionStats
|
||||
switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId, sndId} = do
|
||||
checkRQSwchStatus rq RSSwitchStarted
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth
|
||||
(q, qUri) <- newRcvQueue c userId connId srv' clientVRange
|
||||
let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
void . withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
addSubscription c rq'
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
|
||||
rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSendingQADD
|
||||
let rqs' = updatedQs rq1 rqs <> [rq']
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
|
||||
abortConnectionSwitch' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
|
||||
abortConnectionSwitch' c connId =
|
||||
withConnLock c connId "abortConnectionSwitch" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
|
||||
Just rq
|
||||
| canAbortRcvSwitch rq -> do
|
||||
-- multiple queues to which the connections switches were possible when repeating switch was allowed
|
||||
let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
|
||||
case L.nonEmpty keepRqs of
|
||||
Just rqs' -> do
|
||||
rq' <- withStore' c $ \db -> do
|
||||
mapM_ (setRcvQueueDeleted db) delRqs
|
||||
setRcvSwitchStatus db rq Nothing
|
||||
forM_ delRqs $ \RcvQueue {server, rcvId} -> enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICDeleteRcvQueue rcvId
|
||||
let rqs'' = updatedQs rq' rqs'
|
||||
conn' = DuplexConnection cData rqs'' sqs
|
||||
pure $ connectionStats conn'
|
||||
_ -> throwError $ INTERNAL "won't delete all rcv queues in connection"
|
||||
| otherwise -> throwError $ CMD PROHIBITED
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
switchConnection' c connId = withConnLock c connId "switchConnection" $ do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
DuplexConnection cData@ConnData {userId} rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth
|
||||
(q, qUri) <- newRcvQueue c userId connId srv' clientVRange
|
||||
let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
void . withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
addSubscription c rq'
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
|
||||
pure . connectionStats $ DuplexConnection cData (rq <| rq' :| rqs_) sqs
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
|
||||
ackQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> SMP.MsgId -> m ()
|
||||
ackQueueMessage c rq srvMsgId =
|
||||
@@ -1402,11 +1331,11 @@ getConnectionRatchetAdHash' c connId = do
|
||||
|
||||
connectionStats :: Connection c -> ConnectionStats
|
||||
connectionStats = \case
|
||||
RcvConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
|
||||
SndConnection _ sq -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [sndQueueInfo sq]}
|
||||
DuplexConnection _ rqs sqs -> ConnectionStats {rcvQueuesInfo = map rcvQueueInfo $ L.toList rqs, sndQueuesInfo = map sndQueueInfo $ L.toList sqs}
|
||||
ContactConnection _ rq -> ConnectionStats {rcvQueuesInfo = [rcvQueueInfo rq], sndQueuesInfo = []}
|
||||
NewConnection _ -> ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = []}
|
||||
RcvConnection _ rq -> ConnectionStats {rcvServers = [qServer rq], sndServers = []}
|
||||
SndConnection _ sq -> ConnectionStats {rcvServers = [], sndServers = [qServer sq]}
|
||||
DuplexConnection _ rqs sqs -> ConnectionStats {rcvServers = map qServer $ L.toList rqs, sndServers = map qServer $ L.toList sqs}
|
||||
ContactConnection _ rq -> ConnectionStats {rcvServers = [qServer rq], sndServers = []}
|
||||
NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
|
||||
|
||||
-- | Change servers to be used for creating new queues, in Reader monad
|
||||
setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
|
||||
@@ -1672,7 +1601,6 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
forever $ do
|
||||
void . runExceptT $ do
|
||||
deleteConns `catchError` (notify "" . ERR)
|
||||
deleteRcvMsgHashes `catchError` (notify "" . ERR)
|
||||
deleteRcvFilesExpired `catchError` (notify "" . RFERR)
|
||||
deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
|
||||
deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
|
||||
@@ -1686,9 +1614,6 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
withLock (deleteLock c) "cleanupManager" $ do
|
||||
void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
|
||||
withStore' c deleteUsersWithoutConns >>= mapM_ (notify "" . DEL_USER)
|
||||
deleteRcvMsgHashes = do
|
||||
rcvMsgHashesTTL <- asks $ rcvMsgHashesTTL . config
|
||||
withStore' c (`deleteRcvMsgHashesExpired` rcvMsgHashesTTL)
|
||||
deleteRcvFilesExpired = do
|
||||
rcvFilesTTL <- asks $ rcvFilesTTL . config
|
||||
rcvExpired <- withStore' c (`getRcvFilesExpired` rcvFilesTTL)
|
||||
@@ -1727,8 +1652,6 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
notify :: forall e. AEntityI e => EntityId -> ACommand 'Agent e -> ExceptT AgentErrorType m ()
|
||||
notify entId cmd = atomically $ writeTBQueue subQ ("", entId, APC (sAEntity @e) cmd)
|
||||
|
||||
-- | make sure to ACK or throw in each message processing branch
|
||||
-- it cannot be finally, unfortunately, as sometimes it needs to be ACK+DEL
|
||||
processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
|
||||
processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do
|
||||
(rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId)
|
||||
@@ -1769,15 +1692,12 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
case (conn, dbReplaceQueueId) of
|
||||
(DuplexConnection _ rqs _, Just replacedId) -> do
|
||||
when primary . withStore' c $ \db -> setRcvQueuePrimary db connId rq
|
||||
case find ((replacedId ==) . dbQId) rqs of
|
||||
Just rq'@RcvQueue {server, rcvId} -> do
|
||||
checkRQSwchStatus rq' RSSendingQUSE
|
||||
void $ withStore' c $ \db -> setRcvSwitchStatus db rq' $ Just RSReceivedMessage
|
||||
case find (\RcvQueue {dbQueueId} -> dbQueueId == replacedId) rqs of
|
||||
Just RcvQueue {server, rcvId} -> do
|
||||
enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
|
||||
_ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
|
||||
_ -> pure ()
|
||||
let encryptedMsgHash = C.sha256Hash encAgentMsg
|
||||
tryError (agentClientMsg encryptedMsgHash) >>= \case
|
||||
tryError agentClientMsg >>= \case
|
||||
Right (Just (msgId, msgMeta, aMessage)) -> case aMessage of
|
||||
HELLO -> helloMsg >> ackDel msgId
|
||||
REPLY cReq -> replyMsg cReq >> ackDel msgId
|
||||
@@ -1808,15 +1728,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
logServer "<--" c srv rId "MSG <MSG>"
|
||||
notify $ MSG msgMeta msgFlags body
|
||||
_ -> pure ()
|
||||
_ -> checkDuplicateHash e encryptedMsgHash >> ack
|
||||
Left e -> checkDuplicateHash e encryptedMsgHash >> ack
|
||||
_ -> throwError e
|
||||
Left e -> throwError e
|
||||
where
|
||||
checkDuplicateHash :: AgentErrorType -> ByteString -> m ()
|
||||
checkDuplicateHash e encryptedMsgHash =
|
||||
unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $
|
||||
throwError e
|
||||
agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage))
|
||||
agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do
|
||||
agentClientMsg :: m (Maybe (InternalId, MsgMeta, AMessage))
|
||||
agentClientMsg = withStore c $ \db -> runExceptT $ do
|
||||
agentMsgBody <- agentRatchetDecrypt db connId encAgentMsg
|
||||
liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
|
||||
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
|
||||
@@ -1828,7 +1744,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
recipient = (unId internalId, internalTs)
|
||||
broker = (srvMsgId, systemToUTCTime srvTs)
|
||||
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
|
||||
rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash, encryptedMsgHash}
|
||||
rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash}
|
||||
liftIO $ createRcvMsg db connId rq rcvMsg
|
||||
pure $ Just (internalId, msgMeta, aMessage)
|
||||
_ -> pure Nothing
|
||||
@@ -1974,33 +1890,24 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
-- processed by queue sender
|
||||
qAddMsg :: NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> m ()
|
||||
qAddMsg ((_, Nothing) :| _) _ = qError "adding queue without switching is not supported"
|
||||
qAddMsg ((qUri, Just addr) :| _) (DuplexConnection _ rqs sqs) = do
|
||||
qAddMsg ((qUri, Just addr) :| _) (DuplexConnection _ rqs sqs@(sq :| sqs_)) = do
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
case qUri `compatibleVersion` clientVRange of
|
||||
Just qInfo@(Compatible sqInfo@SMPQueueInfo {queueAddress}) ->
|
||||
case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of
|
||||
(Just _, _) -> qError "QADD: queue address is already used in connection"
|
||||
(_, Just sq@SndQueue {dbQueueId}) -> do
|
||||
let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs
|
||||
case L.nonEmpty keepSqs of
|
||||
Just sqs' -> do
|
||||
-- move inside case?
|
||||
withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs
|
||||
sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo
|
||||
let sq'' = (sq_ :: SndQueue) {primary = True, dbQueueId, dbReplaceQueueId = Just dbQueueId}
|
||||
dbId <- withStore c $ \db -> addConnSndQueue db connId sq''
|
||||
let sq2 = (sq'' :: SndQueue) {dbQueueId = dbId}
|
||||
case (sndPublicKey, e2ePubKey) of
|
||||
(Just sndPubKey, Just dhPublicKey) -> do
|
||||
logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
|
||||
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
|
||||
sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
|
||||
let sqs'' = updatedQs sq1 sqs' <> [sq2]
|
||||
conn' = DuplexConnection cData rqs sqs''
|
||||
notify . SWITCH QDSnd SPStarted $ connectionStats conn'
|
||||
_ -> qError "absent sender keys"
|
||||
_ -> qError "QADD: won't delete all snd queues in connection"
|
||||
(_, Just _replaced@SndQueue {dbQueueId}) -> do
|
||||
sq_@SndQueue {sndPublicKey, e2ePubKey} <- newSndQueue userId connId qInfo
|
||||
let sq' = (sq_ :: SndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
void . withStore c $ \db -> addConnSndQueue db connId sq'
|
||||
case (sndPublicKey, e2ePubKey) of
|
||||
(Just sndPubKey, Just dhPublicKey) -> do
|
||||
logServer "<--" c srv rId $ "MSG <QADD> " <> logSecret (senderId queueAddress)
|
||||
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
|
||||
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
|
||||
let conn' = DuplexConnection cData rqs (sq <| sq' :| sqs_)
|
||||
notify . SWITCH QDSnd SPStarted $ connectionStats conn'
|
||||
_ -> qError "absent sender keys"
|
||||
_ -> qError "QADD: replaced queue address is not found in connection"
|
||||
_ -> throwError $ AGENT A_VERSION
|
||||
|
||||
@@ -2012,7 +1919,6 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
case findRQ (smpServer, senderId) rqs of
|
||||
Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'}
|
||||
| status' == New || status' == Confirmed -> do
|
||||
checkRQSwchStatus rq RSSendingQADD
|
||||
logServer "<--" c srv rId $ "MSG <QKEY> " <> logSecret senderId
|
||||
let dhSecret = C.dh' dhPublicKey dhPrivKey
|
||||
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
|
||||
@@ -2027,23 +1933,16 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
-- mark queue as Secured and to start sending messages to it
|
||||
qUseMsg :: NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> m ()
|
||||
-- NOTE: does not yet support the change of the primary status during the rotation
|
||||
qUseMsg ((addr, _primary) :| _) (DuplexConnection _ rqs sqs) =
|
||||
qUseMsg ((addr, _primary) :| _) (DuplexConnection _ _ sqs) =
|
||||
case findQ addr sqs of
|
||||
Just sq'@SndQueue {dbReplaceQueueId = Just replaceQId} -> do
|
||||
case find ((replaceQId ==) . dbQId) sqs of
|
||||
Just sq1 -> do
|
||||
checkSQSwchStatus sq1 SSSendingQKEY
|
||||
logServer "<--" c srv rId $ "MSG <QUSE> " <> logSecret (snd addr)
|
||||
withStore' c $ \db -> setSndQueueStatus db sq' Secured
|
||||
let sq'' = (sq' :: SndQueue) {status = Secured}
|
||||
-- sending QTEST to the new queue only, the old one will be removed if sent successfully
|
||||
void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
|
||||
sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
|
||||
let sqs' = updatedQs sq1' sqs
|
||||
conn' = DuplexConnection cData rqs sqs'
|
||||
notify . SWITCH QDSnd SPSecured $ connectionStats conn'
|
||||
_ -> qError "QUSE: switching SndQueue not found in connection"
|
||||
_ -> qError "QUSE: switched queue address not found in connection"
|
||||
Just sq' -> do
|
||||
logServer "<--" c srv rId $ "MSG <QUSE> " <> logSecret (snd addr)
|
||||
withStore' c $ \db -> setSndQueueStatus db sq' Secured
|
||||
let sq'' = (sq' :: SndQueue) {status = Secured}
|
||||
-- sending QTEST to the new queue only, the old one will be removed if sent successfully
|
||||
void $ enqueueMessages c cData [sq''] SMP.noMsgFlags $ QTEST [addr]
|
||||
notify . SWITCH QDSnd SPConfirmed $ connectionStats conn
|
||||
_ -> qError "QUSE: queue address not found in connection"
|
||||
|
||||
qError :: String -> m ()
|
||||
qError = throwError . AGENT . A_QUEUE
|
||||
@@ -2069,21 +1968,6 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
|
||||
| internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
|
||||
| otherwise = MsgError MsgDuplicate -- this case is not possible
|
||||
|
||||
checkRQSwchStatus :: AgentMonad m => RcvQueue -> RcvSwitchStatus -> m ()
|
||||
checkRQSwchStatus rq@RcvQueue {rcvSwchStatus} expected =
|
||||
unless (rcvSwchStatus == Just expected) $ switchStatusError rq expected rcvSwchStatus
|
||||
|
||||
checkSQSwchStatus :: AgentMonad m => SndQueue -> SndSwitchStatus -> m ()
|
||||
checkSQSwchStatus sq@SndQueue {sndSwchStatus} expected =
|
||||
unless (sndSwchStatus == Just expected) $ switchStatusError sq expected sndSwchStatus
|
||||
|
||||
switchStatusError :: (SMPQueueRec q, AgentMonad m, Show a) => q -> a -> Maybe a -> m ()
|
||||
switchStatusError q expected actual =
|
||||
throwError . INTERNAL $
|
||||
("unexpected switch status, queueId=" <> show (queueId q))
|
||||
<> (", expected=" <> show expected)
|
||||
<> (", actual=" <> show actual)
|
||||
|
||||
connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> m ()
|
||||
connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
@@ -2168,6 +2052,5 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd
|
||||
dbQueueId = 0,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
sndSwchStatus = Nothing,
|
||||
smpClientVersion
|
||||
}
|
||||
|
||||
@@ -115,6 +115,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (lefts, partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (deleteFirstsBy, foldl', partition, (\\))
|
||||
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
@@ -701,6 +702,7 @@ protocolClientError protocolError_ host = \case
|
||||
PCETransportError e -> BROKER host $ TRANSPORT e
|
||||
e@PCECryptoError {} -> INTERNAL $ show e
|
||||
PCEIOError {} -> BROKER host NETWORK
|
||||
PCEInternalError e -> INTERNAL e
|
||||
|
||||
data ProtocolTestStep
|
||||
= TSConnect
|
||||
@@ -841,7 +843,6 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do
|
||||
dbQueueId = 0,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
rcvSwchStatus = Nothing,
|
||||
smpClientVersion = maxVersion vRange,
|
||||
clientNtfCreds = Nothing,
|
||||
deleteErrors = 0
|
||||
|
||||
@@ -82,7 +82,6 @@ data AgentConfig = AgentConfig
|
||||
helloTimeout :: NominalDiffTime,
|
||||
initialCleanupDelay :: Int64,
|
||||
cleanupInterval :: Int64,
|
||||
rcvMsgHashesTTL :: NominalDiffTime,
|
||||
rcvFilesTTL :: NominalDiffTime,
|
||||
sndFilesTTL :: NominalDiffTime,
|
||||
xftpNotifyErrsOnRetry :: Bool,
|
||||
@@ -146,7 +145,6 @@ defaultAgentConfig =
|
||||
helloTimeout = 2 * nominalDay,
|
||||
initialCleanupDelay = 30 * 1000000, -- 30 seconds
|
||||
cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
|
||||
rcvMsgHashesTTL = 30 * nominalDay,
|
||||
rcvFilesTTL = 2 * nominalDay,
|
||||
sndFilesTTL = nominalDay,
|
||||
xftpNotifyErrsOnRetry = True,
|
||||
|
||||
@@ -26,7 +26,6 @@ import Data.Bifunctor (first)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (diffUTCTime)
|
||||
import Simplex.Messaging.Agent.Client
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
|
||||
@@ -40,7 +39,7 @@ import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Protocol (NtfServer, ProtocolServer, SMPServer, sameSrvAddr)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
|
||||
import Simplex.Messaging.Util (diffInMicros, threadDelay', tshow, unlessM)
|
||||
import System.Random (randomR)
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO, threadDelay)
|
||||
@@ -292,7 +291,7 @@ rescheduleAction doWork ts actionTs
|
||||
| otherwise = do
|
||||
void . atomically $ tryTakeTMVar doWork
|
||||
void . forkIO $ do
|
||||
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
|
||||
liftIO $ threadDelay' $ diffInMicros actionTs ts
|
||||
void . atomically $ tryPutTMVar doWork ()
|
||||
pure True
|
||||
|
||||
|
||||
@@ -55,12 +55,8 @@ module Simplex.Messaging.Agent.Protocol
|
||||
AEntityI (..),
|
||||
MsgHash,
|
||||
MsgMeta (..),
|
||||
RcvQueueInfo (..),
|
||||
SndQueueInfo (..),
|
||||
ConnectionStats (..),
|
||||
SwitchPhase (..),
|
||||
RcvSwitchStatus (..),
|
||||
SndSwitchStatus (..),
|
||||
QueueDirection (..),
|
||||
SMPConfirmation (..),
|
||||
AgentMsgEnvelope (..),
|
||||
@@ -477,20 +473,18 @@ instance ToJSON QueueDirection where
|
||||
instance FromJSON QueueDirection where
|
||||
parseJSON = strParseJSON "QueueDirection"
|
||||
|
||||
data SwitchPhase = SPStarted | SPConfirmed | SPSecured | SPCompleted
|
||||
data SwitchPhase = SPStarted | SPConfirmed | SPCompleted
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding SwitchPhase where
|
||||
strEncode = \case
|
||||
SPStarted -> "started"
|
||||
SPConfirmed -> "confirmed"
|
||||
SPSecured -> "secured"
|
||||
SPCompleted -> "completed"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"started" -> pure SPStarted
|
||||
"confirmed" -> pure SPConfirmed
|
||||
"secured" -> pure SPSecured
|
||||
"completed" -> pure SPCompleted
|
||||
_ -> fail "bad SwitchPhase"
|
||||
|
||||
@@ -501,113 +495,19 @@ instance ToJSON SwitchPhase where
|
||||
instance FromJSON SwitchPhase where
|
||||
parseJSON = strParseJSON "SwitchPhase"
|
||||
|
||||
data RcvSwitchStatus
|
||||
= RSSwitchStarted
|
||||
| RSSendingQADD
|
||||
| RSSendingQUSE
|
||||
| RSReceivedMessage
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding RcvSwitchStatus where
|
||||
strEncode = \case
|
||||
RSSwitchStarted -> "switch_started"
|
||||
RSSendingQADD -> "sending_qadd"
|
||||
RSSendingQUSE -> "sending_quse"
|
||||
RSReceivedMessage -> "received_message"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"switch_started" -> pure RSSwitchStarted
|
||||
"sending_qadd" -> pure RSSendingQADD
|
||||
"sending_quse" -> pure RSSendingQUSE
|
||||
"received_message" -> pure RSReceivedMessage
|
||||
_ -> fail "bad RcvSwitchStatus"
|
||||
|
||||
instance ToField RcvSwitchStatus where toField = toField . strEncode
|
||||
|
||||
instance FromField RcvSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
|
||||
|
||||
instance ToJSON RcvSwitchStatus where
|
||||
toEncoding = strToJEncoding
|
||||
toJSON = strToJSON
|
||||
|
||||
instance FromJSON RcvSwitchStatus where
|
||||
parseJSON = strParseJSON "RcvSwitchStatus"
|
||||
|
||||
data SndSwitchStatus
|
||||
= SSSendingQKEY
|
||||
| SSSendingQTEST
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding SndSwitchStatus where
|
||||
strEncode = \case
|
||||
SSSendingQKEY -> "sending_qkey"
|
||||
SSSendingQTEST -> "sending_qtest"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"sending_qkey" -> pure SSSendingQKEY
|
||||
"sending_qtest" -> pure SSSendingQTEST
|
||||
_ -> fail "bad SndSwitchStatus"
|
||||
|
||||
instance ToField SndSwitchStatus where toField = toField . strEncode
|
||||
|
||||
instance FromField SndSwitchStatus where fromField = blobFieldDecoder $ parseAll strP
|
||||
|
||||
instance ToJSON SndSwitchStatus where
|
||||
toEncoding = strToJEncoding
|
||||
toJSON = strToJSON
|
||||
|
||||
instance FromJSON SndSwitchStatus where
|
||||
parseJSON = strParseJSON "SndSwitchStatus"
|
||||
|
||||
data RcvQueueInfo = RcvQueueInfo
|
||||
{ rcvServer :: SMPServer,
|
||||
rcvSwitchStatus :: Maybe RcvSwitchStatus,
|
||||
canAbortSwitch :: Bool
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
instance StrEncoding RcvQueueInfo where
|
||||
strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
|
||||
"srv=" <> strEncode rcvServer
|
||||
<> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
|
||||
<> (";can_abort_switch=" <> strEncode canAbortSwitch)
|
||||
strP = do
|
||||
rcvServer <- "srv=" *> strP
|
||||
rcvSwitchStatus <- optional $ ";switch=" *> strP
|
||||
canAbortSwitch <- ";can_abort_switch=" *> strP
|
||||
pure RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch}
|
||||
|
||||
data SndQueueInfo = SndQueueInfo
|
||||
{ sndServer :: SMPServer,
|
||||
sndSwitchStatus :: Maybe SndSwitchStatus
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON SndQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
instance StrEncoding SndQueueInfo where
|
||||
strEncode SndQueueInfo {sndServer, sndSwitchStatus} =
|
||||
"srv=" <> strEncode sndServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) sndSwitchStatus
|
||||
strP = do
|
||||
sndServer <- "srv=" *> strP
|
||||
sndSwitchStatus <- optional $ ";switch=" *> strP
|
||||
pure SndQueueInfo {sndServer, sndSwitchStatus}
|
||||
|
||||
data ConnectionStats = ConnectionStats
|
||||
{ rcvQueuesInfo :: [RcvQueueInfo],
|
||||
sndQueuesInfo :: [SndQueueInfo]
|
||||
{ rcvServers :: [SMPServer],
|
||||
sndServers :: [SMPServer]
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance StrEncoding ConnectionStats where
|
||||
strEncode ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
|
||||
"rcv=" <> strEncodeList rcvQueuesInfo <> " snd=" <> strEncodeList sndQueuesInfo
|
||||
strEncode ConnectionStats {rcvServers, sndServers} =
|
||||
"rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
|
||||
strP = do
|
||||
rcvQueuesInfo <- "rcv=" *> strListP
|
||||
sndQueuesInfo <- " snd=" *> strListP
|
||||
pure ConnectionStats {rcvQueuesInfo, sndQueuesInfo}
|
||||
rcvServers <- "rcv=" *> strListP
|
||||
sndServers <- " snd=" *> strListP
|
||||
pure ConnectionStats {rcvServers, sndServers}
|
||||
|
||||
instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
|
||||
@@ -21,7 +21,6 @@ import Data.Kind (Type)
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Type.Equality
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
@@ -67,13 +66,12 @@ data RcvQueue = RcvQueue
|
||||
sndId :: SMP.SenderId,
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
-- | database queue ID (within connection), can be Nothing for old queues
|
||||
dbQueueId :: Int64,
|
||||
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
|
||||
primary :: Bool,
|
||||
-- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
|
||||
dbReplaceQueueId :: Maybe Int64,
|
||||
rcvSwchStatus :: Maybe RcvSwitchStatus,
|
||||
-- | SMP client version
|
||||
smpClientVersion :: Version,
|
||||
-- | credentials used in context of notifications
|
||||
@@ -82,22 +80,6 @@ data RcvQueue = RcvQueue
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
|
||||
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
|
||||
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
|
||||
|
||||
canAbortRcvSwitch :: RcvQueue -> Bool
|
||||
canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
|
||||
where
|
||||
canAbort = \case
|
||||
RSSwitchStarted -> True
|
||||
RSSendingQADD -> True
|
||||
-- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
|
||||
RSSendingQUSE -> False
|
||||
-- if switch is in RSReceivedMessage status, aborting switch (deleting new queue)
|
||||
-- will break the connection because the sender would have original queue deleted
|
||||
RSReceivedMessage -> False
|
||||
|
||||
data ClientNtfCreds = ClientNtfCreds
|
||||
{ -- | key pair to be used by the notification server to sign transmissions
|
||||
ntfPublicKey :: NtfPublicVerifyKey,
|
||||
@@ -125,22 +107,17 @@ data SndQueue = SndQueue
|
||||
e2eDhSecret :: C.DhSecretX25519,
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
-- | database queue ID (within connection), can be Nothing for old queues
|
||||
dbQueueId :: Int64,
|
||||
-- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
|
||||
primary :: Bool,
|
||||
-- | ID of the queue this one is replacing
|
||||
dbReplaceQueueId :: Maybe Int64,
|
||||
sndSwchStatus :: Maybe SndSwitchStatus,
|
||||
-- | SMP client version
|
||||
smpClientVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
sndQueueInfo :: SndQueue -> SndQueueInfo
|
||||
sndQueueInfo SndQueue {server, sndSwchStatus} =
|
||||
SndQueueInfo {sndServer = server, sndSwitchStatus = sndSwchStatus}
|
||||
|
||||
instance SMPQueue RcvQueue where
|
||||
qServer RcvQueue {server} = server
|
||||
{-# INLINE qServer #-}
|
||||
@@ -178,20 +155,10 @@ findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
|
||||
findRQ sAddr = find $ sameQAddress sAddr . sndAddress
|
||||
{-# INLINE findRQ #-}
|
||||
|
||||
switchingRQ :: NonEmpty RcvQueue -> Maybe RcvQueue
|
||||
switchingRQ = find $ isJust . rcvSwchStatus
|
||||
{-# INLINE switchingRQ #-}
|
||||
|
||||
updatedQs :: SMPQueueRec q => q -> NonEmpty q -> NonEmpty q
|
||||
updatedQs q = L.map $ \q' -> if dbQId q == dbQId q' then q else q'
|
||||
{-# INLINE updatedQs #-}
|
||||
|
||||
class SMPQueue q => SMPQueueRec q where
|
||||
qUserId :: q -> UserId
|
||||
qConnId :: q -> ConnId
|
||||
queueId :: q -> QueueId
|
||||
dbQId :: q -> Int64
|
||||
dbReplaceQId :: q -> Maybe Int64
|
||||
|
||||
instance SMPQueueRec RcvQueue where
|
||||
qUserId = userId
|
||||
@@ -200,10 +167,6 @@ instance SMPQueueRec RcvQueue where
|
||||
{-# INLINE qConnId #-}
|
||||
queueId = rcvId
|
||||
{-# INLINE queueId #-}
|
||||
dbQId = dbQueueId
|
||||
{-# INLINE dbQId #-}
|
||||
dbReplaceQId = dbReplaceQueueId
|
||||
{-# INLINE dbReplaceQId #-}
|
||||
|
||||
instance SMPQueueRec SndQueue where
|
||||
qUserId = userId
|
||||
@@ -212,10 +175,6 @@ instance SMPQueueRec SndQueue where
|
||||
{-# INLINE qConnId #-}
|
||||
queueId = sndId
|
||||
{-# INLINE queueId #-}
|
||||
dbQId = dbQueueId
|
||||
{-# INLINE dbQId #-}
|
||||
dbReplaceQId = dbReplaceQueueId
|
||||
{-# INLINE dbReplaceQId #-}
|
||||
|
||||
-- * Connection types
|
||||
|
||||
@@ -349,7 +308,6 @@ data InternalCommand
|
||||
| ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
|
||||
| ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
|
||||
| ICDeleteConn
|
||||
| ICDeleteRcvQueue SMP.RecipientId
|
||||
| ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
|
||||
| ICQDelete SMP.RecipientId
|
||||
|
||||
@@ -359,7 +317,6 @@ data InternalCommandTag
|
||||
| ICAllowSecure_
|
||||
| ICDuplexSecure_
|
||||
| ICDeleteConn_
|
||||
| ICDeleteRcvQueue_
|
||||
| ICQSecure_
|
||||
| ICQDelete_
|
||||
deriving (Show)
|
||||
@@ -371,7 +328,6 @@ instance StrEncoding InternalCommand where
|
||||
ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
|
||||
ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
|
||||
ICDeleteConn -> strEncode ICDeleteConn_
|
||||
ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId)
|
||||
ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
|
||||
ICQDelete rId -> strEncode (ICQDelete_, rId)
|
||||
strP =
|
||||
@@ -381,7 +337,6 @@ instance StrEncoding InternalCommand where
|
||||
ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
|
||||
ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
|
||||
ICDeleteConn_ -> pure ICDeleteConn
|
||||
ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP
|
||||
ICQSecure_ -> ICQSecure <$> _strP <*> _strP
|
||||
ICQDelete_ -> ICQDelete <$> _strP
|
||||
|
||||
@@ -392,7 +347,6 @@ instance StrEncoding InternalCommandTag where
|
||||
ICAllowSecure_ -> "ALLOW_SECURE"
|
||||
ICDuplexSecure_ -> "DUPLEX_SECURE"
|
||||
ICDeleteConn_ -> "DELETE_CONN"
|
||||
ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE"
|
||||
ICQSecure_ -> "QSECURE"
|
||||
ICQDelete_ -> "QDELETE"
|
||||
strP =
|
||||
@@ -402,7 +356,6 @@ instance StrEncoding InternalCommandTag where
|
||||
"ALLOW_SECURE" -> pure ICAllowSecure_
|
||||
"DUPLEX_SECURE" -> pure ICDuplexSecure_
|
||||
"DELETE_CONN" -> pure ICDeleteConn_
|
||||
"DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_
|
||||
"QSECURE" -> pure ICQSecure_
|
||||
"QDELETE" -> pure ICQDelete_
|
||||
_ -> fail "bad InternalCommandTag"
|
||||
@@ -419,7 +372,6 @@ internalCmdTag = \case
|
||||
ICAllowSecure {} -> ICAllowSecure_
|
||||
ICDuplexSecure {} -> ICDuplexSecure_
|
||||
ICDeleteConn -> ICDeleteConn_
|
||||
ICDeleteRcvQueue {} -> ICDeleteRcvQueue_
|
||||
ICQSecure {} -> ICQSecure_
|
||||
ICQDelete _ -> ICQDelete_
|
||||
|
||||
@@ -476,8 +428,7 @@ data RcvMsgData = RcvMsgData
|
||||
msgBody :: MsgBody,
|
||||
internalRcvId :: InternalRcvId,
|
||||
internalHash :: MsgHash,
|
||||
externalPrevSndHash :: MsgHash,
|
||||
encryptedMsgHash :: MsgHash
|
||||
externalPrevSndHash :: MsgHash
|
||||
}
|
||||
|
||||
data RcvMsg = RcvMsg
|
||||
|
||||
@@ -54,19 +54,14 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
setConnDeleted,
|
||||
getDeletedConnIds,
|
||||
getRcvConn,
|
||||
getRcvQueueById,
|
||||
getSndQueueById,
|
||||
deleteConn,
|
||||
upgradeRcvConnToDuplex,
|
||||
upgradeSndConnToDuplex,
|
||||
addConnRcvQueue,
|
||||
addConnSndQueue,
|
||||
setRcvQueueStatus,
|
||||
setRcvSwitchStatus,
|
||||
setRcvQueueDeleted,
|
||||
setRcvQueueConfirmedE2E,
|
||||
setSndQueueStatus,
|
||||
setSndSwitchStatus,
|
||||
setRcvQueuePrimary,
|
||||
setSndQueuePrimary,
|
||||
deleteConnRcvQueue,
|
||||
@@ -74,7 +69,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
deleteConnSndQueue,
|
||||
getPrimaryRcvQueue,
|
||||
getRcvQueue,
|
||||
getDeletedRcvQueue,
|
||||
setRcvQueueNtfCreds,
|
||||
-- Confirmations
|
||||
createConfirmation,
|
||||
@@ -100,10 +94,8 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
deletePendingMsgs,
|
||||
setMsgUserAck,
|
||||
getLastMsg,
|
||||
checkRcvMsgHashExists,
|
||||
deleteMsg,
|
||||
deleteSndMsgDelivery,
|
||||
deleteRcvMsgHashesExpired,
|
||||
-- Double ratchet persistence
|
||||
createRatchetX3dhKeys,
|
||||
getRatchetX3dhKeys,
|
||||
@@ -190,7 +182,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
-- * utilities
|
||||
withConnection,
|
||||
withTransaction,
|
||||
withTransactionCtx,
|
||||
firstRow,
|
||||
firstRow',
|
||||
maybeFirstRow,
|
||||
@@ -221,7 +212,7 @@ import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
|
||||
import Data.Word (Word32)
|
||||
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
@@ -250,7 +241,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
|
||||
import Simplex.Messaging.Protocol
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, ($>>=), (<$$>))
|
||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
|
||||
import Simplex.Messaging.Version
|
||||
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
|
||||
import System.Exit (exitFailure)
|
||||
@@ -437,29 +428,16 @@ withConnection SQLiteStore {dbConnection} =
|
||||
(atomically . putTMVar dbConnection)
|
||||
|
||||
withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
|
||||
withTransaction = withTransactionCtx Nothing
|
||||
|
||||
withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
|
||||
withTransactionCtx ctx_ st action = withConnection st $ loop 500 3_000_000
|
||||
withTransaction st action = withConnection st $ loop 500 3_000_000
|
||||
where
|
||||
loop :: Int -> Int -> DB.Connection -> IO a
|
||||
loop t tLim db =
|
||||
transactionWithCtx `E.catch` \(e :: SQLError) ->
|
||||
DB.withImmediateTransaction db (action db) `E.catch` \(e :: SQLError) ->
|
||||
if tLim > t && DB.sqlError e == DB.ErrorBusy
|
||||
then do
|
||||
threadDelay t
|
||||
loop (t * 9 `div` 8) (tLim - t) db
|
||||
else E.throwIO e
|
||||
where
|
||||
transactionWithCtx = case ctx_ of
|
||||
Nothing -> DB.withImmediateTransaction db (action db)
|
||||
Just ctx -> do
|
||||
t1 <- getCurrentTime
|
||||
r <- DB.withImmediateTransaction db (action db)
|
||||
t2 <- getCurrentTime
|
||||
putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
|
||||
putStrLn $ "withTransactionCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
|
||||
pure r
|
||||
|
||||
createUserRecord :: DB.Connection -> IO UserId
|
||||
createUserRecord db = do
|
||||
@@ -567,7 +545,7 @@ getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreE
|
||||
getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
|
||||
rq@RcvQueue {connId} <-
|
||||
ExceptT . firstRow toRcvQueue SEConnNotFound $
|
||||
DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId)
|
||||
DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?") (host, port, rcvId)
|
||||
(rq,) <$> ExceptT (getConn db connId)
|
||||
|
||||
deleteConn :: DB.Connection -> ConnId -> IO ()
|
||||
@@ -626,29 +604,6 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
|
||||
|]
|
||||
[":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
|
||||
|
||||
setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue
|
||||
setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_queues
|
||||
SET switch_status = ?
|
||||
WHERE host = ? AND port = ? AND rcv_id = ?
|
||||
|]
|
||||
(rcvSwchStatus, host, port, rcvId)
|
||||
pure rq {rcvSwchStatus}
|
||||
|
||||
setRcvQueueDeleted :: DB.Connection -> RcvQueue -> IO ()
|
||||
setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_queues
|
||||
SET deleted = 1
|
||||
WHERE host = ? AND port = ? AND rcv_id = ?
|
||||
|]
|
||||
(host, port, rcvId)
|
||||
|
||||
setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
|
||||
setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
|
||||
DB.executeNamed
|
||||
@@ -680,18 +635,6 @@ setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} stat
|
||||
|]
|
||||
[":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
|
||||
|
||||
setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue
|
||||
setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE snd_queues
|
||||
SET switch_status = ?
|
||||
WHERE host = ? AND port = ? AND snd_id = ?
|
||||
|]
|
||||
(sndSwchStatus, host, port, sndId)
|
||||
pure sq {sndSwchStatus}
|
||||
|
||||
setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO ()
|
||||
setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do
|
||||
DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId)
|
||||
@@ -728,12 +671,7 @@ getPrimaryRcvQueue db connId =
|
||||
getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueue db connId (SMPServer host port _) rcvId =
|
||||
firstRow toRcvQueue SEConnNotFound $
|
||||
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId)
|
||||
|
||||
getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
|
||||
getDeletedRcvQueue db connId (SMPServer host port _) rcvId =
|
||||
firstRow toRcvQueue SEConnNotFound $
|
||||
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId)
|
||||
DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ?") (connId, host, port, rcvId)
|
||||
|
||||
setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO ()
|
||||
setRcvQueueNtfCreds db connId clientNtfCreds =
|
||||
@@ -964,7 +902,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do
|
||||
(dbRcvId, srvMsgId) <-
|
||||
ExceptT . firstRow id SEMsgNotFound $
|
||||
DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
|
||||
rq <- ExceptT $ getRcvQueueById db connId dbRcvId
|
||||
rq <- ExceptT $ getRcvQueueById_ db connId dbRcvId
|
||||
pure (rq, srvMsgId)
|
||||
|
||||
getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
|
||||
@@ -987,17 +925,6 @@ getLastMsg db connId msgId =
|
||||
let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
|
||||
in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgBody, userAck}
|
||||
|
||||
checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool
|
||||
checkRcvMsgHashExists db connId hash = do
|
||||
fromMaybe False
|
||||
<$> maybeFirstRow
|
||||
fromOnly
|
||||
( DB.query
|
||||
db
|
||||
"SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1"
|
||||
(connId, hash)
|
||||
)
|
||||
|
||||
deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
|
||||
deleteMsg db connId msgId =
|
||||
DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
|
||||
@@ -1011,11 +938,6 @@ deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId = do
|
||||
(Only (cnt :: Int) : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
|
||||
when (cnt == 0) $ deleteMsg db connId msgId
|
||||
|
||||
deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
|
||||
deleteRcvMsgHashesExpired db ttl = do
|
||||
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
|
||||
DB.execute db "DELETE FROM encrypted_rcv_message_hashes WHERE created_at < ?" (Only cutoffTs)
|
||||
|
||||
createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
|
||||
createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
|
||||
DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
|
||||
@@ -1421,7 +1343,7 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId}
|
||||
[sql|
|
||||
SELECT conn_id, rcv_ntf_dh_secret
|
||||
FROM rcv_queues
|
||||
WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
|
||||
WHERE host = ? AND port = ? AND ntf_id = ?
|
||||
|]
|
||||
(host, port, notifierId)
|
||||
where
|
||||
@@ -1657,7 +1579,7 @@ getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connect
|
||||
getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
|
||||
getRcvQueuesByConnId_ db connId =
|
||||
L.nonEmpty . sortBy primaryFirst . map toRcvQueue
|
||||
<$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId)
|
||||
<$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
|
||||
where
|
||||
primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
|
||||
-- the current primary queue is ordered first, the next primary - second
|
||||
@@ -1668,7 +1590,7 @@ rcvQueueQuery =
|
||||
[sql|
|
||||
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
|
||||
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors,
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
@@ -1677,62 +1599,44 @@ rcvQueueQuery =
|
||||
|
||||
toRcvQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
|
||||
:. (Int64, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
|
||||
:. (Int64, Bool, Maybe Int64, Maybe Version, Int)
|
||||
:. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
|
||||
RcvQueue
|
||||
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
|
||||
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
|
||||
let server = SMPServer host port keyHash
|
||||
smpClientVersion = fromMaybe 1 smpClientVersion_
|
||||
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
_ -> Nothing
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
|
||||
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById db connId dbRcvId =
|
||||
getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById_ db connId dbRcvId =
|
||||
firstRow toRcvQueue SEConnNotFound $
|
||||
DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ? AND q.deleted = 0") (connId, dbRcvId)
|
||||
DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ?") (connId, dbRcvId)
|
||||
|
||||
-- | returns all connection queues, the first queue is the primary one
|
||||
getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue))
|
||||
getSndQueuesByConnId_ dbConn connId =
|
||||
L.nonEmpty . sortBy primaryFirst . map toSndQueue
|
||||
<$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
|
||||
L.nonEmpty . sortBy primaryFirst . map sndQueue
|
||||
<$> DB.query
|
||||
dbConn
|
||||
[sql|
|
||||
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
|
||||
FROM snd_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
WHERE q.conn_id = ?;
|
||||
|]
|
||||
(Only connId)
|
||||
where
|
||||
sndQueue ((userId, keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
|
||||
let server = SMPServer host port keyHash
|
||||
in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion}
|
||||
primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
|
||||
-- the current primary queue is ordered first, the next primary - second
|
||||
compare (Down p) (Down p') <> compare i i'
|
||||
|
||||
sndQueueQuery :: Query
|
||||
sndQueueQuery =
|
||||
[sql|
|
||||
SELECT
|
||||
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id,
|
||||
q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
|
||||
q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
|
||||
FROM snd_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
|]
|
||||
|
||||
toSndQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
|
||||
:. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
|
||||
:. (Int64, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
|
||||
SndQueue
|
||||
toSndQueue
|
||||
( (userId, keyHash, connId, host, port, sndId)
|
||||
:. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
|
||||
:. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
|
||||
) =
|
||||
let server = SMPServer host port keyHash
|
||||
in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
|
||||
|
||||
getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
|
||||
getSndQueueById db connId dbSndId =
|
||||
firstRow toSndQueue SEConnNotFound $
|
||||
DB.query db (sndQueueQuery <> " WHERE q.conn_id = ? AND q.snd_queue_id = ?") (connId, dbSndId)
|
||||
|
||||
-- * updateRcvIds helpers
|
||||
|
||||
retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
|
||||
@@ -1786,10 +1690,10 @@ insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody,
|
||||
]
|
||||
|
||||
insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
|
||||
insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do
|
||||
insertRcvMsgDetails_ dbConn connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
|
||||
let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta
|
||||
DB.executeNamed
|
||||
db
|
||||
dbConn
|
||||
[sql|
|
||||
INSERT INTO rcv_messages
|
||||
( conn_id, rcv_queue_id, internal_rcv_id, internal_id, external_snd_id,
|
||||
@@ -1811,7 +1715,6 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna
|
||||
":external_prev_snd_hash" := externalPrevSndHash,
|
||||
":integrity" := integrity
|
||||
]
|
||||
DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash)
|
||||
|
||||
updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
|
||||
updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} =
|
||||
|
||||
@@ -58,9 +58,6 @@ 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.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
@@ -85,10 +82,7 @@ schemaMigrations =
|
||||
("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)
|
||||
("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -107,8 +101,7 @@ getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrati
|
||||
|
||||
run :: Connection -> MigrationsToRun -> IO ()
|
||||
run db = \case
|
||||
MTRUp [] -> pure ()
|
||||
MTRUp ms -> mapM_ runUp ms >> execSQL "VACUUM;"
|
||||
MTRUp ms -> mapM_ runUp ms
|
||||
MTRDown ms -> mapM_ runDown $ reverse ms
|
||||
MTRNone -> pure ()
|
||||
where
|
||||
|
||||
-22
@@ -1,22 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230510_files_pending_replicas_indexes :: Query
|
||||
m20230510_files_pending_replicas_indexes =
|
||||
[sql|
|
||||
CREATE INDEX idx_rcv_file_chunk_replicas_pending ON rcv_file_chunk_replicas(received, replica_number);
|
||||
CREATE INDEX idx_snd_file_chunk_replicas_pending ON snd_file_chunk_replicas(replica_status, replica_number);
|
||||
CREATE INDEX idx_deleted_snd_chunk_replicas_pending ON deleted_snd_chunk_replicas(created_at);
|
||||
|]
|
||||
|
||||
down_m20230510_files_pending_replicas_indexes :: Query
|
||||
down_m20230510_files_pending_replicas_indexes =
|
||||
[sql|
|
||||
DROP INDEX idx_deleted_snd_chunk_replicas_pending;
|
||||
DROP INDEX idx_snd_file_chunk_replicas_pending;
|
||||
DROP INDEX idx_rcv_file_chunk_replicas_pending;
|
||||
|]
|
||||
-28
@@ -1,28 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230516_encrypted_rcv_message_hashes :: Query
|
||||
m20230516_encrypted_rcv_message_hashes =
|
||||
[sql|
|
||||
CREATE TABLE encrypted_rcv_message_hashes(
|
||||
encrypted_rcv_message_hash_id INTEGER PRIMARY KEY,
|
||||
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
hash BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hashes(conn_id, hash);
|
||||
|]
|
||||
|
||||
down_m20230516_encrypted_rcv_message_hashes :: Query
|
||||
down_m20230516_encrypted_rcv_message_hashes =
|
||||
[sql|
|
||||
DROP INDEX idx_encrypted_rcv_message_hashes_hash;
|
||||
|
||||
DROP TABLE encrypted_rcv_message_hashes;
|
||||
|]
|
||||
@@ -1,22 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230531_switch_status :: Query
|
||||
m20230531_switch_status =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues ADD COLUMN switch_status TEXT;
|
||||
ALTER TABLE rcv_queues ADD COLUMN deleted INTEGER NOT NULL DEFAULT 0;
|
||||
ALTER TABLE snd_queues ADD COLUMN switch_status TEXT;
|
||||
|]
|
||||
|
||||
down_m20230531_switch_status :: Query
|
||||
down_m20230531_switch_status =
|
||||
[sql|
|
||||
ALTER TABLE snd_queues DROP COLUMN switch_status;
|
||||
ALTER TABLE rcv_queues DROP COLUMN deleted;
|
||||
ALTER TABLE rcv_queues DROP COLUMN switch_status;
|
||||
|]
|
||||
@@ -50,8 +50,6 @@ CREATE TABLE rcv_queues(
|
||||
replace_rcv_queue_id INTEGER NULL,
|
||||
delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL),
|
||||
server_key_hash BLOB,
|
||||
switch_status TEXT,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY(host, port, rcv_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE,
|
||||
@@ -73,7 +71,6 @@ CREATE TABLE snd_queues(
|
||||
snd_primary INTEGER CHECK(snd_primary NOT NULL),
|
||||
replace_snd_queue_id INTEGER NULL,
|
||||
server_key_hash BLOB,
|
||||
switch_status TEXT,
|
||||
PRIMARY KEY(host, port, snd_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
@@ -191,6 +188,7 @@ tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
|
||||
FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
) WITHOUT ROWID;
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE TABLE ntf_subscriptions(
|
||||
conn_id BLOB NOT NULL,
|
||||
smp_host TEXT NULL,
|
||||
@@ -226,6 +224,8 @@ CREATE TABLE commands(
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
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);
|
||||
CREATE TABLE snd_message_deliveries(
|
||||
snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
@@ -234,135 +234,15 @@ CREATE TABLE snd_message_deliveries(
|
||||
FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
|
||||
);
|
||||
CREATE TABLE sqlite_sequence(name,seq);
|
||||
CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
|
||||
conn_id,
|
||||
snd_queue_id
|
||||
);
|
||||
CREATE TABLE users(
|
||||
user_id INTEGER PRIMARY KEY AUTOINCREMENT
|
||||
,
|
||||
deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
|
||||
);
|
||||
CREATE TABLE xftp_servers(
|
||||
xftp_server_id INTEGER PRIMARY KEY,
|
||||
xftp_host TEXT NOT NULL,
|
||||
xftp_port TEXT NOT NULL,
|
||||
xftp_key_hash BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
UNIQUE(xftp_host, xftp_port, xftp_key_hash)
|
||||
);
|
||||
CREATE TABLE rcv_files(
|
||||
rcv_file_id INTEGER PRIMARY KEY,
|
||||
rcv_file_entity_id BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
key BLOB NOT NULL,
|
||||
nonce BLOB NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
prefix_path TEXT NOT NULL,
|
||||
tmp_path TEXT,
|
||||
save_path TEXT NOT NULL,
|
||||
status TEXT NOT NULL,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
error TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
UNIQUE(rcv_file_entity_id)
|
||||
);
|
||||
CREATE TABLE rcv_file_chunks(
|
||||
rcv_file_chunk_id INTEGER PRIMARY KEY,
|
||||
rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
|
||||
chunk_no INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
tmp_path TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE rcv_file_chunk_replicas(
|
||||
rcv_file_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE,
|
||||
replica_number INTEGER NOT NULL,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
received INTEGER NOT NULL DEFAULT 0,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE snd_files(
|
||||
snd_file_id INTEGER PRIMARY KEY,
|
||||
snd_file_entity_id BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
num_recipients INTEGER NOT NULL,
|
||||
digest BLOB,
|
||||
key BLOB NOT NUll,
|
||||
nonce BLOB NOT NUll,
|
||||
path TEXT NOT NULL,
|
||||
prefix_path TEXT,
|
||||
status TEXT NOT NULL,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
error TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE snd_file_chunks(
|
||||
snd_file_chunk_id INTEGER PRIMARY KEY,
|
||||
snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE,
|
||||
chunk_no INTEGER NOT NULL,
|
||||
chunk_offset INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE snd_file_chunk_replicas(
|
||||
snd_file_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE,
|
||||
replica_number INTEGER NOT NULL,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
replica_status TEXT NOT NULL,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE snd_file_chunk_replica_recipients(
|
||||
snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY,
|
||||
snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE,
|
||||
rcv_replica_id BLOB NOT NULL,
|
||||
rcv_replica_key BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE deleted_snd_chunk_replicas(
|
||||
deleted_snd_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
chunk_digest BLOB NOT NULL,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE encrypted_rcv_message_hashes(
|
||||
encrypted_rcv_message_hash_id INTEGER PRIMARY KEY,
|
||||
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
hash BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
|
||||
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
|
||||
CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
|
||||
conn_id,
|
||||
snd_queue_id
|
||||
);
|
||||
CREATE INDEX idx_connections_user ON connections(user_id);
|
||||
CREATE INDEX idx_commands_conn_id ON commands(conn_id);
|
||||
CREATE INDEX idx_commands_host_port ON commands(host, port);
|
||||
@@ -406,43 +286,138 @@ CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(
|
||||
internal_id
|
||||
);
|
||||
CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port);
|
||||
CREATE TABLE xftp_servers(
|
||||
xftp_server_id INTEGER PRIMARY KEY,
|
||||
xftp_host TEXT NOT NULL,
|
||||
xftp_port TEXT NOT NULL,
|
||||
xftp_key_hash BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
UNIQUE(xftp_host, xftp_port, xftp_key_hash)
|
||||
);
|
||||
CREATE TABLE rcv_files(
|
||||
rcv_file_id INTEGER PRIMARY KEY,
|
||||
rcv_file_entity_id BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
key BLOB NOT NULL,
|
||||
nonce BLOB NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
prefix_path TEXT NOT NULL,
|
||||
tmp_path TEXT,
|
||||
save_path TEXT NOT NULL,
|
||||
status TEXT NOT NULL,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
error TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
UNIQUE(rcv_file_entity_id)
|
||||
);
|
||||
CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id);
|
||||
CREATE TABLE rcv_file_chunks(
|
||||
rcv_file_chunk_id INTEGER PRIMARY KEY,
|
||||
rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
|
||||
chunk_no INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
tmp_path TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id);
|
||||
CREATE TABLE rcv_file_chunk_replicas(
|
||||
rcv_file_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE,
|
||||
replica_number INTEGER NOT NULL,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
received INTEGER NOT NULL DEFAULT 0,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas(
|
||||
rcv_file_chunk_id
|
||||
);
|
||||
CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas(
|
||||
xftp_server_id
|
||||
);
|
||||
CREATE TABLE snd_files(
|
||||
snd_file_id INTEGER PRIMARY KEY,
|
||||
snd_file_entity_id BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
num_recipients INTEGER NOT NULL,
|
||||
digest BLOB,
|
||||
key BLOB NOT NUll,
|
||||
nonce BLOB NOT NUll,
|
||||
path TEXT NOT NULL,
|
||||
prefix_path TEXT,
|
||||
status TEXT NOT NULL,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
error TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_snd_files_user_id ON snd_files(user_id);
|
||||
CREATE TABLE snd_file_chunks(
|
||||
snd_file_chunk_id INTEGER PRIMARY KEY,
|
||||
snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE,
|
||||
chunk_no INTEGER NOT NULL,
|
||||
chunk_offset INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
digest BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_snd_file_chunks_snd_file_id ON snd_file_chunks(snd_file_id);
|
||||
CREATE TABLE snd_file_chunk_replicas(
|
||||
snd_file_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE,
|
||||
replica_number INTEGER NOT NULL,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
replica_status TEXT NOT NULL,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_snd_file_chunk_replicas_snd_file_chunk_id ON snd_file_chunk_replicas(
|
||||
snd_file_chunk_id
|
||||
);
|
||||
CREATE INDEX idx_snd_file_chunk_replicas_xftp_server_id ON snd_file_chunk_replicas(
|
||||
xftp_server_id
|
||||
);
|
||||
CREATE TABLE snd_file_chunk_replica_recipients(
|
||||
snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY,
|
||||
snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE,
|
||||
rcv_replica_id BLOB NOT NULL,
|
||||
rcv_replica_key BLOB NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id ON snd_file_chunk_replica_recipients(
|
||||
snd_file_chunk_replica_id
|
||||
);
|
||||
CREATE TABLE deleted_snd_chunk_replicas(
|
||||
deleted_snd_chunk_replica_id INTEGER PRIMARY KEY,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
|
||||
replica_id BLOB NOT NULL,
|
||||
replica_key BLOB NOT NULL,
|
||||
chunk_digest BLOB NOT NULL,
|
||||
delay INTEGER,
|
||||
retries INTEGER NOT NULL DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX idx_deleted_snd_chunk_replicas_user_id ON deleted_snd_chunk_replicas(
|
||||
user_id
|
||||
);
|
||||
CREATE INDEX idx_deleted_snd_chunk_replicas_xftp_server_id ON deleted_snd_chunk_replicas(
|
||||
xftp_server_id
|
||||
);
|
||||
CREATE INDEX idx_rcv_file_chunk_replicas_pending ON rcv_file_chunk_replicas(
|
||||
received,
|
||||
replica_number
|
||||
);
|
||||
CREATE INDEX idx_snd_file_chunk_replicas_pending ON snd_file_chunk_replicas(
|
||||
replica_status,
|
||||
replica_number
|
||||
);
|
||||
CREATE INDEX idx_deleted_snd_chunk_replicas_pending ON deleted_snd_chunk_replicas(
|
||||
created_at
|
||||
);
|
||||
CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hashes(
|
||||
conn_id,
|
||||
hash
|
||||
);
|
||||
|
||||
@@ -41,7 +41,6 @@ module Simplex.Messaging.Client
|
||||
subscribeSMPQueues,
|
||||
getSMPMessage,
|
||||
subscribeSMPQueueNotifications,
|
||||
subscribeSMPQueuesNtfs,
|
||||
secureSMPQueue,
|
||||
enableSMPQueueNotifications,
|
||||
disableSMPQueueNotifications,
|
||||
@@ -418,6 +417,8 @@ data ProtocolClientError err
|
||||
PCECryptoError C.CryptoError
|
||||
| -- | IO Error
|
||||
PCEIOError IOException
|
||||
| -- | Internal error
|
||||
PCEInternalError String
|
||||
deriving (Eq, Show, Exception)
|
||||
|
||||
type SMPClientError = ProtocolClientError ErrorType
|
||||
@@ -488,16 +489,6 @@ getSMPMessage c rpKey rId =
|
||||
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
|
||||
subscribeSMPQueueNotifications = okSMPCommand NSUB
|
||||
|
||||
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
|
||||
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
subscribeSMPQueuesNtfs c qs = sendProtocolCommands c cs >>= mapM response
|
||||
where
|
||||
cs = L.map (\(npKey, nId) -> (Just npKey, nId, Cmd SNotifier NSUB)) qs
|
||||
response r = pure $ case r of
|
||||
Right OK -> Right ()
|
||||
Right r' -> Left . PCEUnexpectedResponse $ bshow r'
|
||||
Left e -> Left e
|
||||
|
||||
-- | 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
|
||||
|
||||
@@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
@@ -17,33 +16,27 @@ import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List (find, partition)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Set (Set)
|
||||
import Data.Text.Encoding
|
||||
import Data.Tuple (swap)
|
||||
import Numeric.Natural
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer, NtfPrivateSignKey, NotifierId, RcvPrivateSignKey, RecipientId)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Util (catchAll_, tryE, ($>>=))
|
||||
import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
|
||||
import System.Timeout (timeout)
|
||||
import UnliftIO (async)
|
||||
import UnliftIO (async, forConcurrently_)
|
||||
import UnliftIO.Exception (Exception)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
import Data.Either (isLeft)
|
||||
|
||||
type SMPClientVar = TMVar (Either SMPClientError SMPClient)
|
||||
|
||||
@@ -191,9 +184,9 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
|
||||
_ -> TM.insert srv sVar ps
|
||||
|
||||
serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
|
||||
serverDown ss = unless (M.null ss) $ do
|
||||
serverDown ss = unless (M.null ss) . void . runExceptT $ do
|
||||
notify . CADisconnected srv $ M.keysSet ss
|
||||
void $ runExceptT reconnectServer
|
||||
reconnectServer
|
||||
|
||||
reconnectServer :: ExceptT SMPClientError IO ()
|
||||
reconnectServer = do
|
||||
@@ -208,47 +201,27 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
|
||||
reconnectClient :: ExceptT SMPClientError IO ()
|
||||
reconnectClient = do
|
||||
withSMP ca srv $ \smp -> do
|
||||
liftIO . notify $ CAReconnected srv
|
||||
cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
|
||||
forM_ cs_ $ \cs -> do
|
||||
subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
|
||||
let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
|
||||
nRs <- liftIO $ subscribe_ smp SPNotifier nSubs
|
||||
rRs <- liftIO $ subscribe_ smp SPRecipient rSubs
|
||||
case find isLeft $ nRs <> rRs of
|
||||
Just (Left e) -> throwE e
|
||||
_ -> pure ()
|
||||
notify $ CAReconnected srv
|
||||
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
|
||||
forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
|
||||
unlessM (atomically $ hasSub (srvSubs ca) srv s) $
|
||||
subscribe_ smp sub `catchE` handleError s
|
||||
where
|
||||
isNotifier = \case
|
||||
SPNotifier -> True
|
||||
SPRecipient -> False
|
||||
subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
|
||||
subscribe_ smp sub@(s, _) = do
|
||||
smpSubscribe smp sub
|
||||
atomically $ addSubscription ca srv sub
|
||||
notify $ CAResubscribed srv s
|
||||
|
||||
subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> IO [Either SMPClientError ()]
|
||||
subscribe_ smp party subs =
|
||||
case L.nonEmpty subs of
|
||||
Just subs' -> do
|
||||
let subs'' = L.map (first snd) subs'
|
||||
rs <- L.zip subs'' <$> smpSubscribeQueues party ca smp srv subs''
|
||||
rs' <- forM rs $ \(sub, r) -> do
|
||||
let sub' = first (party,) sub
|
||||
s = fst sub'
|
||||
case snd r of
|
||||
Right () -> do
|
||||
atomically $ addSubscription ca srv sub'
|
||||
notify $ CAResubscribed srv s
|
||||
pure $ Right ()
|
||||
Left e -> do
|
||||
case e of
|
||||
PCEResponseTimeout -> pure $ Left e
|
||||
PCENetworkError -> pure $ Left e
|
||||
_ -> do
|
||||
notify $ CASubError srv s e
|
||||
atomically $ removePendingSubscription ca srv s
|
||||
pure $ Right ()
|
||||
pure $ L.toList rs'
|
||||
Nothing -> pure []
|
||||
handleError :: SMPSub -> SMPClientError -> ExceptT SMPClientError IO ()
|
||||
handleError s = \case
|
||||
e@PCEResponseTimeout -> throwE e
|
||||
e@PCENetworkError -> throwE e
|
||||
e -> do
|
||||
notify $ CASubError srv s e
|
||||
atomically $ removePendingSubscription ca srv s
|
||||
|
||||
notify :: SMPClientAgentEvent -> IO ()
|
||||
notify :: SMPClientAgentEvent -> ExceptT SMPClientError IO ()
|
||||
notify evt = atomically $ writeTBQueue (agentQ ca) evt
|
||||
|
||||
closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
|
||||
@@ -290,35 +263,6 @@ subscribeQueue ca srv sub = do
|
||||
removePendingSubscription ca srv $ fst sub
|
||||
throwE e
|
||||
|
||||
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
|
||||
subscribeQueuesSMP = subscribeQueues_ SPRecipient
|
||||
|
||||
subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
|
||||
subscribeQueuesNtfs = subscribeQueues_ SPNotifier
|
||||
|
||||
subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
|
||||
subscribeQueues_ party ca srv subs = do
|
||||
atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,)
|
||||
runExceptT (getSMPServerClient' ca srv) >>= \case
|
||||
Left e -> pure $ L.map ((,Left e) . fst) subs
|
||||
Right smp -> smpSubscribeQueues party ca smp srv subs
|
||||
|
||||
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
|
||||
smpSubscribeQueues party ca smp srv subs = do
|
||||
rs <- L.zip subs <$> subscribe smp (L.map swap subs)
|
||||
atomically $ forM rs $ \(sub, r) -> (fst sub,) <$> case r of
|
||||
Right () -> do
|
||||
addSubscription ca srv $ first (party,) sub
|
||||
pure $ Right ()
|
||||
Left e -> do
|
||||
when (e /= PCENetworkError && e /= PCEResponseTimeout) $
|
||||
removePendingSubscription ca srv $ (party,) $ fst sub
|
||||
pure $ Left e
|
||||
where
|
||||
subscribe = case party of
|
||||
SPRecipient -> subscribeSMPQueues
|
||||
SPNotifier -> subscribeSMPQueuesNtfs
|
||||
|
||||
showServer :: SMPServer -> ByteString
|
||||
showServer ProtocolServer {host, port} =
|
||||
strEncode host <> B.pack (if null port then "" else ':' : port)
|
||||
|
||||
@@ -18,14 +18,10 @@ import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Function (on)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
@@ -59,7 +55,6 @@ import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
|
||||
import UnliftIO.Directory (doesFileExist, renameFile)
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
import Data.Bifunctor (second)
|
||||
|
||||
runNtfServer :: NtfServerConfig -> IO ()
|
||||
runNtfServer cfg = do
|
||||
@@ -146,8 +141,11 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
|
||||
|
||||
resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
|
||||
resubscribe NtfSubscriber {newSubQ} subs = do
|
||||
subs' <- atomically $ filterM (fmap ntfShouldSubscribe . readTVar . subStatus) $ M.elems subs
|
||||
mapM_ (atomically . writeTBQueue newSubQ . L.map NtfSub) $ L.nonEmpty subs'
|
||||
d <- asks $ resubscribeDelay . config
|
||||
forM_ subs $ \sub@NtfSubData {} ->
|
||||
whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
|
||||
atomically $ writeTBQueue newSubQ $ NtfSub sub
|
||||
threadDelay d
|
||||
liftIO $ logInfo "SMP connections resubscribed"
|
||||
|
||||
ntfSubscriber :: NtfSubscriber -> M ()
|
||||
@@ -155,18 +153,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
raceAny_ [subscribe, receiveSMP, receiveAgent]
|
||||
where
|
||||
subscribe :: M ()
|
||||
subscribe = do
|
||||
d <- asks $ resubscribeDelay . config
|
||||
forever $ do
|
||||
subs <- atomically (readTBQueue newSubQ)
|
||||
let ss = L.groupBy ((==) `on` server) subs
|
||||
forM_ ss $ \serverSubs -> do
|
||||
SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber $ server $ L.head serverSubs
|
||||
atomically $ writeTQueue subscriberSubQ serverSubs
|
||||
when (length serverSubs > 10) $ threadDelay d
|
||||
|
||||
server :: NtfEntityRec 'Subscription -> SMPServer
|
||||
server (NtfSub sub) = ntfSubServer sub
|
||||
subscribe =
|
||||
forever $
|
||||
atomically (readTBQueue newSubQ) >>= \case
|
||||
sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
|
||||
SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
|
||||
atomically $ writeTQueue subscriberSubQ sub
|
||||
|
||||
getSMPSubscriber :: SMPServer -> M SMPSubscriber
|
||||
getSMPSubscriber smpServer =
|
||||
@@ -181,31 +173,21 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
|
||||
runSMPSubscriber :: SMPSubscriber -> M ()
|
||||
runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
|
||||
forever $ do
|
||||
subs <- atomically (peekTQueue subscriberSubQ)
|
||||
let subs' = L.map (\(NtfSub sub) -> sub) subs
|
||||
mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs'
|
||||
rs <- liftIO $ subscribeQueues (server $ L.head subs) subs'
|
||||
subs_ <- L.nonEmpty <$> foldM process [] rs
|
||||
atomically $ do
|
||||
void $ readTQueue subscriberSubQ
|
||||
mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) subs_
|
||||
where
|
||||
process subs (sub@NtfSubData {smpQueue}, r) = case r of
|
||||
Right _ -> updateSubStatus smpQueue NSActive $> subs
|
||||
Left err -> do
|
||||
handleSubError smpQueue err
|
||||
pure $ case err of
|
||||
PCEResponseTimeout -> sub : subs
|
||||
PCENetworkError -> sub : subs
|
||||
_ -> subs
|
||||
|
||||
-- | Subscribe to queues. The list of results can have a different order.
|
||||
subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
|
||||
subscribeQueues srv subs =
|
||||
L.map (second snd) . L.zip subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
|
||||
where
|
||||
sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey)
|
||||
forever $
|
||||
atomically (peekTQueue subscriberSubQ)
|
||||
>>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
|
||||
updateSubStatus smpQueue NSPending
|
||||
let SMPQueueNtf {smpServer, notifierId} = smpQueue
|
||||
liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
|
||||
Right _ -> do
|
||||
updateSubStatus smpQueue NSActive
|
||||
void . atomically $ readTQueue subscriberSubQ
|
||||
Left err -> do
|
||||
handleSubError smpQueue err
|
||||
case err of
|
||||
PCEResponseTimeout -> pure ()
|
||||
PCENetworkError -> pure ()
|
||||
_ -> void . atomically $ readTQueue subscriberSubQ
|
||||
|
||||
receiveSMP :: M ()
|
||||
receiveSMP = forever $ do
|
||||
@@ -251,6 +233,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
|
||||
PCEProtocolError e -> updateErr "SMP error " e
|
||||
PCEIOError e -> updateErr "IOError " e
|
||||
PCEInternalError e -> updateErr "InternalError " e
|
||||
PCEResponseError e -> updateErr "ResponseError " e
|
||||
PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
|
||||
PCETransportError e -> updateErr "TransportError " e
|
||||
@@ -522,7 +505,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
sub <- atomically $ mkNtfSubData subId newSub
|
||||
resp <-
|
||||
atomically (addNtfSubscription st subId sub) >>= \case
|
||||
Just _ -> atomically (writeTBQueue newSubQ [NtfSub sub]) $> NRSubId subId
|
||||
Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
|
||||
_ -> pure $ NRErr AUTH
|
||||
withNtfLog (`logCreateSubscription` sub)
|
||||
incNtfStat subCreated
|
||||
|
||||
@@ -12,7 +12,6 @@ import Control.Monad.IO.Unlift
|
||||
import Crypto.Random
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Word (Word16)
|
||||
@@ -94,7 +93,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
|
||||
newSubQ :: TBQueue (NonEmpty (NtfEntityRec 'Subscription)),
|
||||
newSubQ :: TBQueue (NtfEntityRec 'Subscription),
|
||||
smpAgent :: SMPClientAgent
|
||||
}
|
||||
|
||||
@@ -106,7 +105,7 @@ newNtfSubscriber qSize smpAgentCfg = do
|
||||
pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
|
||||
|
||||
data SMPSubscriber = SMPSubscriber
|
||||
{ newSubQ :: TQueue (NonEmpty (NtfEntityRec 'Subscription)),
|
||||
{ newSubQ :: TQueue (NtfEntityRec 'Subscription),
|
||||
subThreadId :: TVar (Maybe (Weak ThreadId))
|
||||
}
|
||||
|
||||
|
||||
@@ -28,7 +28,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
ntfServerVersion :: String
|
||||
ntfServerVersion = "1.4.1"
|
||||
ntfServerVersion = "1.3.0"
|
||||
|
||||
ntfServerCLI :: FilePath -> FilePath -> IO ()
|
||||
ntfServerCLI cfgPath logPath =
|
||||
|
||||
@@ -344,11 +344,14 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
|
||||
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
|
||||
req <- liftIO $ apnsRequest c tknStr apnsNtf
|
||||
-- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
|
||||
HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
|
||||
let status = H.responseStatus response
|
||||
reason' = maybe "" reason $ J.decodeStrict' bodyHead
|
||||
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
|
||||
result status reason'
|
||||
res <- liftHTTPS2 $ sendRequest http2 req Nothing
|
||||
case res of
|
||||
HTTP2RequestResponse HTTP2Response {response, respBody = HTTP2Body {bodyHead}} -> do
|
||||
let status = H.responseStatus response
|
||||
reason' = maybe "" reason $ J.decodeStrict' bodyHead
|
||||
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
|
||||
result status reason'
|
||||
HTTP2RequestError _e -> throwError PPPermanentError
|
||||
where
|
||||
result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
result status reason'
|
||||
|
||||
@@ -20,7 +20,7 @@ import qualified Data.Set as S
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer)
|
||||
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (whenM, ($>>=))
|
||||
@@ -68,9 +68,6 @@ data NtfSubData = NtfSubData
|
||||
subStatus :: TVar NtfSubStatus
|
||||
}
|
||||
|
||||
ntfSubServer :: NtfSubData -> SMPServer
|
||||
ntfSubServer NtfSubData {smpQueue = SMPQueueNtf {smpServer}} = smpServer
|
||||
|
||||
data NtfEntityRec (e :: NtfEntity) where
|
||||
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
|
||||
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
|
||||
|
||||
@@ -741,8 +741,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
|
||||
st <- asks queueStore
|
||||
ms <- asks msgStore
|
||||
quota <- asks $ msgQueueQuota . config
|
||||
old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
|
||||
runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota old_) . B.lines) >>= \case
|
||||
runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
|
||||
Left e -> do
|
||||
logError . T.pack $ "error restoring messages: " <> e
|
||||
liftIO exitFailure
|
||||
@@ -750,7 +749,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
|
||||
renameFile f $ f <> ".bak"
|
||||
logInfo "messages restored"
|
||||
where
|
||||
restoreMsg st ms quota old_ s = do
|
||||
restoreMsg st ms quota s = do
|
||||
r <- liftEither . first (msgErr "parsing") $ strDecode s
|
||||
case r of
|
||||
MLRv3 rId msg -> addToMsgQueue rId msg
|
||||
@@ -760,14 +759,13 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
|
||||
addToMsgQueue rId msg'
|
||||
where
|
||||
addToMsgQueue rId msg = do
|
||||
logFull <- atomically $ do
|
||||
full <- atomically $ do
|
||||
q <- getMsgQueue ms rId quota
|
||||
case msg of
|
||||
Message {msgTs}
|
||||
| maybe True (systemSeconds msgTs >=) old_ -> isNothing <$> writeMsg q msg
|
||||
| otherwise -> pure False
|
||||
MessageQuota {} -> writeMsg q msg $> False
|
||||
when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
|
||||
isNothing <$> writeMsg q msg
|
||||
case msg of
|
||||
Message {} ->
|
||||
when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
|
||||
MessageQuota {} -> pure ()
|
||||
updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
|
||||
let nonce = C.cbNonce msgId
|
||||
msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
|
||||
|
||||
@@ -164,9 +164,6 @@ strictIni section key ini =
|
||||
readStrictIni :: Read a => Text -> Text -> Ini -> a
|
||||
readStrictIni section key = read . T.unpack . strictIni section key
|
||||
|
||||
readIniDefault :: Read a => a -> Text -> Text -> Ini -> a
|
||||
readIniDefault def section key = either (const def) (read . T.unpack) . lookupValue section key
|
||||
|
||||
iniOnOff :: Text -> Text -> Ini -> Maybe Bool
|
||||
iniOnOff section name ini = case lookupValue section name ini of
|
||||
Right "on" -> Just True
|
||||
|
||||
@@ -72,13 +72,10 @@ data ServerConfig = ServerConfig
|
||||
logTLSErrors :: Bool
|
||||
}
|
||||
|
||||
defMsgExpirationDays :: Int64
|
||||
defMsgExpirationDays = 21
|
||||
|
||||
defaultMessageExpiration :: ExpirationConfig
|
||||
defaultMessageExpiration =
|
||||
ExpirationConfig
|
||||
{ ttl = defMsgExpirationDays * 86400, -- seconds
|
||||
{ ttl = 30 * 86400, -- seconds, 30 days
|
||||
checkInterval = 43200 -- seconds, 12 hours
|
||||
}
|
||||
|
||||
|
||||
@@ -15,14 +15,3 @@ data ExpirationConfig = ExpirationConfig
|
||||
|
||||
expireBeforeEpoch :: ExpirationConfig -> IO Int64
|
||||
expireBeforeEpoch ExpirationConfig {ttl} = subtract ttl . systemSeconds <$> liftIO getSystemTime
|
||||
|
||||
showTTL :: Int64 -> String
|
||||
showTTL s
|
||||
| s' /= 0 = show s <> " seconds"
|
||||
| ms' /= 0 = show ms <> " minutes"
|
||||
| hs' /= 0 = show hs <> " hours"
|
||||
| otherwise = show ds <> " days"
|
||||
where
|
||||
(ms, s') = s `divMod` 60
|
||||
(hs, ms') = ms `divMod` 60
|
||||
(ds, hs') = hs `divMod` 24
|
||||
|
||||
@@ -24,7 +24,7 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
|
||||
import Simplex.Messaging.Server (runSMPServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration, defMsgExpirationDays)
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
@@ -106,8 +106,7 @@ smpServerCLI cfgPath logPath =
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_messages: " <> onOff enableStoreLog <> "\n")
|
||||
<> ("expire_messages_days: " <> show defMsgExpirationDays <> "\n\n")
|
||||
<> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Log daily server statistics to CSV file\n"
|
||||
<> ("log_stats: " <> onOff logStats <> "\n\n")
|
||||
<> "[AUTH]\n\
|
||||
@@ -141,13 +140,10 @@ smpServerCLI cfgPath logPath =
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
|
||||
cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig
|
||||
srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
|
||||
printServiceInfo serverVersion srv
|
||||
printServerConfig transports storeLogFile
|
||||
putStrLn $ case messageExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
|
||||
_ -> "not expiring messages"
|
||||
putStrLn $ case inactiveClientExpiration of
|
||||
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
||||
_ -> "not expiring inactive clients"
|
||||
@@ -165,7 +161,7 @@ smpServerCLI cfgPath logPath =
|
||||
ServerConfig
|
||||
{ transports = iniTransports ini,
|
||||
tbqSize = 32,
|
||||
serverTbqSize = 1024,
|
||||
serverTbqSize = 128,
|
||||
msgQueueQuota = 128,
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
||||
@@ -183,10 +179,7 @@ smpServerCLI cfgPath logPath =
|
||||
-- allow creating new queues by default
|
||||
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
|
||||
newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
|
||||
messageExpiration =
|
||||
Just defaultMessageExpiration
|
||||
{ ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
|
||||
},
|
||||
messageExpiration = Just defaultMessageExpiration,
|
||||
inactiveClientExpiration =
|
||||
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
|
||||
$> ExpirationConfig
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Transport.HTTP2 where
|
||||
|
||||
@@ -23,7 +24,16 @@ defaultHTTP2BufferSize :: BufferSize
|
||||
defaultHTTP2BufferSize = 32768
|
||||
|
||||
withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a
|
||||
withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c)
|
||||
withHTTP2 sz run c =
|
||||
E.bracket
|
||||
(allocHTTP2Config c sz)
|
||||
freeSimpleConfig
|
||||
( \cfg ->
|
||||
run cfg (tlsUniq c) `E.catch` \(e :: E.SomeException) ->
|
||||
do
|
||||
print $ "withHTTP2 e: " <> show e
|
||||
E.throwIO e
|
||||
)
|
||||
|
||||
allocHTTP2Config :: TLS -> BufferSize -> IO Config
|
||||
allocHTTP2Config c sz = do
|
||||
|
||||
@@ -29,10 +29,10 @@ import UnliftIO.STM
|
||||
import UnliftIO.Timeout
|
||||
|
||||
data HTTP2Client = HTTP2Client
|
||||
{ action :: Maybe (Async HTTP2Response),
|
||||
{ action :: Maybe (Async HTTP2RequestResult),
|
||||
sessionId :: SessionId,
|
||||
sessionTs :: UTCTime,
|
||||
sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response,
|
||||
sendReq :: Request -> (Response -> IO HTTP2RequestResult) -> IO HTTP2RequestResult,
|
||||
client_ :: HClient
|
||||
}
|
||||
|
||||
@@ -42,9 +42,13 @@ data HClient = HClient
|
||||
host :: TransportHost,
|
||||
port :: ServiceName,
|
||||
config :: HTTP2ClientConfig,
|
||||
reqQ :: TBQueue (Request, TMVar HTTP2Response)
|
||||
reqQ :: TBQueue (Request, TMVar HTTP2RequestResult)
|
||||
}
|
||||
|
||||
data HTTP2RequestResult
|
||||
= HTTP2RequestResponse HTTP2Response
|
||||
| HTTP2RequestError E.SomeException
|
||||
|
||||
data HTTP2Response = HTTP2Response
|
||||
{ response :: Response,
|
||||
respBody :: HTTP2Body
|
||||
@@ -101,7 +105,7 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien
|
||||
Just (Left e) -> Left e
|
||||
Nothing -> Left HCNetworkError
|
||||
|
||||
client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2Response
|
||||
client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2RequestResult
|
||||
client c cVar sessionId sendReq = do
|
||||
sessionTs <- getCurrentTime
|
||||
let c' = HTTP2Client {action = Nothing, client_ = c, sendReq, sessionId, sessionTs}
|
||||
@@ -110,28 +114,34 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien
|
||||
putTMVar cVar (Right c')
|
||||
process c' sendReq `E.finally` disconnected
|
||||
|
||||
process :: HTTP2Client -> H.Client HTTP2Response
|
||||
process :: HTTP2Client -> H.Client HTTP2RequestResult
|
||||
process HTTP2Client {client_ = HClient {reqQ}} sendReq = forever $ do
|
||||
(req, respVar) <- atomically $ readTBQueue reqQ
|
||||
sendReq req $ \r -> do
|
||||
respBody <- getHTTP2Body r bodyHeadSize
|
||||
let resp = HTTP2Response {response = r, respBody}
|
||||
atomically $ putTMVar respVar resp
|
||||
pure resp
|
||||
(req, resVar) <- atomically $ readTBQueue reqQ
|
||||
sendReq req (processResp resVar) `E.catch` \e -> do
|
||||
liftIO $ print $ "in process catch e: " <> show e
|
||||
let res = HTTP2RequestError e
|
||||
atomically $ putTMVar resVar res
|
||||
pure res
|
||||
where
|
||||
processResp resVar r = do
|
||||
respBody <- getHTTP2Body r bodyHeadSize
|
||||
let res = HTTP2RequestResponse $ HTTP2Response {response = r, respBody}
|
||||
atomically $ putTMVar resVar res
|
||||
pure res
|
||||
|
||||
-- | Disconnects client from the server and terminates client threads.
|
||||
closeHTTP2Client :: HTTP2Client -> IO ()
|
||||
closeHTTP2Client = mapM_ uninterruptibleCancel . action
|
||||
|
||||
sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
|
||||
sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2RequestResult)
|
||||
sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req reqTimeout_ = do
|
||||
resp <- newEmptyTMVarIO
|
||||
atomically $ writeTBQueue reqQ (req, resp)
|
||||
resVar <- newEmptyTMVarIO
|
||||
atomically $ writeTBQueue reqQ (req, resVar)
|
||||
let reqTimeout = http2RequestTimeout config reqTimeout_
|
||||
maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resp))
|
||||
maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resVar))
|
||||
|
||||
-- | this function should not be used until HTTP2 is thread safe, use sendRequest
|
||||
sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
|
||||
sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2RequestResult)
|
||||
sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req reqTimeout_ = do
|
||||
let reqTimeout = http2RequestTimeout config reqTimeout_
|
||||
reqTimeout `timeout` try (sendReq req process) >>= \case
|
||||
@@ -141,7 +151,7 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
|
||||
where
|
||||
process r = do
|
||||
respBody <- getHTTP2Body r $ bodyHeadSize config
|
||||
pure HTTP2Response {response = r, respBody}
|
||||
pure $ HTTP2RequestResponse $ HTTP2Response {response = r, respBody}
|
||||
|
||||
http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
|
||||
http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
|
||||
|
||||
@@ -12,11 +12,13 @@ import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Fixed (Fixed (MkFixed), Pico)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Data.Time (nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime)
|
||||
import UnliftIO.Async
|
||||
|
||||
raceAny_ :: MonadUnliftIO m => [m a] -> m ()
|
||||
@@ -115,8 +117,14 @@ threadDelay' time = do
|
||||
threadDelay $ fromIntegral maxWait
|
||||
when (maxWait /= time) $ threadDelay' (time - maxWait)
|
||||
|
||||
diffToMicroseconds :: NominalDiffTime -> Int64
|
||||
diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer)
|
||||
diffInSeconds :: UTCTime -> UTCTime -> Int64
|
||||
diffInSeconds a b = (`div` 1000000_000000) $ diffInPicos a b
|
||||
|
||||
diffToMilliseconds :: NominalDiffTime -> Int64
|
||||
diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer)
|
||||
diffInMicros :: UTCTime -> UTCTime -> Int64
|
||||
diffInMicros a b = (`div` 1000000) $ diffInPicos a b
|
||||
|
||||
diffInPicos :: UTCTime -> UTCTime -> Int64
|
||||
diffInPicos a b = fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
|
||||
|
||||
fromPico :: Pico -> Integer
|
||||
fromPico (MkFixed i) = i
|
||||
|
||||
@@ -61,7 +61,6 @@ import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (ATransport (..))
|
||||
import Simplex.Messaging.Util (tryError)
|
||||
import Simplex.Messaging.Version
|
||||
import System.Directory (copyFile, renameFile)
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
import XFTPClient (testXFTPServer)
|
||||
@@ -125,18 +124,6 @@ runRight action =
|
||||
Right x -> pure x
|
||||
Left e -> error $ "Unexpected error: " <> show e
|
||||
|
||||
getInAnyOrder :: HasCallStack => AgentClient -> [AEntityTransmission 'AEConn -> Bool] -> Expectation
|
||||
getInAnyOrder _ [] = pure ()
|
||||
getInAnyOrder c rs = do
|
||||
r <- get c
|
||||
let rest = filter (not . expected r) rs
|
||||
if length rest < length rs
|
||||
then getInAnyOrder c rest
|
||||
else error $ "unexpected event: " <> show r
|
||||
where
|
||||
expected :: AEntityTransmission 'AEConn -> (AEntityTransmission 'AEConn -> Bool) -> Bool
|
||||
expected r rp = rp r
|
||||
|
||||
functionalAPITests :: ATransport -> Spec
|
||||
functionalAPITests t = do
|
||||
describe "Establishing duplex connection" $ do
|
||||
@@ -160,13 +147,9 @@ functionalAPITests t = do
|
||||
testAsyncServerOffline t
|
||||
it "should notify after HELLO timeout" $
|
||||
withSmpServer t testAsyncHelloTimeout
|
||||
describe "Message delivery" $ do
|
||||
describe "Duplicate message delivery" $
|
||||
it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
|
||||
testDuplicateMessage t
|
||||
it "should report error via msg integrity on skipped messages" $
|
||||
testSkippedMessages t
|
||||
it "should report decryption error on ratchet becoming out of sync" $
|
||||
testDecryptionError t
|
||||
describe "Inactive client disconnection" $ do
|
||||
it "should disconnect clients if it was inactive longer than TTL" $
|
||||
testInactiveClientDisconnected t
|
||||
@@ -180,11 +163,8 @@ functionalAPITests t = do
|
||||
it "should suspend agent on timeout, even if pending messages not sent" $
|
||||
testSuspendingAgentTimeout t
|
||||
describe "Batching SMP commands" $ do
|
||||
it "should subscribe to multiple (200) subscriptions with batching" $
|
||||
testBatchedSubscriptions 200 10 t
|
||||
-- 200 subscriptions gets very slow with test coverage, use below test instead
|
||||
xit "should subscribe to multiple (6) subscriptions with batching" $
|
||||
testBatchedSubscriptions 6 3 t
|
||||
it "should subscribe to multiple subscriptions with batching" $
|
||||
testBatchedSubscriptions t
|
||||
describe "Async agent commands" $ do
|
||||
it "should connect using async agent commands" $
|
||||
withSmpServer t testAsyncCommands
|
||||
@@ -203,23 +183,13 @@ functionalAPITests t = do
|
||||
testUsersNoServer t
|
||||
it "should connect two users and switch session mode" $
|
||||
withSmpServer t testTwoUsers
|
||||
describe "Connection switch" $ do
|
||||
describe "Queue rotation" $ do
|
||||
describe "should switch delivery to the new queue" $
|
||||
testServerMatrix2 t testSwitchConnection
|
||||
describe "should switch to new queue asynchronously" $
|
||||
testServerMatrix2 t testSwitchAsync
|
||||
describe "should delete connection during switch" $
|
||||
describe "should delete connection during rotation" $
|
||||
testServerMatrix2 t testSwitchDelete
|
||||
describe "should abort switch in Started phase" $
|
||||
testServerMatrix2 t testAbortSwitchStarted
|
||||
describe "should abort switch in Started phase, reinitiate immediately" $
|
||||
testServerMatrix2 t testAbortSwitchStartedReinitiate
|
||||
describe "should prohibit to abort switch in Secured phase" $
|
||||
testServerMatrix2 t testCannotAbortSwitchSecured
|
||||
describe "should switch two connections simultaneously" $
|
||||
testServerMatrix2 t testSwitch2Connections
|
||||
describe "should switch two connections simultaneously, abort one" $
|
||||
testServerMatrix2 t testSwitch2ConnectionsAbort1
|
||||
describe "SMP basic auth" $ do
|
||||
describe "with server auth" $ do
|
||||
-- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail
|
||||
@@ -521,101 +491,6 @@ testDuplicateMessage t = do
|
||||
get alice2 ##> ("", bobId, SENT 6)
|
||||
get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
|
||||
|
||||
testSkippedMessages :: HasCallStack => ATransport -> IO ()
|
||||
testSkippedMessages t = do
|
||||
alice <- getSMPAgentClient' agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
||||
runRight_ $ do
|
||||
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT 4)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 4
|
||||
|
||||
disconnectAgentClient bob
|
||||
|
||||
runRight_ $ do
|
||||
5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
|
||||
get alice ##> ("", bobId, SENT 5)
|
||||
6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
|
||||
get alice ##> ("", bobId, SENT 6)
|
||||
7 <- sendMessage alice bobId SMP.noMsgFlags "hello 4"
|
||||
get alice ##> ("", bobId, SENT 7)
|
||||
|
||||
pure (aliceId, bobId)
|
||||
|
||||
nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
|
||||
threadDelay 200000
|
||||
|
||||
disconnectAgentClient alice
|
||||
|
||||
alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
|
||||
bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
runRight_ $ do
|
||||
subscribeConnection bob2 aliceId
|
||||
subscribeConnection alice2 bobId
|
||||
|
||||
8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5"
|
||||
get alice2 ##> ("", bobId, SENT 8)
|
||||
get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False
|
||||
ackMessage bob2 aliceId 5
|
||||
|
||||
9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6"
|
||||
get alice2 ##> ("", bobId, SENT 9)
|
||||
get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False
|
||||
ackMessage bob2 aliceId 6
|
||||
|
||||
testDecryptionError :: HasCallStack => ATransport -> IO ()
|
||||
testDecryptionError t = do
|
||||
alice <- getSMPAgentClient' agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
|
||||
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
|
||||
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
||||
runRight_ $ do
|
||||
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
get alice ##> ("", bobId, SENT 4)
|
||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 4
|
||||
|
||||
5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
|
||||
get bob ##> ("", aliceId, SENT 5)
|
||||
get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId 5
|
||||
|
||||
liftIO $ copyFile testDB2 (testDB2 <> ".bak")
|
||||
|
||||
6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
|
||||
get alice ##> ("", bobId, SENT 6)
|
||||
get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
|
||||
ackMessage bob aliceId 6
|
||||
|
||||
7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
|
||||
get bob ##> ("", aliceId, SENT 7)
|
||||
get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId 7
|
||||
|
||||
disconnectAgentClient bob
|
||||
|
||||
-- importing database backup after progressing ratchet de-synchronizes ratchet,
|
||||
-- this will be fixed by ratchet re-negotiation
|
||||
liftIO $ renameFile (testDB2 <> ".bak") testDB2
|
||||
|
||||
bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
|
||||
|
||||
runRight_ $ do
|
||||
subscribeConnection bob2 aliceId
|
||||
|
||||
8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5"
|
||||
get alice ##> ("", bobId, SENT 8)
|
||||
get bob2 =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == aliceId; _ -> False
|
||||
|
||||
6 <- sendMessage bob2 aliceId SMP.noMsgFlags "hello 6"
|
||||
get bob2 ##> ("", aliceId, SENT 6)
|
||||
get alice =##> \case ("", c, ERR AGENT {agentErr = A_CRYPTO {cryptoErr = RATCHET_HEADER}}) -> c == bobId; _ -> False
|
||||
|
||||
makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
||||
makeConnection alice bob = makeConnectionForUsers alice 1 bob 1
|
||||
|
||||
@@ -737,14 +612,14 @@ testSuspendingAgentTimeout t = do
|
||||
("", "", SUSPENDED) <- nGet b
|
||||
pure ()
|
||||
|
||||
testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
|
||||
testBatchedSubscriptions nCreate nDel t = do
|
||||
testBatchedSubscriptions :: ATransport -> IO ()
|
||||
testBatchedSubscriptions t = do
|
||||
a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
|
||||
b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
|
||||
conns <- runServers $ do
|
||||
conns <- forM [1 .. nCreate :: Int] . const $ makeConnection a b
|
||||
conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
|
||||
forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
|
||||
let (aIds', bIds') = unzip $ take nDel conns
|
||||
let (aIds', bIds') = unzip $ take 10 conns
|
||||
delete a bIds'
|
||||
delete b aIds'
|
||||
liftIO $ threadDelay 1000000
|
||||
@@ -760,14 +635,11 @@ testBatchedSubscriptions nCreate nDel t = do
|
||||
("", "", UP {}) <- nGet b
|
||||
liftIO $ threadDelay 1000000
|
||||
let (aIds, bIds) = unzip conns
|
||||
conns' = drop nDel conns
|
||||
conns' = drop 10 conns
|
||||
(aIds', bIds') = unzip conns'
|
||||
subscribe a bIds
|
||||
subscribe b aIds
|
||||
forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
|
||||
void $ resubscribeConnections a bIds
|
||||
void $ resubscribeConnections b aIds
|
||||
forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 8 a bId b aId
|
||||
delete a bIds'
|
||||
delete b aIds'
|
||||
deleteFail a bIds'
|
||||
@@ -777,7 +649,7 @@ testBatchedSubscriptions nCreate nDel t = do
|
||||
subscribe c cs = do
|
||||
r <- subscribeConnections c cs
|
||||
liftIO $ do
|
||||
let dc = S.fromList $ take nDel cs
|
||||
let dc = S.fromList $ take 10 cs
|
||||
all isRight (M.withoutKeys r dc) `shouldBe` True
|
||||
all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
|
||||
M.keys r `shouldMatchList` cs
|
||||
@@ -983,49 +855,28 @@ testSwitchConnection servers = do
|
||||
runRight_ $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
testFullSwitch a bId b aId 10
|
||||
testFullSwitch a bId b aId 16
|
||||
|
||||
testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO ()
|
||||
testFullSwitch a bId b aId msgId = do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
switchComplete a bId b aId
|
||||
exchangeGreetingsMsgId msgId a bId b aId
|
||||
switchConnectionAsync a "" bId
|
||||
switchComplete a bId b aId
|
||||
exchangeGreetingsMsgId 10 a bId b aId
|
||||
|
||||
switchComplete :: AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()
|
||||
switchComplete a bId b aId = do
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
||||
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
||||
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId SPCompleted [Nothing]
|
||||
phaseRcv a bId SPCompleted [Nothing]
|
||||
phase a bId QDRcv SPStarted
|
||||
phase b aId QDSnd SPStarted
|
||||
phase a bId QDRcv SPConfirmed
|
||||
phase b aId QDSnd SPConfirmed
|
||||
phase b aId QDSnd SPCompleted
|
||||
phase a bId QDRcv SPCompleted
|
||||
|
||||
phaseRcv :: AgentClient -> ByteString -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ExceptT AgentErrorType IO ()
|
||||
phaseRcv c connId p swchStatuses = phase c connId QDRcv p (\stats -> rcvSwchStatuses' stats `shouldMatchList` swchStatuses)
|
||||
|
||||
rcvSwchStatuses' :: ConnectionStats -> [Maybe RcvSwitchStatus]
|
||||
rcvSwchStatuses' ConnectionStats {rcvQueuesInfo} = map (\RcvQueueInfo {rcvSwitchStatus} -> rcvSwitchStatus) rcvQueuesInfo
|
||||
|
||||
phaseSnd :: AgentClient -> ByteString -> SwitchPhase -> [Maybe SndSwitchStatus] -> ExceptT AgentErrorType IO ()
|
||||
phaseSnd c connId p swchStatuses = phase c connId QDSnd p (\stats -> sndSwchStatuses' stats `shouldMatchList` swchStatuses)
|
||||
|
||||
sndSwchStatuses' :: ConnectionStats -> [Maybe SndSwitchStatus]
|
||||
sndSwchStatuses' ConnectionStats {sndQueuesInfo} = map (\SndQueueInfo {sndSwitchStatus} -> sndSwitchStatus) sndQueuesInfo
|
||||
|
||||
phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Expectation) -> ExceptT AgentErrorType IO ()
|
||||
phase c connId d p statsExpectation =
|
||||
phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> ExceptT AgentErrorType IO ()
|
||||
phase c connId d p =
|
||||
get c >>= \(_, connId', msg) -> do
|
||||
liftIO $ connId `shouldBe` connId'
|
||||
case msg of
|
||||
SWITCH d' p' stats -> liftIO $ do
|
||||
SWITCH d' p' _ -> liftIO $ do
|
||||
d `shouldBe` d'
|
||||
p `shouldBe` p'
|
||||
statsExpectation stats
|
||||
ERR (AGENT A_DUPLICATE) -> phase c connId d p statsExpectation
|
||||
ERR (AGENT A_DUPLICATE) -> phase c connId d p
|
||||
r -> do
|
||||
liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
|
||||
SWITCH {} <- pure r
|
||||
@@ -1037,44 +888,33 @@ testSwitchAsync servers = do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
pure (aId, bId)
|
||||
let withA' = sessionSubscribe withA [bId]
|
||||
withB' = sessionSubscribe withB [aId]
|
||||
let withA' = session withA bId
|
||||
withB' = session withB aId
|
||||
withA' $ \a -> do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
switchConnectionAsync a "" bId
|
||||
phase a bId QDRcv SPStarted
|
||||
withB' $ \b -> phase b aId QDSnd SPStarted
|
||||
withA' $ \a -> phase a bId QDRcv SPConfirmed
|
||||
withB' $ \b -> do
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
withA' $ \a -> do
|
||||
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
||||
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
||||
withB' $ \b -> do
|
||||
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId SPCompleted [Nothing]
|
||||
withA' $ \a -> phaseRcv a bId SPCompleted [Nothing]
|
||||
phase b aId QDSnd SPConfirmed
|
||||
phase b aId QDSnd SPCompleted
|
||||
withA' $ \a -> phase a bId QDRcv SPCompleted
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
subscribeConnection a bId
|
||||
subscribeConnection b aId
|
||||
exchangeGreetingsMsgId 10 a bId b aId
|
||||
testFullSwitch a bId b aId 16
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
withAgent :: AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a
|
||||
withAgent cfg' servers dbPath = bracket (getSMPAgentClient' cfg' servers dbPath) disconnectAgentClient
|
||||
|
||||
sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
|
||||
sessionSubscribe withC connIds a =
|
||||
withC $ \c -> runRight_ $ do
|
||||
void $ subscribeConnections c connIds
|
||||
r <- a c
|
||||
liftIO $ threadDelay 500000
|
||||
liftIO $ noMessages c "nothing else should be delivered"
|
||||
pure r
|
||||
withAgent :: AgentConfig -> FilePath -> (AgentClient -> IO a) -> IO a
|
||||
withAgent cfg' dbPath = bracket (getSMPAgentClient' cfg' servers dbPath) disconnectAgentClient
|
||||
session :: (forall a. (AgentClient -> IO a) -> IO a) -> ConnId -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
|
||||
session withC connId a =
|
||||
withC $ \c -> runRight_ $ do
|
||||
subscribeConnection c connId
|
||||
r <- a c
|
||||
liftIO $ threadDelay 500000
|
||||
pure r
|
||||
withA = withAgent agentCfg testDB
|
||||
withB = withAgent agentCfg {initialClientId = 1} testDB2
|
||||
|
||||
testSwitchDelete :: InitialAgentServers -> IO ()
|
||||
testSwitchDelete servers = do
|
||||
@@ -1084,280 +924,14 @@ testSwitchDelete servers = do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
disconnectAgentClient b
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
switchConnectionAsync a "" bId
|
||||
phase a bId QDRcv SPStarted
|
||||
deleteConnectionAsync a bId
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
|
||||
get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
|
||||
liftIO $ noMessages a "nothing else should be delivered to alice"
|
||||
|
||||
testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testAbortSwitchStarted servers = do
|
||||
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
pure (aId, bId)
|
||||
let withA' = sessionSubscribe withA [bId]
|
||||
withB' = sessionSubscribe withB [aId]
|
||||
withA' $ \a -> do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
-- repeat switch is prohibited
|
||||
Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ switchConnectionAsync a "" bId
|
||||
-- abort current switch
|
||||
stats' <- abortConnectionSwitch a bId
|
||||
liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
|
||||
withB' $ \b -> do
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
withA' $ \a -> do
|
||||
get a ##> ("", bId, ERR (AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}))
|
||||
-- repeat switch
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
subscribeConnection a bId
|
||||
subscribeConnection b aId
|
||||
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
|
||||
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
||||
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
||||
|
||||
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId SPCompleted [Nothing]
|
||||
|
||||
phaseRcv a bId SPCompleted [Nothing]
|
||||
|
||||
exchangeGreetingsMsgId 12 a bId b aId
|
||||
|
||||
testFullSwitch a bId b aId 18
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testAbortSwitchStartedReinitiate servers = do
|
||||
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
pure (aId, bId)
|
||||
let withA' = sessionSubscribe withA [bId]
|
||||
withB' = sessionSubscribe withB [aId]
|
||||
withA' $ \a -> do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
-- abort current switch
|
||||
stats' <- abortConnectionSwitch a bId
|
||||
liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
|
||||
-- repeat switch
|
||||
stats'' <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats'' `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
withB' $ \b -> do
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
liftIO . getInAnyOrder b $
|
||||
[ switchPhaseSndP aId SPStarted [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
subscribeConnection a bId
|
||||
subscribeConnection b aId
|
||||
|
||||
liftIO . getInAnyOrder a $
|
||||
[ errQueueNotFoundP bId,
|
||||
switchPhaseRcvP bId SPConfirmed [Just RSSendingQADD, Nothing]
|
||||
]
|
||||
|
||||
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
||||
|
||||
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId SPCompleted [Nothing]
|
||||
|
||||
phaseRcv a bId SPCompleted [Nothing]
|
||||
|
||||
exchangeGreetingsMsgId 12 a bId b aId
|
||||
|
||||
testFullSwitch a bId b aId 18
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
|
||||
switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
|
||||
|
||||
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> AEntityTransmission 'AEConn -> Bool
|
||||
switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
|
||||
|
||||
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> AEntityTransmission 'AEConn -> Bool
|
||||
switchPhaseP cId qd sphase statsP = \case
|
||||
(_, cId', SWITCH qd' sphase' stats) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
|
||||
_ -> False
|
||||
|
||||
errQueueNotFoundP :: ConnId -> AEntityTransmission 'AEConn -> Bool
|
||||
errQueueNotFoundP cId = \case
|
||||
(_, cId', ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}) -> cId' == cId
|
||||
_ -> False
|
||||
|
||||
testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testCannotAbortSwitchSecured servers = do
|
||||
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
pure (aId, bId)
|
||||
let withA' = sessionSubscribe withA [bId]
|
||||
withB' = sessionSubscribe withB [aId]
|
||||
withA' $ \a -> do
|
||||
stats <- switchConnectionAsync a "" bId
|
||||
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
||||
withB' $ \b -> do
|
||||
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
||||
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
withA' $ \a -> do
|
||||
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
||||
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
||||
Left Agent.CMD {cmdErr = PROHIBITED} <- runExceptT $ abortConnectionSwitch a bId
|
||||
pure ()
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
subscribeConnection a bId
|
||||
subscribeConnection b aId
|
||||
|
||||
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId SPCompleted [Nothing]
|
||||
|
||||
phaseRcv a bId SPCompleted [Nothing]
|
||||
|
||||
exchangeGreetingsMsgId 10 a bId b aId
|
||||
|
||||
testFullSwitch a bId b aId 16
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testSwitch2Connections servers = do
|
||||
(aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId1, bId1) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId1 b aId1
|
||||
(aId2, bId2) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId2 b aId2
|
||||
pure (aId1, bId1, aId2, bId2)
|
||||
withA $ \a -> runRight_ $ do
|
||||
void $ subscribeConnections a [bId1, bId2]
|
||||
stats1 <- switchConnectionAsync a "" bId1
|
||||
liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
|
||||
stats2 <- switchConnectionAsync a "" bId2
|
||||
liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
void $ subscribeConnections a [bId1, bId2]
|
||||
void $ subscribeConnections b [aId1, aId2]
|
||||
|
||||
liftIO . getInAnyOrder b $
|
||||
[ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
]
|
||||
|
||||
liftIO . getInAnyOrder a $
|
||||
[ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
|
||||
switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
|
||||
switchPhaseRcvP bId2 SPConfirmed [Just RSSendingQADD, Nothing],
|
||||
switchPhaseRcvP bId2 SPSecured [Just RSSendingQUSE, Nothing]
|
||||
]
|
||||
|
||||
liftIO . getInAnyOrder b $
|
||||
[ switchPhaseSndP aId1 SPSecured [Just SSSendingQTEST, Nothing],
|
||||
switchPhaseSndP aId1 SPCompleted [Nothing],
|
||||
switchPhaseSndP aId2 SPSecured [Just SSSendingQTEST, Nothing],
|
||||
switchPhaseSndP aId2 SPCompleted [Nothing]
|
||||
]
|
||||
|
||||
liftIO . getInAnyOrder a $
|
||||
[ switchPhaseRcvP bId1 SPCompleted [Nothing],
|
||||
switchPhaseRcvP bId2 SPCompleted [Nothing]
|
||||
]
|
||||
|
||||
exchangeGreetingsMsgId 10 a bId1 b aId1
|
||||
exchangeGreetingsMsgId 10 a bId2 b aId2
|
||||
|
||||
testFullSwitch a bId1 b aId1 16
|
||||
testFullSwitch a bId2 b aId2 16
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testSwitch2ConnectionsAbort1 servers = do
|
||||
(aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId1, bId1) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId1 b aId1
|
||||
(aId2, bId2) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId2 b aId2
|
||||
pure (aId1, bId1, aId2, bId2)
|
||||
let withA' = sessionSubscribe withA [bId1, bId2]
|
||||
withB' = sessionSubscribe withB [aId1, aId2]
|
||||
withA' $ \a -> do
|
||||
stats1 <- switchConnectionAsync a "" bId1
|
||||
liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
|
||||
stats2 <- switchConnectionAsync a "" bId2
|
||||
liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
|
||||
phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
|
||||
-- abort switch of second connection
|
||||
stats2' <- abortConnectionSwitch a bId2
|
||||
liftIO $ rcvSwchStatuses' stats2' `shouldMatchList` [Nothing]
|
||||
withB' $ \b -> do
|
||||
liftIO . getInAnyOrder b $
|
||||
[ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
|
||||
switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
|
||||
]
|
||||
withA' $ \a -> do
|
||||
liftIO . getInAnyOrder a $
|
||||
[ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
|
||||
switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
|
||||
errQueueNotFoundP bId2
|
||||
]
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
void $ subscribeConnections a [bId1, bId2]
|
||||
void $ subscribeConnections b [aId1, aId2]
|
||||
|
||||
phaseSnd b aId1 SPSecured [Just SSSendingQTEST, Nothing]
|
||||
phaseSnd b aId1 SPCompleted [Nothing]
|
||||
|
||||
phaseRcv a bId1 SPCompleted [Nothing]
|
||||
|
||||
exchangeGreetingsMsgId 10 a bId1 b aId1
|
||||
exchangeGreetingsMsgId 8 a bId2 b aId2
|
||||
|
||||
testFullSwitch a bId1 b aId1 16
|
||||
testFullSwitch a bId2 b aId2 14
|
||||
where
|
||||
withA :: (AgentClient -> IO a) -> IO a
|
||||
withA = withAgent agentCfg servers testDB
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent agentCfg {initialClientId = 1} servers testDB2
|
||||
|
||||
testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
|
||||
testCreateQueueAuth clnt1 clnt2 = do
|
||||
a <- getClient clnt1
|
||||
|
||||
@@ -19,8 +19,8 @@ import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import NtfClient
|
||||
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2)
|
||||
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
|
||||
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
|
||||
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn, xit')
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
@@ -31,7 +31,6 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Types (NtfToken (..))
|
||||
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Transport (ATransport)
|
||||
import Simplex.Messaging.Util (tryE)
|
||||
import System.Directory (doesFileExist, removeFile)
|
||||
@@ -86,10 +85,6 @@ notificationTests t =
|
||||
it "should resume subscriptions after SMP server is restarted" $ \_ ->
|
||||
withAPNSMockServer $ \apns ->
|
||||
withNtfServer t $ testNotificationsSMPRestart t apns
|
||||
describe "Notifications after SMP server restart" $
|
||||
it "should resume batched subscriptions after SMP server is restarted" $ \_ ->
|
||||
withAPNSMockServer $ \apns ->
|
||||
withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
|
||||
describe "should switch notifications to the new queue" $
|
||||
testServerMatrix2 t $ \servers ->
|
||||
withAPNSMockServer $ \apns ->
|
||||
@@ -485,52 +480,6 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
|
||||
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
liftIO $ killThread threadId
|
||||
|
||||
testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
|
||||
testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
|
||||
b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
|
||||
conns <- runServers $ do
|
||||
conns <- forM [1 .. n :: Int] . const $ makeConnection a b
|
||||
_ <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
liftIO $ threadDelay 1500000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
void $ messageNotification apnsQ
|
||||
get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
ackMessage a bobId msgId
|
||||
pure conns
|
||||
|
||||
runRight_ @AgentErrorType $ do
|
||||
("", "", DOWN _ bcs1) <- nGet a
|
||||
("", "", DOWN _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", DOWN _ acs1) <- nGet b
|
||||
("", "", DOWN _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
|
||||
runServers $ do
|
||||
("", "", UP _ bcs1) <- nGet a
|
||||
("", "", UP _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", UP _ acs1) <- nGet b
|
||||
("", "", UP _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
liftIO $ threadDelay 1500000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
_ <- messageNotificationData a apnsQ
|
||||
get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
where
|
||||
runServers :: ExceptT AgentErrorType IO a -> IO a
|
||||
runServers a = do
|
||||
withSmpServerStoreLogOn t testPort $ \t1 -> do
|
||||
res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
|
||||
runRight a `finally` killThread t2
|
||||
killThread t1
|
||||
pure res
|
||||
|
||||
testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
|
||||
testSwitchNotifications servers APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' agentCfg servers testDB
|
||||
@@ -547,7 +496,7 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
|
||||
get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
|
||||
ackMessage a bId msgId
|
||||
testMessage "hello"
|
||||
_ <- switchConnectionAsync a "" bId
|
||||
switchConnectionAsync a "" bId
|
||||
switchComplete a bId b aId
|
||||
liftIO $ threadDelay 500000
|
||||
testMessage "hello again"
|
||||
|
||||
@@ -167,7 +167,6 @@ rcvQueue1 =
|
||||
dbQueueId = 1,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
rcvSwchStatus = Nothing,
|
||||
smpClientVersion = 1,
|
||||
clientNtfCreds = Nothing,
|
||||
deleteErrors = 0
|
||||
@@ -188,7 +187,6 @@ sndQueue1 =
|
||||
dbQueueId = 1,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
sndSwchStatus = Nothing,
|
||||
smpClientVersion = 1
|
||||
}
|
||||
|
||||
@@ -326,7 +324,6 @@ testUpgradeRcvConnToDuplex =
|
||||
e2eDhSecret = testDhSecret,
|
||||
status = New,
|
||||
dbQueueId = 1,
|
||||
sndSwchStatus = Nothing,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
smpClientVersion = 1
|
||||
@@ -355,7 +352,6 @@ testUpgradeSndConnToDuplex =
|
||||
sndId = "4567",
|
||||
status = New,
|
||||
dbQueueId = 1,
|
||||
rcvSwchStatus = Nothing,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
smpClientVersion = 1,
|
||||
@@ -432,8 +428,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
|
||||
msgFlags = SMP.noMsgFlags,
|
||||
msgBody = hw,
|
||||
internalHash,
|
||||
externalPrevSndHash = "hash_from_sender",
|
||||
encryptedMsgHash = "encrypted_msg_hash"
|
||||
externalPrevSndHash = "hash_from_sender"
|
||||
}
|
||||
|
||||
testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvQueue -> RcvMsgData -> Expectation
|
||||
|
||||
@@ -57,8 +57,6 @@ testSchemaMigrations = do
|
||||
schema'' <- getSchema testDB testSchema
|
||||
schema'' `shouldBe` schema
|
||||
withConnection st (`Migrations.run` MTRUp [m])
|
||||
schema''' <- getSchema testDB testSchema
|
||||
schema''' `shouldBe` schema'
|
||||
|
||||
getSchema :: FilePath -> FilePath -> IO String
|
||||
getSchema dpPath schemaPath = do
|
||||
|
||||
+1
-59
@@ -55,9 +55,7 @@ serverTests t@(ATransport t') = do
|
||||
describe "Exceeding queue quota" $ testExceedQueueQuota t'
|
||||
describe "Store log" $ testWithStoreLog t
|
||||
describe "Restore messages" $ testRestoreMessages t
|
||||
describe "Restore messages (old / v2)" $ do
|
||||
testRestoreMessagesV2 t
|
||||
testRestoreExpireMessages t
|
||||
describe "Restore messages (old / v2)" $ testRestoreMessagesV2 t
|
||||
describe "Timing of AUTH error" $ testTiming t
|
||||
describe "Message notifications" $ testMessageNotifications t
|
||||
describe "Message expiration" $ do
|
||||
@@ -781,62 +779,6 @@ testRestoreMessagesV2 at@(ATransport t) =
|
||||
runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
||||
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
||||
|
||||
testRestoreExpireMessages :: ATransport -> Spec
|
||||
testRestoreExpireMessages at@(ATransport t) =
|
||||
it "should store messages on exit and restore on start" $ do
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
recipientId <- newTVarIO ""
|
||||
recipientKey <- newTVarIO Nothing
|
||||
dhShared <- newTVarIO Nothing
|
||||
senderId <- newTVarIO ""
|
||||
|
||||
withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
|
||||
runClient t $ \h1 -> do
|
||||
(sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
|
||||
atomically $ do
|
||||
writeTVar recipientId rId
|
||||
writeTVar recipientKey $ Just rKey
|
||||
writeTVar dhShared $ Just dh
|
||||
writeTVar senderId sId
|
||||
sId <- readTVarIO senderId
|
||||
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello 1")
|
||||
Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
|
||||
threadDelay 3000000
|
||||
Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
|
||||
Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
|
||||
pure ()
|
||||
|
||||
logSize testStoreLogFile `shouldReturn` 2
|
||||
msgs <- B.readFile testStoreMsgsFile
|
||||
length (B.lines msgs) `shouldBe` 4
|
||||
|
||||
let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200}
|
||||
cfg1 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1}
|
||||
withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure ()
|
||||
|
||||
logSize testStoreLogFile `shouldReturn` 1
|
||||
msgs' <- B.readFile testStoreMsgsFile
|
||||
msgs' `shouldBe` msgs
|
||||
|
||||
let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200}
|
||||
cfg2 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2}
|
||||
withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure ()
|
||||
|
||||
logSize testStoreLogFile `shouldReturn` 1
|
||||
-- two messages expired
|
||||
msgs'' <- B.readFile testStoreMsgsFile
|
||||
length (B.lines msgs'') `shouldBe` 2
|
||||
B.lines msgs'' `shouldBe` drop 2 (B.lines msgs)
|
||||
|
||||
where
|
||||
runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
|
||||
runTest _ test' server = do
|
||||
testSMPClient test' `shouldReturn` ()
|
||||
killThread server
|
||||
|
||||
runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
||||
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
||||
|
||||
createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
|
||||
createAndSecureQueue h sPub = do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
|
||||
Reference in New Issue
Block a user