Merge branch 'master' into ep/test-coverage

* docker entrypoint: DRY store log backup

Don't Repeat Yourself

Set a variable for the full path to the source file.

Create the backup path by appending an extension from `date` output.

Also fixed quoting and switched to an `if` block.

Clean up block level variables.

* docker entrypoint: use ISO 8601 format

The previous format discards information about the local time zone.

* docker entrypoint: always use UTC

Now the format always ends in +00:00, and we can ignore that part again.

* docker entrypoint: provide the date format again

* docker entrypoint: remove time zone from the date format

* docker entrypoint: use an unambiguous date format

Present a leading zero before the month:
YYYY-0MM-DD

Both YYYY-MM-DD and YYYY-DD-MM are used by people and can be confusing in the beginning of the month.

* docker entrypoint: use appropriate quoting

Without avoiding field splitting a password containing a space changes the number of arguments being set.

* docker entrypoint: use explicit braces for custom variables

Make the intentions clear and don't assume the user knows the special cases for when variables won't be extended.

Example:
word=animal
words=mistake
echo "$words vs $word vs ${word}s"

* docker entrypoint-xftp-server: braces and quoting

* docker entrypoint-xftp-server: backup block

* docker entrypoints: explain date format in a comment

* switched from long to short option to date for POSIX

* docker entrypoint-smp-server: explain date format

* docker entrypoint-xftp-server: explain date format

* docker entrypoints: further explain format

I fixed the case to match the date format letters.

Also, use words to explain since I don't want everyone to need to read about date formats to understand.

* docker entrypoints: only quote letters

I was either going to quote the dashes too or stop quoting the colons.

Having less quotes was more readable.

* Revert "docker entrypoint: use an unambiguous date format"

This reverts commit ba2a93bad9.

* docker entrypoints: remove %F

* docker entrypoint-smp-server: remove %F

Used part of the explicit ISO 8601 format,
provided by the coreutils date invocation guide.

* docker entrypoint-xftp-server: remove %F

Used part of the explicit ISO 8601 format,
provided by the coreutils date invocation guide.

.github/CODEOWNERS

@@ -1 +1,4 @@
-* @epoberezkin @efim-poberezkin
+* @epoberezkin @spaced4ndy
+/Dockerfile @shumvgolove
+/scripts/docker/ @shumvgolove
+/scripts/main/ @shumvgolove

.github/workflows/build.yml

@@ -17,8 +17,10 @@ jobs:
       fail-fast: false
       matrix:
         include:
-          - os: ubuntu-18.04
           - os: ubuntu-20.04
+            platform_name: 20_04-x86-64
+          - os: ubuntu-22.04
+            platform_name: 22_04-x86-64
     steps:
       - name: Clone project
         uses: actions/checkout@v2
@@ -42,19 +44,18 @@ jobs:
         run: cabal build --enable-tests
 
       - name: Test
-        if: matrix.os == 'ubuntu-18.04'
         timeout-minutes: 30
         shell: bash
         run: cabal test --test-show-details=direct
 
       - name: Prepare binaries
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+        if: startsWith(github.ref, 'refs/tags/v')
         shell: bash
         run: |
-          mv $(cabal list-bin smp-server) smp-server-ubuntu-20_04-x86-64
-          mv $(cabal list-bin ntf-server) ntf-server-ubuntu-20_04-x86-64
-          mv $(cabal list-bin xftp-server) xftp-server-ubuntu-20_04-x86-64
-          mv $(cabal list-bin xftp) xftp-ubuntu-20_04-x86-64
+          mv $(cabal list-bin smp-server) smp-server-ubuntu-${{ matrix.platform_name}}
+          mv $(cabal list-bin ntf-server) ntf-server-ubuntu-${{ matrix.platform_name}}
+          mv $(cabal list-bin xftp-server) xftp-server-ubuntu-${{ matrix.platform_name}}
+          mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
 
       - name: Build changelog
         if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
@@ -80,10 +81,10 @@ jobs:
           prerelease: true
           files: |
             LICENSE
-            smp-server-ubuntu-20_04-x86-64
-            ntf-server-ubuntu-20_04-x86-64
-            xftp-server-ubuntu-20_04-x86-64
-            xftp-ubuntu-20_04-x86-64
+            smp-server-ubuntu-${{ matrix.platform_name}}
+            ntf-server-ubuntu-${{ matrix.platform_name}}
+            xftp-server-ubuntu-${{ matrix.platform_name}}
+            xftp-ubuntu-${{ matrix.platform_name}}
           fail_on_unmatched_files: true
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

.github/workflows/docker-image.yml

@@ -0,0 +1,50 @@
+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 }}

.gitignore

@@ -7,3 +7,7 @@ dist-newstyle/
 
 cabal.project.local
 cabal.project.local~
+
+.hpc/
+*.tix
+.coverage

CHANGELOG.md

@@ -1,3 +1,17 @@
+# 5.0.0
+
+SimpleX File Transfer Protocol (XFTP):
+- XFTP server
+- XFTP CLI
+- support XFTP in the agent
+
+Other changes:
+- preserve retry interval for sending messages on agent restarts
+- support IPv6 in the servers and in the agent
+- support for 32-bit platforms
+
+Read more about XFTP in this post: https://simplex.chat/blog/20230301-simplex-file-transfer-protocol.html
+
 # 4.4.1
 
 SMP agent:

Dockerfile

@@ -0,0 +1,62 @@
+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" ]

README.md

@@ -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 server on Linux
+## Deploy SMP/XFTP servers on Linux
 
-You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
+You can run your SMP/XFTP server as a Linux process, optionally using a service manager for booting and restarts.
 
-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:
+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:
 
 ```sh
 # For Ubuntu
@@ -105,28 +105,53 @@ apt update && apt install openssl
 
 #### Using Docker
 
-On Linux, you can deploy smp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat/simplexmq).
+On Linux, you can deploy smp and xftp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat).
 
-1. Create `config` and `logs` directories:
+1. Create directories for persistent Docker configuration:
 
    ```sh
-   mkdir -p ~/simplex/{config,logs}
+   mkdir -p $HOME/simplex/{xftp,smp}/{config,logs} && mkdir -p $HOME/simplex/xftp/files
    ```
 
-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/simplexmq
-   ```
+2. Run your Docker container.
 
-#### Ubuntu
+   - `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
+     ```
 
-For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
+   - `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 '1268d605e90bca1a8c7ef476038a8bd9aa9b1a28f79ea0a1485669ccf8fc23cd simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm /simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
+```
 
 ### Build from source
 
@@ -136,31 +161,50 @@ For Ubuntu you can download a binary from [the latest release](https://github.co
 
 On Linux, you can build smp server using Docker.
 
-1. Build your `smp-server` image:
+1. Build your images:
 
    ```sh
    git clone https://github.com/simplex-chat/simplexmq
    cd simplexmq
    git checkout stable
-   DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
+   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
    ```
 
-2. Create `config` and `logs` directories:
+2. Create directories for persistent Docker configuration:
 
    ```sh
-   mkdir -p ~/simplex/{config,logs}
+   mkdir -p $HOME/simplex/{xftp,smp}/{config,logs} && mkdir -p $HOME/simplex/xftp/files
    ```
 
-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
-   ```
+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
+     ```
 
 #### Using your distribution
 

apps/smp-agent/Main.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -10,17 +9,25 @@ import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Server (runSMPAgent)
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
 cfg = defaultAgentConfig
 
+agentDbFile :: String
+agentDbFile = "smp-agent.db"
+
+agentDbKey :: String
+agentDbKey = ""
+
 servers :: InitialAgentServers
 servers =
   InitialAgentServers
     { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])],
       ntf = [],
+      xftp = M.empty,
       netCfg = defaultNetworkConfig
     }
 
@@ -31,4 +38,5 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
+  Right st <- createAgentStore agentDbFile agentDbKey MCConsole
+  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers st

build.Dockerfile

@@ -1,51 +0,0 @@
-FROM ubuntu:focal AS final
-FROM ubuntu:focal 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
-
-# Install ghcup
-RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghcup && \
-    chmod +x /usr/bin/ghcup
-
-# Install ghc
-RUN ghcup install ghc 8.10.7
-# Install cabal
-RUN ghcup install cabal
-# Set both as default
-RUN ghcup set ghc 8.10.7 && \
-    ghcup set cabal
-
-COPY . /project
-WORKDIR /project
-
-# Adjust PATH
-ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
-
-# Compile smp-server
-RUN cabal update
-RUN cabal install
-
-### Final stage
-
-FROM final
-
-# Install OpenSSL dependency
-RUN apt-get update && apt-get install -y openssl
-
-# Copy compiled smp-server from build stage
-COPY --from=build /root/.cabal/bin/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" ]

cabal.project

@@ -1,6 +1,15 @@
 packages: .
 -- packages: . ../direct-sqlcipher ../sqlcipher-simple
 -- packages: . ../hs-socks
+-- packages: . ../http2
+
+package *
+  coverage: True
+  library-coverage: True
+
+package attoparsec
+  coverage: False
+  library-coverage: False
 
 source-repository-package
     type: git
@@ -15,7 +24,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: aa56ded3494dd4f0efb0bbcb5378879ce785a647
+    tag: b5a1b7200cf5bc7044af34ba325284271f6dff25
 
 source-repository-package
     type: git

download.Dockerfile

@@ -1,20 +0,0 @@
-FROM ubuntu:focal
-
-# Install curl
-RUN apt-get update && apt-get install -y curl
-
-# 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" ]

install.sh

@@ -0,0 +1,141 @@
+#!/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"
+
+# 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_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 update and uninstallation script:
+    - all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}
+
+Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
+
+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"
+ }
+
+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 update and uninstallation script..."
+ setup_scripts
+ printf "${GRN} Done!${NC}\n"
+
+ printf "%b" "$end"
+}
+
+main

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.0.0
+version: 5.1.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -42,9 +42,10 @@ dependencies:
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 4.0.*
+  - http2 == 4.1.*
   - generic-random >= 1.3 && < 1.5
   - ini == 0.4.1
+  - iproute == 1.7.*
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
@@ -135,6 +136,7 @@ tests:
     main: Test.hs
     dependencies:
       - simplexmq
+      - deepseq == 1.4.*
       - hspec == 2.7.*
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
@@ -142,6 +144,8 @@ tests:
       - silently == 1.2.*
       - main-tester == 0.2.*
       - timeit == 2.0.*
+    ghc-options:
+      - -fhpc
 
 ghc-options:
   # - -haddock

scripts/docker/entrypoint

@@ -1,29 +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]*) 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.bak
-# rotate server log
-[ -f "$logd/smp-server.log" ] && mv "$logd"/smp-server.log "$logd"/smp-server-"$(date +'%FT%T')".log
-
-# 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 > "$logd"/smp-server.log 2>&1

scripts/docker/entrypoint-smp-server

@@ -0,0 +1,48 @@
+#!/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
+

scripts/docker/entrypoint-xftp-server

@@ -0,0 +1,48 @@
+#!/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
+

scripts/main/simplex-servers-uninstall

@@ -0,0 +1,18 @@
+#!/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
+
+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"

scripts/main/simplex-servers-update

@@ -0,0 +1,160 @@
+#!/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"
+
+# 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_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_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"
+
+  if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null; then
+    printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n"
+    rm "$path_tmp_bin_uninstall"
+  else
+    printf -- "- Updating uninstall script..."
+    mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
+    printf "${GRN}Done!${NC}\n"
+  fi
+  if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null; then
+    printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
+    rm "$path_tmp_bin_update"
+  else
+    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; 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; 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"
+
+      print -- "- Updating smp-server bin to %s..." "$remote_version"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
+      printf "${GRN}Done!${NC}\n"
+      
+      printf -- "- Starting smp-server service..."
+      systemctl stop smp-server
+      printf "${GRN}Done!${NC}\n"
+    else
+      print -- "- Updating smp-server bin..."
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_smp" && chmod +x "$bin_path_smp"
+      printf "${GRN}Done!${NC}\n"
+    fi
+
+    if systemctl is-active --quiet xftp-server; then
+      printf -- "- Stopping xftp-server service..."
+      systemctl stop xftp-server
+      printf "${GRN}Done!${NC}\n"
+
+      print -- "- Updating xftp-server bin to %s..." "$remote_version"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
+      printf "${GRN}Done!${NC}\n"
+      
+      printf -- "- Starting xftp-server service..."
+      systemctl stop xftp-server
+      printf "${GRN}Done!${NC}\n"
+    else
+      print -- "- Updating xftp-server bin..."
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$bin_path_xftp" && chmod +x "$bin_path_xftp"
+      printf "${GRN}Done!${NC}\n"
+    fi
+  else
+    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
+}
+
+main "$@"

scripts/main/smp-server.service

@@ -0,0 +1,15 @@
+[Unit]
+Description=SMP server
+
+[Service]
+User=smp
+Group=smp
+Type=simple
+ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS 
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex/smp-server-store.log" ] && cp "/var/opt/simplex/smp-server-store.log" "/var/opt/simplex/smp-server-store.log.$(date +%FT%T)'
+LimitNOFILE=65535
+KillSignal=SIGINT
+TimeoutStopSec=infinity
+
+[Install]
+WantedBy=multi-user.target

scripts/main/xftp-server.service

@@ -0,0 +1,16 @@
+[Unit]
+Description=XFTP server
+
+[Service]
+User=xftp
+Group=xftp
+Type=simple
+ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
+ExecStopPost=/usr/bin/env sh -c '[ -e "/var/opt/simplex-xftp/file-server-store.log" ] && cp "/var/opt/simplex-xftp/file-server-store.log" "/var/opt/simplex-xftp/file-server-store.log.$(date +%FT%T)'
+LimitNOFILE=65535
+KillSignal=SIGINT
+TimeoutStopSec=infinity
+AmbientCapabilities=CAP_NET_BIND_SERVICE
+   
+[Install]
+WantedBy=multi-user.target

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.0.0
+version:        5.1.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -35,9 +35,12 @@ flag swift
 library
   exposed-modules:
       Simplex.FileTransfer
+      Simplex.FileTransfer.Agent
       Simplex.FileTransfer.Client
       Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
+      Simplex.FileTransfer.Client.Presets
+      Simplex.FileTransfer.Crypto
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
       Simplex.FileTransfer.Server
@@ -47,6 +50,8 @@ library
       Simplex.FileTransfer.Server.Store
       Simplex.FileTransfer.Server.StoreLog
       Simplex.FileTransfer.Transport
+      Simplex.FileTransfer.Types
+      Simplex.FileTransfer.Util
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
@@ -72,6 +77,11 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
+      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.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
@@ -145,8 +155,9 @@ library
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -208,8 +219,9 @@ executable ntf-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -224,6 +236,7 @@ executable ntf-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -271,8 +284,9 @@ executable smp-agent
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -287,6 +301,7 @@ executable smp-agent
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -334,8 +349,9 @@ executable smp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -350,6 +366,7 @@ executable smp-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -397,8 +414,9 @@ executable xftp
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -461,8 +479,9 @@ executable xftp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
@@ -477,6 +496,7 @@ executable xftp-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -502,6 +522,7 @@ test-suite simplexmq-test
       AgentTests.ConnectionRequestTests
       AgentTests.DoubleRatchetTests
       AgentTests.FunctionalAPITests
+      AgentTests.MigrationTests
       AgentTests.NotificationTests
       AgentTests.SchemaDump
       AgentTests.SQLiteTests
@@ -517,13 +538,14 @@ test-suite simplexmq-test
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPAgent
       XFTPCLI
       XFTPClient
       XFTPServerTests
       Paths_simplexmq
   hs-source-dirs:
       tests
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
+  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -fhpc
   build-depends:
       HUnit ==1.6.*
     , QuickCheck ==2.14.*
@@ -543,6 +565,7 @@ test-suite simplexmq-test
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -550,8 +573,9 @@ test-suite simplexmq-test
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
+    , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , main-tester ==0.2.*
     , memory ==0.15.*
@@ -568,6 +592,7 @@ test-suite simplexmq-test
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*

src/Simplex/FileTransfer/Agent.hs

@@ -0,0 +1,646 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.FileTransfer.Agent
+  ( startWorkers,
+    closeXFTPAgent,
+    toFSFilePath,
+    -- Receiving files
+    receiveFile,
+    deleteRcvFile,
+    -- Sending files
+    sendFileExperimental,
+    sendFile,
+    deleteSndFileInternal,
+    deleteSndFileRemote,
+  )
+where
+
+import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple (logError)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Crypto.Random (ChaChaDRG, randomBytesGenerate)
+import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Composition ((.:))
+import Data.Int (Int64)
+import Data.List (foldl', isSuffixOf, partition, sortOn)
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as L
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
+import Simplex.FileTransfer.Client.Main
+import Simplex.FileTransfer.Crypto
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI, SFileParty (..))
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types
+import Simplex.FileTransfer.Util (removePath, uniqueCombine)
+import Simplex.Messaging.Agent.Client
+import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (EntityId, XFTPServer, XFTPServerWithAuth)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (liftError, liftIOEither, tshow, unlessM, whenM)
+import System.FilePath (takeFileName, (</>))
+import UnliftIO
+import UnliftIO.Concurrent
+import UnliftIO.Directory
+import qualified UnliftIO.Exception as E
+
+startWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
+startWorkers c workDir = do
+  wd <- asks $ xftpWorkDir . xftpAgent
+  atomically $ writeTVar wd workDir
+  startRcvFiles
+  startSndFiles
+  startDelFiles
+  where
+    startRcvFiles = do
+      rcvFilesTTL <- asks $ rcvFilesTTL . config
+      pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
+      forM_ pendingRcvServers $ \s -> addXFTPRcvWorker c (Just s)
+      -- start local worker for files pending decryption,
+      -- no need to make an extra query for the check
+      -- as the worker will check the store anyway
+      addXFTPRcvWorker c Nothing
+    startSndFiles = do
+      sndFilesTTL <- asks $ sndFilesTTL . config
+      -- start worker for files pending encryption/creation
+      addXFTPSndWorker c Nothing
+      pendingSndServers <- withStore' c (`getPendingSndFilesServers` sndFilesTTL)
+      forM_ pendingSndServers $ \s -> addXFTPSndWorker c (Just s)
+    startDelFiles = do
+      rcvFilesTTL <- asks $ rcvFilesTTL . config
+      pendingDelServers <- withStore' c (`getPendingDelFilesServers` rcvFilesTTL)
+      forM_ pendingDelServers $ addXFTPDelWorker c
+
+closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
+closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
+  stopWorkers xftpRcvWorkers
+  stopWorkers xftpSndWorkers
+  where
+    stopWorkers wsSel = do
+      ws <- atomically $ stateTVar wsSel (,M.empty)
+      mapM_ (uninterruptibleCancel . snd) ws
+
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
+receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) = do
+  g <- asks idsDrg
+  prefixPath <- getPrefixPath "rcv.xftp"
+  createDirectory prefixPath
+  let relPrefixPath = takeFileName prefixPath
+      relTmpPath = relPrefixPath </> "xftp.encrypted"
+      relSavePath = relPrefixPath </> "xftp.decrypted"
+  createDirectory =<< toFSFilePath relTmpPath
+  createEmptyFile =<< toFSFilePath relSavePath
+  fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath relSavePath
+  forM_ chunks downloadChunk
+  pure fId
+  where
+    downloadChunk :: AgentMonad m => FileChunk -> m ()
+    downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
+      addXFTPRcvWorker c (Just server)
+    downloadChunk _ = throwError $ INTERNAL "no replicas"
+
+getPrefixPath :: AgentMonad m => String -> m FilePath
+getPrefixPath suffix = do
+  workPath <- getXFTPWorkPath
+  ts <- liftIO getCurrentTime
+  let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
+  uniqueCombine workPath (isoTime <> "_" <> suffix)
+
+toFSFilePath :: AgentMonad m => FilePath -> m FilePath
+toFSFilePath f = (</> f) <$> getXFTPWorkPath
+
+createEmptyFile :: AgentMonad m => FilePath -> m ()
+createEmptyFile fPath = do
+  h <- openFile fPath AppendMode
+  liftIO $ B.hPut h "" >> hFlush h
+
+addXFTPRcvWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPRcvWorker c = addWorker c xftpRcvWorkers runXFTPRcvWorker runXFTPRcvLocalWorker
+
+addWorker ::
+  AgentMonad m =>
+  AgentClient ->
+  (XFTPAgent -> TMap (Maybe XFTPServer) (TMVar (), Async ())) ->
+  (AgentClient -> XFTPServer -> TMVar () -> m ()) ->
+  (AgentClient -> TMVar () -> m ()) ->
+  Maybe XFTPServer ->
+  m ()
+addWorker c wsSel runWorker runWorkerNoSrv srv_ = do
+  ws <- asks $ wsSel . xftpAgent
+  atomically (TM.lookup srv_ ws) >>= \case
+    Nothing -> do
+      doWork <- newTMVarIO ()
+      let runWorker' = case srv_ of
+            Just srv -> runWorker c srv doWork
+            Nothing -> runWorkerNoSrv c doWork
+      worker <- async $ runWorker' `E.finally` atomically (TM.delete srv_ ws)
+      atomically $ TM.insert srv_ (doWork, worker) ws
+    Just (doWork, _) ->
+      void . atomically $ tryPutTMVar doWork ()
+
+runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPRcvWorker c srv doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    atomically $ assertAgentForeground c
+    runXFTPOperation
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextChunk <- withStore' c $ \db -> getNextRcvChunkToDownload db srv rcvFilesTTL
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
+        Just fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
+          ri <- asks $ reconnectInterval . config
+          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
+          withRetryInterval ri' $ \delay' loop ->
+            downloadFileChunk fc replica
+              `catchError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
+          where
+            retryLoop loop e replicaDelay = do
+              flip catchError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
+                when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
+                closeXFTPServerClient c userId server digest
+                withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
+              atomically $ assertAgentForeground c
+              loop
+            retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e)
+    downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> m ()
+    downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
+      fsFileTmpPath <- toFSFilePath fileTmpPath
+      chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo
+      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
+          relChunkPath = fileTmpPath </> takeFileName chunkPath
+      agentXFTPDownloadChunk c userId digest replica chunkSpec
+      (complete, progress) <- withStore c $ \db -> runExceptT $ do
+        liftIO $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId relChunkPath
+        RcvFile {size = FileSize total, chunks} <- ExceptT $ getRcvFile db rcvFileId
+        let rcvd = receivedSize chunks
+            complete = all chunkReceived chunks
+        liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
+        pure (complete, RFPROG rcvd total)
+      notify c rcvFileEntityId progress
+      when complete $ addXFTPRcvWorker c Nothing
+      where
+        receivedSize :: [RcvFileChunk] -> Int64
+        receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
+        receivedChunkSize ch@RcvFileChunk {chunkSize = s}
+          | chunkReceived ch = fromIntegral (unFileSize s)
+          | otherwise = 0
+        chunkReceived RcvFileChunk {replicas} = any received replicas
+
+retryOnError :: AgentMonad m => Text -> m a -> m a -> AgentErrorType -> m a
+retryOnError name loop done e = do
+  logError $ name <> " error: " <> tshow e
+  if temporaryAgentError e
+    then loop
+    else done
+
+rcvWorkerInternalError :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m ()
+rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
+  forM_ tmpPath (removePath <=< toFSFilePath)
+  withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
+  notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
+
+runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPRcvLocalWorker c doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    atomically $ assertAgentForeground c
+    runXFTPOperation
+  where
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextFile <- withStore' c (`getNextRcvFileToDecrypt` rcvFilesTTL)
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
+          decryptFile f `catchError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    decryptFile :: RcvFile -> m ()
+    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
+      fsSavePath <- toFSFilePath savePath
+      when (status == RFSDecrypting) $
+        whenM (doesFileExist fsSavePath) (removeFile fsSavePath >> createEmptyFile fsSavePath)
+      withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
+      chunkPaths <- getChunkPaths chunks
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure fsSavePath
+      notify c rcvFileEntityId $ RFDONE fsSavePath
+      forM_ tmpPath (removePath <=< toFSFilePath)
+      withStore' c (`updateRcvFileComplete` rcvFileId)
+      where
+        getChunkPaths :: [RcvFileChunk] -> m [FilePath]
+        getChunkPaths [] = pure []
+        getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do
+          ps <- getChunkPaths cs
+          fsPath <- toFSFilePath path
+          pure $ fsPath : ps
+        getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
+          throwError $ INTERNAL "no chunk path"
+
+deleteRcvFile :: AgentMonad m => AgentClient -> RcvFileId -> m ()
+deleteRcvFile c rcvFileEntityId = do
+  RcvFile {rcvFileId, prefixPath, status} <- withStore c $ \db -> getRcvFileByEntityId db rcvFileEntityId
+  if status == RFSComplete || status == RFSError
+    then do
+      removePath prefixPath
+      withStore' c (`deleteRcvFile'` rcvFileId)
+    else withStore' c (`updateRcvFileDeleted` rcvFileId)
+
+sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
+sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients = do
+  g <- asks idsDrg
+  sndFileId <- liftIO $ randomId g 12
+  xftpSrvs <- atomically $ TM.lookup userId xftpServers
+  void $ forkIO $ sendCLI sndFileId $ maybe [] L.toList xftpSrvs
+  pure sndFileId
+  where
+    randomId :: TVar ChaChaDRG -> Int -> IO ByteString
+    randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
+    sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m ()
+    sendCLI sndFileId xftpSrvs = do
+      let fileName = takeFileName filePath
+      workPath <- getXFTPWorkPath
+      outputDir <- uniqueCombine workPath $ fileName <> ".descr"
+      createDirectory outputDir
+      let tempPath = workPath </> "snd"
+      createDirectoryIfMissing False tempPath
+      runSend fileName outputDir tempPath `catchError` \e -> do
+        cleanup outputDir tempPath
+        notify c sndFileId $ SFERR e
+      where
+        runSend :: String -> FilePath -> FilePath -> m ()
+        runSend fileName outputDir tempPath = do
+          let sendOptions =
+                SendOptions
+                  { filePath,
+                    outputDir = Just outputDir,
+                    numRecipients,
+                    xftpServers = xftpSrvs,
+                    retryCount = 3,
+                    tempPath = Just tempPath,
+                    verbose = False
+                  }
+          liftCLI $ cliSendFileOpts sendOptions False $ notify c sndFileId .: SFPROG
+          (sndDescr, rcvDescrs) <- readDescrs outputDir fileName
+          cleanup outputDir tempPath
+          notify c sndFileId $ SFDONE sndDescr rcvDescrs
+        cleanup :: FilePath -> FilePath -> m ()
+        cleanup outputDir tempPath = do
+          removePath tempPath
+          removePath outputDir
+    liftCLI :: ExceptT CLIError IO () -> m ()
+    liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT
+    readDescrs :: FilePath -> FilePath -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
+    readDescrs outDir fileName = do
+      let descrDir = outDir </> (fileName <> ".xftp")
+      files <- listDirectory descrDir
+      let (sdFiles, rdFiles) = partition ("snd.xftp.private" `isSuffixOf`) files
+          sdFile = maybe "" (\l -> descrDir </> L.head l) (nonEmpty sdFiles)
+          rdFiles' = map (descrDir </>) rdFiles
+      (,) <$> readDescr sdFile <*> mapM readDescr rdFiles'
+    readDescr :: FilePartyI p => FilePath -> m (ValidFileDescription p)
+    readDescr f = liftIOEither $ first INTERNAL . strDecode <$> B.readFile f
+
+notify :: forall m e. (MonadUnliftIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
+notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
+
+sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
+sendFile c userId filePath numRecipients = do
+  g <- asks idsDrg
+  prefixPath <- getPrefixPath "snd.xftp"
+  createDirectory prefixPath
+  let relPrefixPath = takeFileName prefixPath
+  key <- liftIO C.randomSbKey
+  nonce <- liftIO C.randomCbNonce
+  -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
+  fId <- withStore c $ \db -> createSndFile db g userId numRecipients filePath relPrefixPath key nonce
+  addXFTPSndWorker c Nothing
+  pure fId
+
+addXFTPSndWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPSndWorker c = addWorker c xftpSndWorkers runXFTPSndWorker runXFTPSndPrepareWorker
+
+runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPSndPrepareWorker c doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    atomically $ assertAgentForeground c
+    runXFTPOperation
+  where
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextFile <- withStore' c (`getNextSndFileToPrepare` sndFilesTTL)
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
+          prepareFile f `catchError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    prepareFile :: SndFile -> m ()
+    prepareFile SndFile {prefixPath = Nothing} =
+      throwError $ INTERNAL "no prefix path"
+    prepareFile sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
+      SndFile {numRecipients, chunks} <-
+        if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
+          then do
+            fsEncPath <- toFSFilePath $ sndFileEncPath ppath
+            when (status == SFSEncrypting) $
+              whenM (doesFileExist fsEncPath) $ removeFile fsEncPath
+            withStore' c $ \db -> updateSndFileStatus db sndFileId SFSEncrypting
+            (digest, chunkSpecsDigests) <- encryptFileForUpload sndFile fsEncPath
+            withStore c $ \db -> do
+              updateSndFileEncrypted db sndFileId digest chunkSpecsDigests
+              getSndFile db sndFileId
+          else pure sndFile
+      maxRecipients <- asks (xftpMaxRecipientsPerRequest . config)
+      let numRecipients' = min numRecipients maxRecipients
+      -- concurrently?
+      forM_ (filter (not . chunkCreated) chunks) $ createChunk numRecipients'
+      withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
+      where
+        encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
+        encryptFileForUpload SndFile {key, nonce, filePath} fsEncPath = do
+          let fileName = takeFileName filePath
+          fileSize <- fromInteger <$> getFileSize filePath
+          when (fileSize > maxFileSize) $ throwError $ INTERNAL "max file size exceeded"
+          let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
+              fileSize' = fromIntegral (B.length fileHdr) + fileSize
+              chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
+              chunkSizes' = map fromIntegral chunkSizes
+              encSize = sum chunkSizes'
+          void $ liftError (INTERNAL . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize fsEncPath
+          digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath
+          let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
+          chunkDigests <- map FileDigest <$> mapM (liftIO . getChunkDigest) chunkSpecs
+          pure (FileDigest digest, zip chunkSpecs chunkDigests)
+        chunkCreated :: SndFileChunk -> Bool
+        chunkCreated SndFileChunk {replicas} =
+          any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSCreated) replicas
+        createChunk :: Int -> SndFileChunk -> m ()
+        createChunk numRecipients' ch = do
+          atomically $ assertAgentForeground c
+          (replica, ProtoServerWithAuth srv _) <- tryCreate
+          withStore' c $ \db -> createSndFileReplica db ch replica
+          addXFTPSndWorker c $ Just srv
+          where
+            tryCreate = do
+              ri <- asks $ messageRetryInterval . config
+              usedSrvs <- newTVarIO ([] :: [XFTPServer])
+              withRetryInterval (riFast ri) $ \_ loop ->
+                createWithNextSrv usedSrvs
+                  `catchError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
+              where
+                retryLoop loop = atomically (assertAgentForeground c) >> loop
+            createWithNextSrv usedSrvs = do
+              deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
+              when deleted $ throwError $ INTERNAL "file deleted, aborting chunk creation"
+              withNextSrv c userId usedSrvs [] $ \srvAuth -> do
+                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
+                pure (replica, srvAuth)
+
+sndWorkerInternalError :: AgentMonad m => AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> m ()
+sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do
+  forM_ prefixPath $ removePath <=< toFSFilePath
+  withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
+  notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
+
+runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPSndWorker c srv doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    atomically $ assertAgentForeground c
+    runXFTPOperation
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextChunk <- withStore' c $ \db -> getNextSndChunkToUpload db srv sndFilesTTL
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
+        Just fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
+          ri <- asks $ reconnectInterval . config
+          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
+          withRetryInterval ri' $ \delay' loop ->
+            uploadFileChunk fc replica
+              `catchError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
+          where
+            retryLoop loop e replicaDelay = do
+              flip catchError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
+                when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
+                closeXFTPServerClient c userId server digest
+                withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
+              atomically $ assertAgentForeground c
+              loop
+            retryDone 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
+      fsFilePath <- toFSFilePath filePath
+      unlessM (doesFileExist fsFilePath) $ throwError $ INTERNAL "encrypted file doesn't exist on upload"
+      let chunkSpec' = chunkSpec {filePath = fsFilePath} :: XFTPChunkSpec
+      atomically $ assertAgentForeground c
+      agentXFTPUploadChunk c userId chunkDigest replica' chunkSpec'
+      sf@SndFile {sndFileEntityId, prefixPath, chunks} <- withStore c $ \db -> do
+        updateSndChunkReplicaStatus db sndChunkReplicaId SFRSUploaded
+        getSndFile db sndFileId
+      let uploaded = uploadedSize chunks
+          total = totalSize chunks
+          complete = all chunkUploaded chunks
+      notify c sndFileEntityId $ SFPROG uploaded total
+      when complete $ do
+        (sndDescr, rcvDescrs) <- sndFileToDescrs sf
+        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
+        forM_ prefixPath $ removePath <=< toFSFilePath
+        withStore' c $ \db -> updateSndFileComplete db sndFileId
+      where
+        addRecipients :: SndFileChunk -> SndFileChunkReplica -> m SndFileChunkReplica
+        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
+          | length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
+          | length rcvIdsKeys == numRecipients = pure cr
+          | otherwise = do
+            maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
+            let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
+            rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
+            cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
+            addRecipients ch cr'
+        sndFileToDescrs :: SndFile -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
+        sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
+        sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
+        sndFileToDescrs SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _)} = do
+          let chunkSize = FileSize $ sndChunkSize fstChunk
+              size = FileSize $ sum $ map (fromIntegral . sndChunkSize) chunks
+          -- snd description
+          sndDescrChunks <- mapM toSndDescrChunk chunks
+          let fdSnd = FileDescription {party = SFSender, size, digest, key, nonce, chunkSize, chunks = sndDescrChunks}
+          validFdSnd <- either (throwError . INTERNAL) pure $ validateFileDescription fdSnd
+          -- rcv descriptions
+          let fdRcv = FileDescription {party = SFRecipient, size, digest, key, nonce, chunkSize, chunks = []}
+              fdRcvs = createRcvFileDescriptions fdRcv chunks
+          validFdRcvs <- either (throwError . INTERNAL) pure $ mapM validateFileDescription fdRcvs
+          pure (validFdSnd, validFdRcvs)
+        toSndDescrChunk :: SndFileChunk -> m FileChunk
+        toSndDescrChunk SndFileChunk {replicas = []} = throwError $ INTERNAL "snd file chunk has no replicas"
+        toSndDescrChunk ch@SndFileChunk {chunkNo, digest = chDigest, replicas = (SndFileChunkReplica {server, replicaId, replicaKey} : _)} = do
+          let chunkSize = FileSize $ sndChunkSize ch
+              replicas = [FileChunkReplica {server, replicaId, replicaKey}]
+          pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
+        createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient]
+        createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
+          where
+            rcvReplicas :: [SentRecipientReplica]
+            rcvReplicas = concatMap toSentRecipientReplicas sndChunks
+            toSentRecipientReplicas :: SndFileChunk -> [SentRecipientReplica]
+            toSentRecipientReplicas ch@SndFileChunk {chunkNo, digest, replicas} =
+              let chunkSize = FileSize $ sndChunkSize ch
+               in concatMap
+                    ( \SndFileChunkReplica {server, rcvIdsKeys} ->
+                        zipWith
+                          (\rcvNo (replicaId, replicaKey) -> SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize})
+                          [1 ..]
+                          rcvIdsKeys
+                    )
+                    replicas
+            rcvChunks :: [[FileChunk]]
+            rcvChunks = map (sortChunks . M.elems) $ M.elems $ foldl' addRcvChunk M.empty rcvReplicas
+            sortChunks :: [FileChunk] -> [FileChunk]
+            sortChunks = map reverseReplicas . sortOn (chunkNo :: FileChunk -> Int)
+            reverseReplicas ch@FileChunk {replicas} = (ch :: FileChunk) {replicas = reverse replicas}
+            addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk)
+            addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize} =
+              M.alter (Just . addOrChangeRecipient) rcvNo m
+              where
+                addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk
+                addOrChangeRecipient = \case
+                  Just m' -> M.alter (Just . addOrChangeChunk) chunkNo m'
+                  _ -> M.singleton chunkNo $ FileChunk {chunkNo, digest, chunkSize, replicas = [replica']}
+                addOrChangeChunk :: Maybe FileChunk -> FileChunk
+                addOrChangeChunk = \case
+                  Just ch@FileChunk {replicas} -> ch {replicas = replica' : replicas}
+                  _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica']}
+                replica' = FileChunkReplica {server, replicaId, replicaKey}
+        uploadedSize :: [SndFileChunk] -> Int64
+        uploadedSize = foldl' (\sz ch -> sz + uploadedChunkSize ch) 0
+        uploadedChunkSize ch
+          | chunkUploaded ch = fromIntegral (sndChunkSize ch)
+          | otherwise = 0
+        totalSize :: [SndFileChunk] -> Int64
+        totalSize = foldl' (\sz ch -> sz + fromIntegral (sndChunkSize ch)) 0
+        chunkUploaded :: SndFileChunk -> Bool
+        chunkUploaded SndFileChunk {replicas} =
+          any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSUploaded) replicas
+
+deleteSndFileInternal :: AgentMonad m => AgentClient -> SndFileId -> m ()
+deleteSndFileInternal c sndFileEntityId = do
+  SndFile {sndFileId, prefixPath, status} <- withStore c $ \db -> getSndFileByEntityId db sndFileEntityId
+  if status == SFSComplete || status == SFSError
+    then do
+      forM_ prefixPath $ removePath <=< toFSFilePath
+      withStore' c (`deleteSndFile'` sndFileId)
+    else withStore' c (`updateSndFileDeleted` sndFileId)
+
+deleteSndFileRemote :: forall m. AgentMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
+deleteSndFileRemote c userId sndFileEntityId (ValidFileDescription FileDescription {chunks}) = do
+  deleteSndFileInternal c sndFileEntityId `catchError` (notify c sndFileEntityId . SFERR)
+  forM_ chunks $ \ch -> deleteFileChunk ch `catchError` (notify c sndFileEntityId . SFERR)
+  where
+    deleteFileChunk :: FileChunk -> m ()
+    deleteFileChunk FileChunk {digest, replicas = replica@FileChunkReplica {server} : _} = do
+      withStore' c $ \db -> createDeletedSndChunkReplica db userId replica digest
+      addXFTPDelWorker c server
+    deleteFileChunk _ = pure ()
+
+addXFTPDelWorker :: AgentMonad m => AgentClient -> XFTPServer -> m ()
+addXFTPDelWorker c srv = do
+  ws <- asks $ xftpDelWorkers . xftpAgent
+  atomically (TM.lookup srv ws) >>= \case
+    Nothing -> do
+      doWork <- newTMVarIO ()
+      worker <- async $ runXFTPDelWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
+      atomically $ TM.insert srv (doWork, worker) ws
+    Just (doWork, _) ->
+      void . atomically $ tryPutTMVar doWork ()
+
+runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPDelWorker c srv doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    atomically $ assertAgentForeground c
+    runXFTPOperation
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      -- no point in deleting files older than rcv ttl, as they will be expired on server
+      rcvFilesTTL <- asks (rcvFilesTTL . config)
+      nextReplica <- withStore' c $ \db -> getNextDeletedSndChunkReplica db srv rcvFilesTTL
+      case nextReplica of
+        Nothing -> noWorkToDo
+        Just replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} -> do
+          ri <- asks $ reconnectInterval . config
+          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
+          withRetryInterval ri' $ \delay' loop ->
+            deleteChunkReplica replica
+              `catchError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
+          where
+            retryLoop loop e replicaDelay = do
+              flip catchError (\_ -> pure ()) $ do
+                notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
+                when notifyOnRetry $ notify c "" $ SFERR e
+                closeXFTPServerClient c userId server chunkDigest
+                withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
+              atomically $ assertAgentForeground c
+              loop
+            retryDone e = delWorkerInternalError c deletedSndChunkReplicaId e
+    deleteChunkReplica :: DeletedSndChunkReplica -> m ()
+    deleteChunkReplica replica@DeletedSndChunkReplica {userId, deletedSndChunkReplicaId} = do
+      agentXFTPDeleteChunk c userId replica
+      withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
+
+delWorkerInternalError :: AgentMonad m => AgentClient -> Int64 -> AgentErrorType -> m ()
+delWorkerInternalError c deletedSndChunkReplicaId e = do
+  withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
+  notify c "" $ SFERR e
+
+assertAgentForeground :: AgentClient -> STM ()
+assertAgentForeground c = do
+  throwWhenInactive c
+  waitUntilForeground c

src/Simplex/FileTransfer/Client.hs

@@ -16,6 +16,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Time (UTCTime)
 import Data.Word (Word32)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
@@ -31,8 +32,10 @@ import Simplex.Messaging.Client
     proxyUsername,
     transportClientConfig,
   )
+import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( BasicAuth,
     Protocol (..),
@@ -41,21 +44,22 @@ import Simplex.Messaging.Protocol
     SenderId,
   )
 import Simplex.Messaging.Transport (supportedParameters)
-import Simplex.Messaging.Transport.Client (TransportClientConfig)
+import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Util (bshow, liftEitherError, whenM)
+import UnliftIO
 import UnliftIO.Directory
-import UnliftIO.IO
 
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
+    transportSession :: TransportSession FileResponse,
     config :: XFTPClientConfig
   }
 
 data XFTPClientConfig = XFTPClientConfig
-  { networkConfig :: NetworkConfig,
-    uploadTimeoutPerMb :: Int
+  { xftpNetworkConfig :: NetworkConfig,
+    uploadTimeoutPerMb :: Int64
   }
 
 data XFTPChunkBody = XFTPChunkBody
@@ -69,30 +73,48 @@ data XFTPChunkSpec = XFTPChunkSpec
     chunkOffset :: Int64,
     chunkSize :: Word32
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 type XFTPClientError = ProtocolClientError XFTPErrorType
 
 defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig =
   XFTPClientConfig
-    { networkConfig = defaultNetworkConfig,
+    { xftpNetworkConfig = defaultNetworkConfig,
       uploadTimeoutPerMb = 10000000 -- 10 seconds
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do
-  let tcConfig = transportClientConfig networkConfig
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do
+  let tcConfig = transportClientConfig xftpNetworkConfig
       http2Config = xftpHTTP2Config tcConfig config
       username = proxyUsername transportSession
       ProtocolServer _ host port keyHash = srv
-  useHost <- liftEither $ chooseTransportHost networkConfig host
+  useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
+  clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
-  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config disconnected
-  pure XFTPClient {http2Client, config}
+      clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
+  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
+  let c = XFTPClient {http2Client, transportSession, config}
+  atomically $ writeTVar clientVar $ Just c
+  pure c
+
+closeXFTPClient :: XFTPClient -> IO ()
+closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client
+
+xftpClientServer :: XFTPClient -> String
+xftpClientServer = B.unpack . strEncode . snd3 . transportSession
+  where
+    snd3 (_, s, _) = s
+
+xftpTransportHost :: XFTPClient -> TransportHost
+xftpTransportHost = (host :: HClient -> TransportHost) . client_ . http2Client
+
+xftpSessionTs :: XFTPClient -> UTCTime
+xftpSessionTs = sessionTs . http2Client
 
 xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
-xftpHTTP2Config transportConfig XFTPClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} =
+xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = supportedParameters,
@@ -112,7 +134,7 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
     liftEither . first PCETransportError $
       xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
   let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
-      reqTimeout = (\XFTPChunkSpec {chunkSize} -> (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1) <$> chunkSpec_
+      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?
@@ -139,31 +161,43 @@ createXFTPChunk ::
   NonEmpty C.APublicVerifyKey ->
   Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunk c spKey file rsps auth_ =
-  sendXFTPCommand c spKey "" (FNEW file rsps auth_) Nothing >>= \case
+createXFTPChunk c spKey file rcps auth_ =
+  sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case
     (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
+addXFTPRecipients :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> NonEmpty C.APublicVerifyKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
+addXFTPRecipients c spKey fId rcps =
+  sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case
+    (FRRcvIds rIds, body) -> noFile body rIds
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
 uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
 uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
 downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
-downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
+downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
   (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
   sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
-    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of
       -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
       Just chunkPart -> do
         let dhSecret = C.dh' sDhKey rpDhKey
         cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
-        -- timeout download in the same way as upload
-        withExceptT PCEResponseError $
-          receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
-            whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
+        let t = chunkTimeout config chunkSize
+        t `timeout` download cbState >>= maybe (throwError PCEResponseTimeout) pure
+        where
+          download cbState =
+            withExceptT PCEResponseError $
+              receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
+                whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
+chunkTimeout :: XFTPClientConfig -> Word32 -> Int
+chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
+
 deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
 
@@ -181,7 +215,5 @@ noFile HTTP2Body {bodyPart} a = case bodyPart of
   Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE
   _ -> pure a
 
--- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
--- FDEL :: FileCommand Sender
 -- FACK :: FileCommand Recipient
 -- PING :: FileCommand Recipient

src/Simplex/FileTransfer/Client/Agent.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -20,7 +21,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tryError)
+import Simplex.Messaging.Util (catchAll_, tryError)
 import UnliftIO
 
 type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
@@ -67,8 +68,8 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
         first (XFTPClientAgentError srv)
           <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected _ = do
       atomically $ TM.delete srv xftpClients
       logInfo $ "disconnected from " <> showServer srv
 
@@ -83,7 +84,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
 
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
-      let XFTPClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
+      let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
       client_ <- tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
       liftEither $ case client_ of
         Just (Right c) -> Right c
@@ -109,8 +110,18 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
               throwError e
         tryConnectAsync :: ME ()
         tryConnectAsync = void . async $ do
-          withRetryInterval (reconnectInterval config) $ void . tryConnectClient
+          withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop
 
 showServer :: XFTPServer -> Text
 showServer ProtocolServer {host, port} =
   decodeUtf8 $ strEncode host <> B.pack (if null port then "" else ':' : port)
+
+closeXFTPServerClient :: XFTPClientAgent -> XFTPServer -> IO ()
+closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
+  atomically (TM.lookupDelete srv xftpClients) >>= mapM_ closeClient
+  where
+    closeClient cVar = do
+      let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+        Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
+        _ -> pure ()

src/Simplex/FileTransfer/Client/Main.hs

@@ -1,19 +1,34 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Client.Main
-  ( xftpClientCLI,
+  ( SendOptions (..),
+    CLIError (..),
+    xftpClientCLI,
+    cliSendFile,
+    cliSendFileOpts,
     prepareChunkSizes,
+    prepareChunkSpecs,
+    chunkSize1,
+    chunkSize2,
+    chunkSize3,
+    maxFileSize,
+    fileSizeLen,
+    getChunkDigest,
+    SentRecipientReplica (..),
   )
 where
 
 import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
@@ -22,6 +37,7 @@ import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Char (toLower)
 import Data.Function (on)
 import Data.Int (Int64)
 import Data.List (foldl', groupBy, sortOn)
@@ -30,23 +46,29 @@ import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
 import Data.Word (Word32)
+import GHC.Records (HasField (getField))
 import Options.Applicative
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
+import Simplex.FileTransfer.Client.Presets
+import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types
+import Simplex.FileTransfer.Util (uniqueCombine)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth)
 import Simplex.Messaging.Server.CLI (getCliCommand')
-import Simplex.Messaging.Util (ifM, whenM)
+import Simplex.Messaging.Util (ifM, tshow, whenM)
 import System.Exit (exitFailure)
-import System.FilePath (splitExtensions, splitFileName, (</>))
+import System.FilePath (splitFileName, (</>))
 import System.IO.Temp (getCanonicalTemporaryDirectory)
 import System.Random (StdGen, newStdGen, randomR)
 import UnliftIO
@@ -64,15 +86,25 @@ chunkSize2 = mb 1
 chunkSize3 :: Word32
 chunkSize3 = mb 4
 
+maxFileSize :: Int64
+maxFileSize = gb 1
+
+maxFileSizeStr :: String
+maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
+
 fileSizeLen :: Int64
 fileSizeLen = 8
 
-authTagSize :: Int64
-authTagSize = fromIntegral C.authTagSize
-
 newtype CLIError = CLIError String
   deriving (Eq, Show, Exception)
 
+cliCryptoError :: FTCryptoError -> CLIError
+cliCryptoError = \case
+  FTCECryptoError e -> CLIError $ "Error decrypting file: " <> show e
+  FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e
+  FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag"
+  FTCEFileIOError e -> CLIError $ "File IO error: " <> show e
+
 data CliCommand
   = SendFile SendOptions
   | ReceiveFile ReceiveOptions
@@ -86,7 +118,8 @@ data SendOptions = SendOptions
     numRecipients :: Int,
     xftpServers :: [XFTPServerWithAuth],
     retryCount :: Int,
-    tempPath :: Maybe FilePath
+    tempPath :: Maybe FilePath,
+    verbose :: Bool
   }
   deriving (Show)
 
@@ -94,13 +127,17 @@ data ReceiveOptions = ReceiveOptions
   { fileDescription :: FilePath,
     filePath :: Maybe FilePath,
     retryCount :: Int,
-    tempPath :: Maybe FilePath
+    tempPath :: Maybe FilePath,
+    verbose :: Bool,
+    yes :: Bool
   }
   deriving (Show)
 
 data DeleteOptions = DeleteOptions
   { fileDescription :: FilePath,
-    retryCount :: Int
+    retryCount :: Int,
+    verbose :: Bool,
+    yes :: Bool
   }
   deriving (Show)
 
@@ -111,24 +148,13 @@ newtype InfoOptions = InfoOptions
 
 data RandomFileOptions = RandomFileOptions
   { filePath :: FilePath,
-    fileSize :: FileSize Int
+    fileSize :: FileSize Int64
   }
   deriving (Show)
 
 defaultRetryCount :: Int
 defaultRetryCount = 3
 
-defaultXFTPServers :: NonEmpty XFTPServerWithAuth
-defaultXFTPServers =
-  L.fromList
-    [ "xftp://da1aH3nOT-9G8lV7bWamhxpDYdJ1xmW7j3JpGaDR5Ug=@xftp1.simplex.im",
-      "xftp://5vog2Imy1ExJB_7zDZrkV1KDWi96jYFyy9CL6fndBVw=@xftp2.simplex.im",
-      "xftp://PYa32DdYNFWi0uZZOprWQoQpIk5qyjRJ3EF7bVpbsn8=@xftp3.simplex.im",
-      "xftp://k_GgQl40UZVV0Y4BX9ZTyMVqX5ZewcLW0waQIl7AYDE=@xftp4.simplex.im",
-      "xftp://-bIo6o8wuVc4wpZkZD3tH-rCeYaeER_0lz1ffQcSJDs=@xftp5.simplex.im",
-      "xftp://6nSvtY9pJn6PXWTAIMNl95E1Kk1vD7FM2TeOA64CFLg=@xftp6.simplex.im"
-    ]
-
 cliCommandP :: Parser CliCommand
 cliCommandP =
   hsubparser
@@ -148,6 +174,7 @@ cliCommandP =
         <*> xftpServers
         <*> retryCountP
         <*> temp
+        <*> verboseP
     receiveP :: Parser ReceiveOptions
     receiveP =
       ReceiveOptions
@@ -155,11 +182,15 @@ cliCommandP =
         <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
         <*> retryCountP
         <*> temp
+        <*> verboseP
+        <*> yesP
     deleteP :: Parser DeleteOptions
     deleteP =
       DeleteOptions
         <$> fileDescrArg
         <*> retryCountP
+        <*> verboseP
+        <*> yesP
     infoP :: Parser InfoOptions
     infoP = InfoOptions <$> fileDescrArg
     randomP :: Parser RandomFileOptions
@@ -170,6 +201,8 @@ cliCommandP =
     fileDescrArg = argument str (metavar "FILE" <> help "File description file")
     retryCountP = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
     temp = optional (strOption $ long "tmp" <> metavar "TMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
+    verboseP = switch (long "verbose" <> short 'v' <> help "Verbose output")
+    yesP = switch (long "yes" <> short 'y' <> help "Yes to questions")
     xftpServers =
       option
         parseXFTPServers
@@ -208,41 +241,40 @@ data SentRecipientReplica = SentRecipientReplica
     chunkSize :: FileSize Word32
   }
 
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
 xftpClientCLI :: IO ()
 xftpClientCLI =
   getCliCommand' cliCommandP clientVersion >>= \case
-    SendFile opts -> runE $ cliSendFile opts
-    ReceiveFile opts -> runE $ cliReceiveFile opts
-    DeleteFile opts -> runE $ cliDeleteFile opts
+    SendFile opts -> runLogE opts $ cliSendFile opts
+    ReceiveFile opts -> runLogE opts $ cliReceiveFile opts
+    DeleteFile opts -> runLogE opts $ cliDeleteFile opts
     FileDescrInfo opts -> runE $ cliFileDescrInfo opts
     RandomFile opts -> cliRandomFile opts
   where
     clientVersion = "SimpleX XFTP client v" <> xftpClientVersion
 
+runLogE :: HasField "verbose" a Bool => a -> ExceptT CLIError IO () -> IO ()
+runLogE opts a
+  | getField @"verbose" opts = setLogLevel LogDebug >> withGlobalLogging logCfg (runE a)
+  | otherwise = runE a
+
 runE :: ExceptT CLIError IO () -> IO ()
 runE a =
   runExceptT a >>= \case
     Left (CLIError e) -> putStrLn e >> exitFailure
     _ -> pure ()
 
--- fileExtra is added to allow header extension in future versions
-data FileHeader = FileHeader
-  { fileName :: String,
-    fileExtra :: Maybe String
-  }
-  deriving (Eq, Show)
-
-instance Encoding FileHeader where
-  smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra)
-  smpP = do
-    (fileName, fileExtra) <- smpP
-    pure FileHeader {fileName, fileExtra}
-
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
-cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
+cliSendFile opts = cliSendFileOpts opts True $ printProgress "Uploaded"
+
+cliSendFileOpts :: SendOptions -> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
+cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} printInfo notifyProgress = do
   let (_, fileName) = splitFileName filePath
-  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFile fileName
-  liftIO $ printNoNewLine "Uploading file..."
+  liftIO $ when printInfo $ printNoNewLine "Encrypting file..."
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName
+  liftIO $ when printInfo $ printNoNewLine "Uploading file..."
   uploadedChunks <- newTVarIO []
   sentChunks <- uploadFile chunkSpecs uploadedChunks encSize
   whenM (doesFileExist encPath) $ removeFile encPath
@@ -251,37 +283,32 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     let fdRcvs = createRcvFileDescriptions fdRcv sentChunks
         fdSnd' = createSndFileDescription fdSnd sentChunks
     (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
-    printNoNewLine "File uploaded!"
-    putStrLn "\nPass file descriptions to the recipient(s):"
+    when printInfo $ do
+      printNoNewLine "File uploaded!"
+      putStrLn $ "\nSender file description: " <> fdSndPath
+      putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
-    putStrLn "Sender file description:"
-    putStrLn fdSndPath
   where
-    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
-    encryptFile fileName = do
+    encryptFileForUpload :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
+    encryptFileForUpload fileName = do
+      fileSize <- fromInteger <$> getFileSize filePath
+      when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
       encPath <- getEncPath tempPath "xftp"
       key <- liftIO C.randomSbKey
       nonce <- liftIO C.randomCbNonce
-      fileSize <- fromInteger <$> getFileSize filePath
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
           chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
           defChunkSize = head chunkSizes
           chunkSizes' = map fromIntegral chunkSizes
           encSize = sum chunkSizes'
-      encrypt fileHdr key nonce fileSize' encSize encPath
+      withExceptT (CLIError . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
-          fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+      logInfo $ "encrypted file to " <> tshow encPath
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
-      where
-        encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
-        encrypt fileHdr key nonce fileSize' encSize encFile = do
-          f <- liftIO $ LB.readFile filePath
-          let f' = LB.fromStrict fileHdr <> f
-          c <- liftEither $ first (CLIError . show) $ LC.sbEncryptTailTag key nonce f' fileSize' $ encSize - authTagSize
-          liftIO $ LB.writeFile encFile c
     uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
     uploadFile chunks uploadedChunks encSize = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
@@ -293,28 +320,28 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       -- TODO shuffle/unshuffle chunks
       -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
       -- upload doesn't allow other requests within the same client until complete (but download does allow).
+      logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
       map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 chunks' (mapM $ uploadFileChunk a)
       where
         uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
+          logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
-          chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          digest <- liftIO $ getChunkDigest chunkSpec
+          let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
-          withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
+          withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
+          logInfo $ "uploaded chunk " <> tshow chunkNo
           uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
             let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
-          liftIO $ printProgress "Uploaded" uploaded encSize
+          liftIO $ do
+            notifyProgress uploaded encSize
+            when verbose $ putStrLn ""
           let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
               replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
           pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
-        getChunkInfo :: SndPublicVerifyKey -> XFTPChunkSpec -> IO FileInfo
-        getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
-          withFile chunkPath ReadMode $ \h -> do
-            hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-            digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
-            pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
         getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
         getXFTPServer gen = \case
           srv :| [] -> pure srv
@@ -324,8 +351,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     -- M chunks, R replicas, N recipients
     -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
     -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
-    createRcvFileDescriptions :: FileDescription 'FPRecipient -> [SentFileChunk] -> [FileDescription 'FPRecipient]
-    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FPRecipient)) {chunks}) rcvChunks
+    createRcvFileDescriptions :: FileDescription 'FRecipient -> [SentFileChunk] -> [FileDescription 'FRecipient]
+    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
       where
         rcvReplicas :: [SentRecipientReplica]
         rcvReplicas =
@@ -356,7 +383,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
               Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
               _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
             replica = FileChunkReplica {server, replicaId, replicaKey}
-    createSndFileDescription :: FileDescription 'FPSender -> [SentFileChunk] -> FileDescription 'FPSender
+    createSndFileDescription :: FileDescription 'FSender -> [SentFileChunk] -> FileDescription 'FSender
     createSndFileDescription fd sentChunks = fd {chunks = sndChunks}
       where
         sndChunks :: [FileChunk]
@@ -371,7 +398,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica]
         sndReplicas [] _ _ = []
         sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}]
-    writeFileDescriptions :: String -> [FileDescription 'FPRecipient] -> FileDescription 'FPSender -> IO ([FilePath], FilePath)
+    writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath)
     writeFileDescriptions fileName fdRcvs fdSnd = do
       outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
       createDirectoryIfMissing True outDir
@@ -383,11 +410,17 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       B.writeFile fdSndPath $ strEncode fdSnd
       pure (fdRcvPaths, fdSndPath)
 
+getChunkDigest :: XFTPChunkSpec -> IO ByteString
+getChunkDigest XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
+  withFile chunkPath ReadMode $ \h -> do
+    hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+    LC.sha256Hash <$> LB.hGet h (fromIntegral chunkSize)
+
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
-cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} =
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
   getFileDescription' fileDescription >>= receiveFile
   where
-    receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
+    receiveFile :: ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
     receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
@@ -401,48 +434,34 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
       when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
-      path <- decryptFile encSize chunkPaths key nonce
+      liftIO $ printNoNewLine "Decrypting file..."
+      path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
-      liftIO $ printNoNewLine $ "File downloaded: " <> path
-      liftIO $ putStrLn "\nFile description can't be used again"
+      liftIO $ do
+        printNoNewLine $ "File downloaded: " <> path
+        removeFD yes fileDescription
     downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
     downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
+      logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
       chunkPath <- uniqueCombine encPath $ show chunkNo
-      c <- withRetry retryCount $ getXFTPServerClient a server
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      withReconnect a server retryCount $ \c -> downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
       downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
         let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
-      liftIO $ printProgress "Downloaded" downloaded encSize
+      liftIO $ do
+        printProgress "Downloaded" downloaded encSize
+        when verbose $ putStrLn ""
       pure (chunkNo, chunkPath)
     downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
-    decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
-    decryptFile encSize chunkPaths key nonce = do
-      (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
-      let (fileHdr, f') = LB.splitAt 1024 f
-      -- withFile encPath ReadMode $ \r -> do
-      --   fileHdr <- liftIO $ B.hGet r 1024
-      case A.parse smpP $ LB.toStrict fileHdr of
-        A.Fail _ _ e -> throwError $ CLIError $ "Invalid file header: " <> e
-        A.Partial _ -> throwError $ CLIError "Invalid file header"
-        A.Done rest FileHeader {fileName} -> do
-          path <- getFilePath fileName
-          liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
-          unless authOk $ do
-            removeFile path
-            throwError $ CLIError "Error decrypting file: incorrect auth tag"
-          pure path
-    readChunks :: [FilePath] -> IO LB.ByteString
-    readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) LB.empty
-    {-# NOINLINE readChunks #-}
-    getFilePath :: String -> ExceptT CLIError IO FilePath
+    getFilePath :: String -> ExceptT String IO FilePath
     getFilePath name =
       case filePath of
         Just path ->
           ifM (doesDirectoryExist path) (uniqueCombine path name) $
-            ifM (doesFileExist path) (throwError $ CLIError "File already exists") (pure path)
+            ifM (doesFileExist path) (throwError "File already exists") (pure path)
         _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
     acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
     acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
@@ -460,19 +479,21 @@ printNoNewLine s = do
   hFlush stdout
 
 cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
-cliDeleteFile DeleteOptions {fileDescription, retryCount} = do
+cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
   getFileDescription' fileDescription >>= deleteFile
   where
-    deleteFile :: ValidFileDescription 'FPSender -> ExceptT CLIError IO ()
+    deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
     deleteFile (ValidFileDescription FileDescription {chunks}) = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       forM_ chunks $ deleteFileChunk a
-      liftIO $ putStrLn "File deleted"
+      liftIO $ do
+        printNoNewLine "File deleted!"
+        removeFD yes fileDescription
     deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
-    deleteFileChunk a FileChunk {replicas = replica : _} = do
+    deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
-      c <- withRetry retryCount $ getXFTPServerClient a server
-      withRetry retryCount $ deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+      withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+      logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
     deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
 
 cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
@@ -491,16 +512,15 @@ cliFileDescrInfo InfoOptions {fileDescription} = do
       where
         printParty :: IO ()
         printParty = case party of
-          SRecipient -> putStrLn "Recipient file description"
-          SSender -> putStrLn "Sender file description"
+          SFRecipient -> putStrLn "Recipient file description"
+          SFSender -> putStrLn "Sender file description"
 
 strEnc :: StrEncoding a => a -> String
 strEnc = B.unpack . strEncode
 
 getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
-getFileDescription path = do
-  fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
-  liftEither . first CLIError $ validateFileDescription fd
+getFileDescription path =
+  ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
 
 getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p)
 getFileDescription' path =
@@ -532,14 +552,12 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
 getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
 getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path
 
-uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
-uniqueCombine filePath fileName = tryCombine (0 :: Int)
-  where
-    tryCombine n =
-      let (name, ext) = splitExtensions fileName
-          suffix = if n == 0 then "" else "_" <> show n
-          f = filePath </> (name <> suffix <> ext)
-       in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
+withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
+withReconnect a srv n run = withRetry n $ do
+  c <- withRetry n $ getXFTPServerClient a srv
+  withExceptT (CLIError . show) (run c) `catchError` \e -> do
+    liftIO $ closeXFTPServerClient a srv
+    throwError e
 
 withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a
 withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
@@ -547,7 +565,30 @@ withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
     withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
     withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts"
     withRetry' 1 a = a
-    withRetry' n a = a `catchError` \_ -> withRetry' (n - 1) a
+    withRetry' n a =
+      a `catchError` \e -> do
+        logWarn ("retrying: " <> tshow e)
+        withRetry' (n - 1) a
+
+removeFD :: Bool -> FilePath -> IO ()
+removeFD yes fd
+  | yes = do
+    removeFile fd
+    putStrLn $ "\nFile description " <> fd <> " is deleted."
+  | otherwise = do
+    y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
+    when y $ removeFile fd
+
+getConfirmation :: String -> IO Bool
+getConfirmation prompt = do
+  putStr $ prompt <> " (Y/n): "
+  hFlush stdout
+  s <- getLine
+  case map toLower s of
+    "y" -> pure True
+    "" -> pure True
+    "n" -> pure False
+    _ -> getConfirmation prompt
 
 cliRandomFile :: RandomFileOptions -> IO ()
 cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
@@ -555,7 +596,7 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
   putStrLn $ "File created: " <> filePath
   where
     saveRandomFile h sz = do
-      bytes <- getRandomBytes $ min mb' sz
+      bytes <- getRandomBytes $ fromIntegral $ min mb' sz
       B.hPut h bytes
       when (sz > mb') $ saveRandomFile h (sz - mb')
     mb' = mb 1

src/Simplex/FileTransfer/Client/Presets.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Client.Presets where
+
+import Data.List.NonEmpty (NonEmpty)
+import Simplex.Messaging.Protocol (XFTPServerWithAuth)
+
+defaultXFTPServers :: NonEmpty XFTPServerWithAuth
+defaultXFTPServers =
+  [ "xftp://da1aH3nOT-9G8lV7bWamhxpDYdJ1xmW7j3JpGaDR5Ug=@xftp1.simplex.im,blisztokwh6alt5oem45f2eksm2xdowxszmhjesntcyolmhutoon7sid.onion",
+    "xftp://5vog2Imy1ExJB_7zDZrkV1KDWi96jYFyy9CL6fndBVw=@xftp2.simplex.im,jk6jybnel5hin2am5omd7g3hyvb4tfkyl7ea4vx5ldi7gpvz5ogqtcqd.onion",
+    "xftp://PYa32DdYNFWi0uZZOprWQoQpIk5qyjRJ3EF7bVpbsn8=@xftp3.simplex.im,pqhchr4bpkzef5wra4hnmzvppn5j5mjrpzkh5ixx6mhylnxxd6lmwnad.onion",
+    "xftp://k_GgQl40UZVV0Y4BX9ZTyMVqX5ZewcLW0waQIl7AYDE=@xftp4.simplex.im,q2lrjgiyo2efyweksavwxh3dlsrxetaxjztde2x5nateugrtrwzvmdid.onion",
+    "xftp://-bIo6o8wuVc4wpZkZD3tH-rCeYaeER_0lz1ffQcSJDs=@xftp5.simplex.im,2kikdbdhlrluburwt6q6rnoxvezcm2ifx2hj463jlunkeftlzm7hf3qd.onion",
+    "xftp://6nSvtY9pJn6PXWTAIMNl95E1Kk1vD7FM2TeOA64CFLg=@xftp6.simplex.im,tg3fmu6houq7vfqlsipm2qqzhtpgxesnuydqozx3khojxydhs53sbbyd.onion"
+  ]

src/Simplex/FileTransfer/Crypto.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Crypto where
+
+import Control.Monad.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import qualified Data.ByteArray as BA
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Simplex.FileTransfer.Types (FileHeader (..), authTagSize)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Lazy (LazyByteString)
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Util (liftEitherWith)
+import UnliftIO
+import UnliftIO.Directory (removeFile)
+
+encryptFile :: FilePath -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
+encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
+  sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
+  withFile filePath ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
+    let lenStr = smpEncode fileSize'
+        (hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr
+        padLen = encSize - authTagSize - fileSize' - 8
+    liftIO $ B.hPut w hdr
+    sb2 <- encryptChunks r w (sb', fileSize' - fromIntegral (B.length fileHdr))
+    sb3 <- encryptPad w (sb2, padLen)
+    let tag = BA.convert $ LC.sbAuth sb3
+    liftIO $ B.hPut w tag
+  where
+    encryptChunks r = encryptChunks_ $ liftIO . B.hGet r . fromIntegral
+    encryptPad = encryptChunks_ $ \sz -> pure $ B.replicate (fromIntegral sz) '#'
+    encryptChunks_ :: (Int64 -> IO ByteString) -> Handle -> (LC.SbState, Int64) -> ExceptT FTCryptoError IO LC.SbState
+    encryptChunks_ get w (!sb, !len)
+      | len == 0 = pure sb
+      | otherwise = do
+        let chSize = min len 65536
+        ch <- liftIO $ get chSize
+        when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
+        let (ch', sb') = LC.sbEncryptChunk sb ch
+        liftIO $ B.hPut w ch'
+        encryptChunks_ get w (sb', len - chSize)
+
+decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath
+decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
+decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse chPaths of
+  [] -> do
+    (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
+    unless authOk $ throwError FTCEInvalidAuthTag
+    (FileHeader {fileName}, !f') <- parseFileHeader f
+    path <- withExceptT FTCEFileIOError $ getFilePath fileName
+    liftIO $ LB.writeFile path f'
+    pure path
+  lastPath : chPaths' -> do
+    (state, expectedLen, ch) <- decryptFirstChunk
+    (FileHeader {fileName}, ch') <- parseFileHeader ch
+    path <- withExceptT FTCEFileIOError $ getFilePath fileName
+    authOk <- liftIO . withFile path WriteMode $ \h -> do
+      liftIO $ LB.hPut h ch'
+      state' <- foldM (decryptChunk h) state $ reverse chPaths'
+      decryptLastChunk h state' expectedLen
+    unless authOk $ do
+      removeFile path
+      throwError FTCEInvalidAuthTag
+    pure path
+    where
+      decryptFirstChunk = do
+        sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
+        ch <- liftIO $ LB.readFile chPath
+        let (ch1, !sb') = LC.sbDecryptChunkLazy sb ch
+        (!expectedLen, ch2) <- liftEitherWith FTCECryptoError $ LC.splitLen ch1
+        let len1 = LB.length ch2
+        pure ((sb', len1), expectedLen, ch2)
+      decryptChunk h (!sb, !len) chPth = do
+        ch <- LB.readFile chPth
+        let len' = len + LB.length ch
+            (ch', sb') = LC.sbDecryptChunkLazy sb ch
+        LB.hPut h ch'
+        pure (sb', len')
+      decryptLastChunk h (!sb, !len) expectedLen = do
+        ch <- LB.readFile lastPath
+        let (ch1, tag') = LB.splitAt (LB.length ch - authTagSize) ch
+            tag'' = LB.toStrict tag'
+            (ch2, sb') = LC.sbDecryptChunkLazy sb ch1
+            len' = len + LB.length ch2
+            ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2
+            tag :: ByteString = BA.convert (LC.sbAuth sb')
+        LB.hPut h ch3
+        pure $ B.length tag'' == 16 && BA.constEq tag'' tag
+  where
+    parseFileHeader :: LazyByteString -> ExceptT FTCryptoError IO (FileHeader, LazyByteString)
+    parseFileHeader s = do
+      let (hdrStr, s') = LB.splitAt 1024 s
+      case A.parse smpP $ LB.toStrict hdrStr of
+        A.Fail _ _ e -> throwError $ FTCEInvalidHeader e
+        A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete"
+        A.Done rest hdr -> pure (hdr, LB.fromStrict rest <> s')
+
+readChunks :: [FilePath] -> IO LB.ByteString
+readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
+
+data FTCryptoError
+  = FTCECryptoError C.CryptoError
+  | FTCEInvalidHeader String
+  | FTCEInvalidAuthTag
+  | FTCEFileIOError String
+  deriving (Show, Eq, Exception)

src/Simplex/FileTransfer/Description.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -27,6 +26,7 @@ module Simplex.FileTransfer.Description
     validateFileDescription,
     groupReplicasByServer,
     replicaServer,
+    fdSeparator,
     kb,
     mb,
     gb,
@@ -51,6 +51,8 @@ import Data.Maybe (fromMaybe)
 import Data.String
 import Data.Word (Word32)
 import qualified Data.Yaml as Y
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
 import Simplex.FileTransfer.Protocol
 import qualified Simplex.Messaging.Crypto as C
@@ -73,6 +75,7 @@ data FileDescription (p :: FileParty) = FileDescription
 data AFileDescription = forall p. FilePartyI p => AFD (FileDescription p)
 
 newtype ValidFileDescription p = ValidFD (FileDescription p)
+  deriving (Eq, Show)
 
 pattern ValidFileDescription :: FileDescription p -> ValidFileDescription p
 pattern ValidFileDescription fd = ValidFD fd
@@ -81,6 +84,9 @@ pattern ValidFileDescription fd = ValidFD fd
 
 data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p)
 
+fdSeparator :: IsString s => s
+fdSeparator = "################################\n"
+
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
 
@@ -96,6 +102,10 @@ instance ToJSON FileDigest where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromField FileDigest where fromField f = FileDigest <$> fromField f
+
+instance ToField FileDigest where toField (FileDigest s) = toField s
+
 data FileChunk = FileChunk
   { chunkNo :: Int,
     chunkSize :: FileSize Word32,
@@ -125,6 +135,10 @@ instance ToJSON ChunkReplicaId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f
+
+instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s
+
 data YAMLFileDescription = YAMLFileDescription
   { party :: FileParty,
     size :: String,
@@ -160,6 +174,16 @@ data FileServerReplica = FileServerReplica
   }
   deriving (Show)
 
+instance FilePartyI p => StrEncoding (ValidFileDescription p) where
+  strEncode (ValidFD fd) = strEncode fd
+  strDecode s = strDecode s >>= (\(AVFD fd) -> checkParty fd)
+  strP = strDecode <$?> A.takeByteString
+
+instance StrEncoding AValidFileDescription where
+  strEncode (AVFD fd) = strEncode fd
+  strDecode = (\(AFD fd) -> AVFD <$> validateFileDescription fd) <=< strDecode
+  strP = strDecode <$?> A.takeByteString
+
 instance FilePartyI p => StrEncoding (FileDescription p) where
   strEncode = Y.encode . encodeFileDescription
   strDecode s = strDecode s >>= (\(AFD fd) -> checkParty fd)
@@ -170,15 +194,14 @@ instance StrEncoding AFileDescription where
   strDecode = decodeFileDescription <=< first show . Y.decodeEither'
   strP = strDecode <$?> A.takeByteString
 
-validateFileDescription :: AFileDescription -> Either String AValidFileDescription
-validateFileDescription = \case
-  AFD fd@FileDescription {size, chunks}
-    | chunkNos /= [1 .. length chunks] -> Left "chunk numbers are not sequential"
-    | chunksSize chunks /= unFileSize size -> Left "chunks total size is different than file size"
-    | otherwise -> Right $ AVFD (ValidFD fd)
-    where
-      chunkNos = map (chunkNo :: FileChunk -> Int) chunks
-      chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
+validateFileDescription :: FileDescription p -> Either String (ValidFileDescription p)
+validateFileDescription fd@FileDescription {size, chunks}
+  | chunkNos /= [1 .. length chunks] = Left "chunk numbers are not sequential"
+  | chunksSize chunks /= unFileSize size = Left "chunks total size is different than file size"
+  | otherwise = Right $ ValidFD fd
+  where
+    chunkNos = map (chunkNo :: FileChunk -> Int) chunks
+    chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
 
 encodeFileDescription :: FileDescription p -> YAMLFileDescription
 encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} =
@@ -216,16 +239,23 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
 
 kb :: Integral a => a -> a
 kb n = 1024 * n
+{-# INLINE kb #-}
 
 mb :: Integral a => a -> a
 mb n = 1024 * kb n
+{-# INLINE mb #-}
 
 gb :: Integral a => a -> a
 gb n = 1024 * mb n
+{-# INLINE gb #-}
 
 instance (Integral a, Show a) => IsString (FileSize a) where
   fromString = either error id . strDecode . B.pack
 
+instance (FromField a) => FromField (FileSize a) where fromField f = FileSize <$> fromField f
+
+instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toField s
+
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =
   groupBy ((==) `on` replicaServer)

src/Simplex/FileTransfer/Protocol.hs

@@ -13,6 +13,7 @@
 
 module Simplex.FileTransfer.Protocol where
 
+import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -25,6 +26,7 @@ import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
 import GHC.Generics (Generic)
+import Generic.Random (genericArbitraryU)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -55,8 +57,9 @@ import Simplex.Messaging.Protocol
     _smpP,
   )
 import Simplex.Messaging.Transport (SessionId, TransportError (..))
-import Simplex.Messaging.Util ((<$?>))
+import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
+import Test.QuickCheck (Arbitrary (..))
 
 currentXFTPVersion :: Version
 currentXFTPVersion = 1
@@ -65,23 +68,23 @@ xftpBlockSize :: Int
 xftpBlockSize = 16384
 
 -- | File protocol clients
-data FileParty = FPRecipient | FPSender
+data FileParty = FRecipient | FSender
   deriving (Eq, Show, Generic)
 
 instance FromJSON FileParty where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "FP"
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "F"
 
 instance ToJSON FileParty where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "FP"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "FP"
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "F"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "F"
 
 data SFileParty :: FileParty -> Type where
-  SRecipient :: SFileParty FPRecipient
-  SSender :: SFileParty FPSender
+  SFRecipient :: SFileParty FRecipient
+  SFSender :: SFileParty FSender
 
 instance TestEquality SFileParty where
-  testEquality SRecipient SRecipient = Just Refl
-  testEquality SSender SSender = Just Refl
+  testEquality SFRecipient SFRecipient = Just Refl
+  testEquality SFSender SFSender = Just Refl
   testEquality _ _ = Nothing
 
 deriving instance Eq (SFileParty p)
@@ -92,28 +95,28 @@ data AFileParty = forall p. FilePartyI p => AFP (SFileParty p)
 
 toFileParty :: SFileParty p -> FileParty
 toFileParty = \case
-  SRecipient -> FPRecipient
-  SSender -> FPSender
+  SFRecipient -> FRecipient
+  SFSender -> FSender
 
 aFileParty :: FileParty -> AFileParty
 aFileParty = \case
-  FPRecipient -> AFP SRecipient
-  FPSender -> AFP SSender
+  FRecipient -> AFP SFRecipient
+  FSender -> AFP SFSender
 
 class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
 
-instance FilePartyI FPRecipient where sFileParty = SRecipient
+instance FilePartyI FRecipient where sFileParty = SFRecipient
 
-instance FilePartyI FPSender where sFileParty = SSender
+instance FilePartyI FSender where sFileParty = SFSender
 
 data FileCommandTag (p :: FileParty) where
-  FNEW_ :: FileCommandTag FPSender
-  FADD_ :: FileCommandTag FPSender
-  FPUT_ :: FileCommandTag FPSender
-  FDEL_ :: FileCommandTag FPSender
-  FGET_ :: FileCommandTag FPRecipient
-  FACK_ :: FileCommandTag FPRecipient
-  PING_ :: FileCommandTag FPRecipient
+  FNEW_ :: FileCommandTag FSender
+  FADD_ :: FileCommandTag FSender
+  FPUT_ :: FileCommandTag FSender
+  FDEL_ :: FileCommandTag FSender
+  FGET_ :: FileCommandTag FRecipient
+  FACK_ :: FileCommandTag FRecipient
+  PING_ :: FileCommandTag FRecipient
 
 deriving instance Show (FileCommandTag p)
 
@@ -136,13 +139,13 @@ instance Encoding FileCmdTag where
 
 instance ProtocolMsgTag FileCmdTag where
   decodeTag = \case
-    "FNEW" -> Just $ FCT SSender FNEW_
-    "FADD" -> Just $ FCT SSender FADD_
-    "FPUT" -> Just $ FCT SSender FPUT_
-    "FDEL" -> Just $ FCT SSender FDEL_
-    "FGET" -> Just $ FCT SRecipient FGET_
-    "FACK" -> Just $ FCT SRecipient FACK_
-    "PING" -> Just $ FCT SRecipient PING_
+    "FNEW" -> Just $ FCT SFSender FNEW_
+    "FADD" -> Just $ FCT SFSender FADD_
+    "FPUT" -> Just $ FCT SFSender FPUT_
+    "FDEL" -> Just $ FCT SFSender FDEL_
+    "FGET" -> Just $ FCT SFRecipient FGET_
+    "FACK" -> Just $ FCT SFRecipient FACK_
+    "PING" -> Just $ FCT SFRecipient PING_
     _ -> Nothing
 
 instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
@@ -152,19 +155,19 @@ instance Protocol XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
   protocolClientHandshake = ntfClientHandshake
-  protocolPing = FileCmd SRecipient PING
+  protocolPing = FileCmd SFRecipient PING
   protocolError = \case
     FRErr e -> Just e
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender
-  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
-  FPUT :: FileCommand FPSender
-  FDEL :: FileCommand FPSender
-  FGET :: RcvPublicDhKey -> FileCommand FPRecipient
-  FACK :: FileCommand FPRecipient
-  PING :: FileCommand FPRecipient
+  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender
+  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender
+  FPUT :: FileCommand FSender
+  FDEL :: FileCommand FSender
+  FGET :: RcvPublicDhKey -> FileCommand FRecipient
+  FACK :: FileCommand FRecipient
+  PING :: FileCommand FRecipient
 
 deriving instance Show (FileCommand p)
 
@@ -219,14 +222,14 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
   protocolP _v = \case
-    FCT SSender tag ->
-      FileCmd SSender <$> case tag of
+    FCT SFSender tag ->
+      FileCmd SFSender <$> case tag of
         FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
-    FCT SRecipient tag ->
-      FileCmd SRecipient <$> case tag of
+    FCT SFRecipient tag ->
+      FileCmd SFRecipient <$> case tag of
         FGET_ -> FGET <$> _smpP
         FACK_ -> pure FACK
         PING_ -> pure PING
@@ -354,6 +357,18 @@ data XFTPErrorType
     DUPLICATE_ -- not part of SMP protocol, used internally
   deriving (Eq, Generic, Read, Show)
 
+instance ToJSON XFTPErrorType where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
+instance StrEncoding XFTPErrorType where
+  strEncode = \case
+    CMD e -> "CMD " <> bshow e
+    e -> bshow e
+  strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
+
+instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU
+
 instance Encoding XFTPErrorType where
   smpEncode = \case
     BLOCK -> "BLOCK"

src/Simplex/FileTransfer/Server.hs

@@ -22,6 +22,7 @@ import Data.ByteString.Builder (byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
@@ -96,7 +97,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
       st <- asks store
       let interval = checkInterval expCfg * 1000000
       forever $ do
-        threadDelay interval
+        liftIO $ threadDelay' interval
         old <- liftIO $ expireBeforeEpoch expCfg
         sIds <- M.keysSet <$> readTVarIO (files st)
         forM_ sIds $ \sId -> do
@@ -118,11 +119,11 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
       [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> FilePath -> M ()
+    logServerStats :: Int64 -> Int64 -> FilePath -> M ()
     logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0)
+      liftIO $ threadDelay' $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0)
       FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats
       let interval = 1_000_000 * logInterval
       forever $ do
@@ -155,7 +156,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
                 show filesCount',
                 show filesSize'
               ]
-        threadDelay interval
+        liftIO $ threadDelay' interval
 
 data ServerFile = ServerFile
   { filePath :: FilePath,
@@ -201,8 +202,8 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed
 verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
 verifyXFTPTransmission sig_ signed fId cmd =
   case cmd of
-    FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
-    FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing
+    FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
+    FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
     FileCmd party _ -> verifyCmd party
   where
     verifyCmd :: SFileParty p -> M VerificationResult
@@ -217,19 +218,13 @@ verifyXFTPTransmission sig_ signed fId cmd =
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rks auth -> do
-    st <- asks store
-    noFile
-      =<< ifM
-        allowNew
-        (createFile st file rks)
-        (pure $ FRErr AUTH)
+  XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH)
     where
       allowNew = do
         XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
         pure $ allowNewFiles && maybe True ((== auth) . Just) newFileBasicAuth
   XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
-    FADD _rcps -> noFile FROk
+    FADD rks -> noFile =<< addRecipients fId rks
     FPUT -> noFile =<< receiveServerFile fr
     FDEL -> noFile =<< deleteServerFile fr
     FGET rDhKey -> sendServerFile fr rDhKey
@@ -240,15 +235,16 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileStore -> FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
-    createFile st file rks = do
+    createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    createFile file rks = do
+      st <- asks store
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwError SIZE
         ts <- liftIO getSystemTime
         -- TODO validate body empty
-        sId <- ExceptT $ addFileRetry 3 ts
-        rcps <- mapM (ExceptT . addRecipientRetry 3 sId) rks
+        sId <- ExceptT $ addFileRetry st file 3 ts
+        rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         withFileLog $ \sl -> do
           logAddFile sl sId file ts
           logAddRecipients sl sId rcps
@@ -258,25 +254,35 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
-      where
-        addFileRetry :: Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
-        addFileRetry n ts =
-          retryAdd n $ \sId -> runExceptT $ do
-            ExceptT $ addFile st sId file ts
-            pure sId
-        addRecipientRetry :: Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient)
-        addRecipientRetry n sId rpk =
-          retryAdd n $ \rId -> runExceptT $ do
-            let rcp = FileRecipient rId rpk
-            ExceptT $ addRecipient st sId rcp
-            pure rcp
-        retryAdd :: Int -> (XFTPFileId -> STM (Either XFTPErrorType a)) -> M (Either XFTPErrorType a)
-        retryAdd 0 _ = pure $ Left INTERNAL
-        retryAdd n add = do
-          fId <- getFileId
-          atomically (add fId) >>= \case
-            Left DUPLICATE_ -> retryAdd (n - 1) add
-            r -> pure r
+    addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
+    addFileRetry st file n ts =
+      retryAdd n $ \sId -> runExceptT $ do
+        ExceptT $ addFile st sId file ts
+        pure sId
+    addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient)
+    addRecipientRetry st n sId rpk =
+      retryAdd n $ \rId -> runExceptT $ do
+        let rcp = FileRecipient rId rpk
+        ExceptT $ addRecipient st sId rcp
+        pure rcp
+    retryAdd :: Int -> (XFTPFileId -> STM (Either XFTPErrorType a)) -> M (Either XFTPErrorType a)
+    retryAdd 0 _ = pure $ Left INTERNAL
+    retryAdd n add = do
+      fId <- getFileId
+      atomically (add fId) >>= \case
+        Left DUPLICATE_ -> retryAdd (n - 1) add
+        r -> pure r
+    addRecipients :: XFTPFileId -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    addRecipients sId rks = do
+      st <- asks store
+      r <- runExceptT $ do
+        rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
+        withFileLog $ \sl -> logAddRecipients sl sId rcps
+        stats <- asks serverStats
+        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
+        let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
+        pure $ FRRcvIds rIds
+      pure $ either FRErr id r
     receiveServerFile :: FileRec -> M FileResponse
     receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
       -- TODO do not allow repeated file upload

src/Simplex/FileTransfer/Server/Env.hs

@@ -51,8 +51,8 @@ data XFTPServerConfig = XFTPServerConfig
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- stats config - see SMP server config
-    logStatsInterval :: Maybe Int,
-    logStatsStartTime :: Int,
+    logStatsInterval :: Maybe Int64,
+    logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
     logTLSErrors :: Bool
@@ -68,10 +68,13 @@ data XFTPEnv = XFTPEnv
     serverStats :: FileServerStats
   }
 
+defFileExpirationHours :: Int64
+defFileExpirationHours = 48
+
 defaultFileExpiration :: ExpirationConfig
 defaultFileExpiration =
   ExpirationConfig
-    { ttl = 48 * 3600, -- seconds, 48 hours
+    { ttl = defFileExpirationHours * 3600, -- seconds
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 

src/Simplex/FileTransfer/Server/Main.hs

@@ -18,11 +18,12 @@ 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)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defFileExpirationHours)
 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)
@@ -30,7 +31,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 xftpServerVersion :: String
-xftpServerVersion = "0.1.0"
+xftpServerVersion = "1.0.0"
 
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do
@@ -76,6 +77,8 @@ 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\
@@ -113,10 +116,13 @@ 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} = do
+        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration} = 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
@@ -134,7 +140,10 @@ 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,
+              fileExpiration =
+                Just defaultFileExpiration
+                  { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
+                  },
               caCertificateFile = c caCrtFile,
               privateKeyFile = c serverKeyFile,
               certificateFile = c serverCrtFile,

src/Simplex/FileTransfer/Server/Store.hs

@@ -115,8 +115,8 @@ deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
 
 getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
 getFile st party fId = case party of
-  SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
-  SRecipient ->
+  SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
+  SFRecipient ->
     TM.lookup fId (recipients st) >>= \case
       Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey)
       _ -> pure $ Left AUTH

src/Simplex/FileTransfer/Transport.hs

@@ -15,7 +15,6 @@ module Simplex.FileTransfer.Transport
   )
 where
 
-import Control.Concurrent (threadDelay)
 import qualified Control.Exception as E
 import Control.Monad.Except
 import qualified Data.ByteArray as BA
@@ -57,15 +56,12 @@ sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
   where
     go sbState 0 = do
-      -- TODO remove padding when HTTP2 issue is fixed
-      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (fileBlockSize - C.authTagSize) '#'
+      let authTag = BA.convert (LC.sbAuth sbState)
       send $ byteString authTag
     go sbState sz =
       getFileChunk h sz >>= \ch -> do
         let (encCh, sbState') = LC.sbEncryptChunk sbState ch
         send (byteString encCh) `E.catch` \(e :: E.SomeException) -> print e >> E.throwIO e
-        -- TODO remove delay when HTTP2 issue is fixed
-        threadDelay 500
         go sbState' $ sz - fromIntegral (B.length ch)
 
 getFileChunk :: Handle -> Word32 -> IO ByteString
@@ -113,5 +109,5 @@ receiveEncFile getBody = receiveFile_ . receive
 receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
 receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
   ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
-  digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
+  digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath
   when (digest' /= chunkDigest) $ throwError DIGEST

src/Simplex/FileTransfer/Types.hs

@@ -0,0 +1,228 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Types where
+
+import Data.Int (Int64)
+import Data.Word (Word32)
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
+import Simplex.FileTransfer.Description
+import Simplex.Messaging.Agent.Protocol (RcvFileId, SndFileId)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (fromTextField_)
+import Simplex.Messaging.Protocol
+import System.FilePath ((</>))
+
+authTagSize :: Int64
+authTagSize = fromIntegral C.authTagSize
+
+-- fileExtra is added to allow header extension in future versions
+data FileHeader = FileHeader
+  { fileName :: String,
+    fileExtra :: Maybe String
+  }
+  deriving (Eq, Show)
+
+instance Encoding FileHeader where
+  smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra)
+  smpP = do
+    (fileName, fileExtra) <- smpP
+    pure FileHeader {fileName, fileExtra}
+
+type DBRcvFileId = Int64
+
+data RcvFile = RcvFile
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
+    size :: FileSize Int64,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
+    chunks :: [RcvFileChunk],
+    prefixPath :: FilePath,
+    tmpPath :: Maybe FilePath,
+    savePath :: FilePath,
+    status :: RcvFileStatus,
+    deleted :: Bool
+  }
+  deriving (Eq, Show)
+
+data RcvFileStatus
+  = RFSReceiving
+  | RFSReceived
+  | RFSDecrypting
+  | RFSComplete
+  | RFSError
+  deriving (Eq, Show)
+
+instance FromField RcvFileStatus where fromField = fromTextField_ textDecode
+
+instance ToField RcvFileStatus where toField = toField . textEncode
+
+instance TextEncoding RcvFileStatus where
+  textDecode = \case
+    "receiving" -> Just RFSReceiving
+    "received" -> Just RFSReceived
+    "decrypting" -> Just RFSDecrypting
+    "complete" -> Just RFSComplete
+    "error" -> Just RFSError
+    _ -> Nothing
+  textEncode = \case
+    RFSReceiving -> "receiving"
+    RFSReceived -> "received"
+    RFSDecrypting -> "decrypting"
+    RFSComplete -> "complete"
+    RFSError -> "error"
+
+data RcvFileChunk = RcvFileChunk
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
+    rcvChunkId :: Int64,
+    chunkNo :: Int,
+    chunkSize :: FileSize Word32,
+    digest :: FileDigest,
+    replicas :: [RcvFileChunkReplica],
+    fileTmpPath :: FilePath,
+    chunkTmpPath :: Maybe FilePath
+  }
+  deriving (Eq, Show)
+
+data RcvFileChunkReplica = RcvFileChunkReplica
+  { rcvChunkReplicaId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    received :: Bool,
+    delay :: Maybe Int64,
+    retries :: Int
+  }
+  deriving (Eq, Show)
+
+-- Sending files
+
+type DBSndFileId = Int64
+
+data SndFile = SndFile
+  { sndFileId :: DBSndFileId,
+    sndFileEntityId :: SndFileId,
+    userId :: Int64,
+    numRecipients :: Int,
+    digest :: Maybe FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunks :: [SndFileChunk],
+    filePath :: FilePath,
+    prefixPath :: Maybe FilePath,
+    status :: SndFileStatus,
+    deleted :: Bool
+  }
+  deriving (Eq, Show)
+
+sndFileEncPath :: FilePath -> FilePath
+sndFileEncPath prefixPath = prefixPath </> "xftp.encrypted"
+
+data SndFileStatus
+  = SFSNew -- db record created
+  | SFSEncrypting -- encryption started
+  | SFSEncrypted -- encryption complete
+  | SFSUploading -- all chunk replicas are created on servers
+  | SFSComplete -- all chunk replicas are uploaded
+  | SFSError -- permanent error
+  deriving (Eq, Show)
+
+instance FromField SndFileStatus where fromField = fromTextField_ textDecode
+
+instance ToField SndFileStatus where toField = toField . textEncode
+
+instance TextEncoding SndFileStatus where
+  textDecode = \case
+    "new" -> Just SFSNew
+    "encrypting" -> Just SFSEncrypting
+    "encrypted" -> Just SFSEncrypted
+    "uploading" -> Just SFSUploading
+    "complete" -> Just SFSComplete
+    "error" -> Just SFSError
+    _ -> Nothing
+  textEncode = \case
+    SFSNew -> "new"
+    SFSEncrypting -> "encrypting"
+    SFSEncrypted -> "encrypted"
+    SFSUploading -> "uploading"
+    SFSComplete -> "complete"
+    SFSError -> "error"
+
+data SndFileChunk = SndFileChunk
+  { sndFileId :: DBSndFileId,
+    sndFileEntityId :: SndFileId,
+    userId :: Int64,
+    numRecipients :: Int,
+    sndChunkId :: Int64,
+    chunkNo :: Int,
+    chunkSpec :: XFTPChunkSpec,
+    filePrefixPath :: FilePath,
+    digest :: FileDigest,
+    replicas :: [SndFileChunkReplica]
+  }
+  deriving (Eq, Show)
+
+sndChunkSize :: SndFileChunk -> Word32
+sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize
+
+data NewSndChunkReplica = NewSndChunkReplica
+  { server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)]
+  }
+  deriving (Eq, Show)
+
+data SndFileChunkReplica = SndFileChunkReplica
+  { sndChunkReplicaId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)],
+    replicaStatus :: SndFileReplicaStatus,
+    delay :: Maybe Int64,
+    retries :: Int
+  }
+  deriving (Eq, Show)
+
+data SndFileReplicaStatus
+  = SFRSCreated
+  | SFRSUploaded
+  deriving (Eq, Show)
+
+instance FromField SndFileReplicaStatus where fromField = fromTextField_ textDecode
+
+instance ToField SndFileReplicaStatus where toField = toField . textEncode
+
+instance TextEncoding SndFileReplicaStatus where
+  textDecode = \case
+    "created" -> Just SFRSCreated
+    "uploaded" -> Just SFRSUploaded
+    _ -> Nothing
+  textEncode = \case
+    SFRSCreated -> "created"
+    SFRSUploaded -> "uploaded"
+
+data DeletedSndChunkReplica = DeletedSndChunkReplica
+  { deletedSndChunkReplicaId :: Int64,
+    userId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    chunkDigest :: FileDigest,
+    delay :: Maybe Int64,
+    retries :: Int
+  }
+  deriving (Eq, Show)

src/Simplex/FileTransfer/Util.hs

@@ -0,0 +1,24 @@
+module Simplex.FileTransfer.Util
+  ( uniqueCombine,
+    removePath,
+  )
+where
+
+import Simplex.Messaging.Util (ifM, whenM)
+import System.FilePath (splitExtensions, (</>))
+import UnliftIO
+import UnliftIO.Directory
+
+uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
+uniqueCombine filePath fileName = tryCombine (0 :: Int)
+  where
+    tryCombine n =
+      let (name, ext) = splitExtensions fileName
+          suffix = if n == 0 then "" else "_" <> show n
+          f = filePath </> (name <> suffix <> ext)
+       in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
+
+removePath :: MonadIO m => FilePath -> m ()
+removePath p = do
+  ifM (doesDirectoryExist p) (removeDirectoryRecursive p) $
+    whenM (doesFileExist p) (removeFile p)

src/Simplex/Messaging/Agent.hs

@@ -68,8 +68,8 @@ module Simplex.Messaging.Agent
     deleteConnections,
     getConnectionServers,
     getConnectionRatchetAdHash,
-    setSMPServers,
-    testSMPServerConnection,
+    setProtocolServers,
+    testProtocolServer,
     setNtfServers,
     setNetworkConfig,
     getNetworkConfig,
@@ -80,9 +80,16 @@ module Simplex.Messaging.Agent
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
-    activateAgent,
+    xftpStartWorkers,
+    xftpReceiveFile,
+    xftpDeleteRcvFile,
+    xftpSendFile,
+    xftpDeleteSndFileInternal,
+    xftpDeleteSndFileRemote,
+    foregroundAgent,
     suspendAgent,
     execAgentStoreSQL,
+    getAgentMigrations,
     debugAgentLocks,
     getAgentStats,
     resetAgentStats,
@@ -102,7 +109,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::))
 import Data.Foldable (foldl')
 import Data.Functor (($>))
-import Data.List (deleteFirstsBy, find, (\\))
+import Data.List (find)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -113,6 +120,10 @@ import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 import qualified Database.SQLite.Simple as DB
+import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteRcvFile, deleteSndFileInternal, deleteSndFileRemote, receiveFile, sendFile, startWorkers, toFSFilePath)
+import Simplex.FileTransfer.Description (ValidFileDescription)
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock (withLock)
@@ -121,6 +132,7 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -130,12 +142,11 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr')
+import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth)
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
-import System.Random (randomR)
 import UnliftIO.Async (async, race_)
 import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
@@ -144,8 +155,9 @@ import UnliftIO.STM
 -- import GHC.Conc (unsafeIOToSTM)
 
 -- | Creates an SMP agent client instance
-getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> m AgentClient
-getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
+getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> SQLiteStore -> m AgentClient
+getSMPAgentClient cfg initServers store =
+  liftIO (newSMPAgentEnv cfg store) >>= runReaderT runAgent
   where
     runAgent = do
       c <- getAgentClient initServers
@@ -153,9 +165,10 @@ getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
       pure c
 
 disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m ()
-disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns}} = do
+disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do
   closeAgentClient c
-  liftIO $ closeNtfSupervisor ns
+  closeNtfSupervisor ns
+  closeXFTPAgent xa
   logConnection c False
 
 resumeAgentClient :: MonadIO m => AgentClient -> m ()
@@ -163,8 +176,8 @@ resumeAgentClient c = atomically $ writeTVar (active c) True
 
 type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)
 
-createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId
-createUser c = withAgentEnv c . createUser' c
+createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> m UserId
+createUser c = withAgentEnv c .: createUser' c
 
 -- | Delete user record optionally deleting all user's connections on SMP servers
 deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> m ()
@@ -276,18 +289,20 @@ getConnectionRatchetAdHash :: AgentErrorMonad m => AgentClient -> ConnId -> m By
 getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
 
 -- | Change servers to be used for creating new queues
-setSMPServers :: AgentErrorMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
-setSMPServers c = withAgentEnv c .: setSMPServers' c
+setProtocolServers :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
+setProtocolServers c = withAgentEnv c .: setProtocolServers' c
 
--- | Test SMP server
-testSMPServerConnection :: AgentErrorMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
-testSMPServerConnection c = withAgentEnv c .: runSMPServerTest c
+-- | Test protocol server
+testProtocolServer :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> ProtoServerWithAuth p -> m (Maybe ProtocolTestFailure)
+testProtocolServer c userId srv = withAgentEnv c $ case protocolTypeI @p of
+  SPSMP -> runSMPServerTest c userId srv
+  SPXFTP -> runXFTPServerTest c userId srv
 
-setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
+setNtfServers :: MonadUnliftIO m => AgentClient -> [NtfServer] -> m ()
 setNtfServers c = withAgentEnv c . setNtfServers' c
 
 -- | set SOCKS5 proxy on/off and optionally set TCP timeout
-setNetworkConfig :: AgentErrorMonad m => AgentClient -> NetworkConfig -> m ()
+setNetworkConfig :: MonadUnliftIO m => AgentClient -> NetworkConfig -> m ()
 setNetworkConfig c cfg' = do
   cfg <- atomically $ do
     swapTVar (useNetworkConfig c) cfg'
@@ -322,31 +337,57 @@ getNtfTokenData c = withAgentEnv c $ getNtfTokenData' c
 toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m ()
 toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c
 
+xftpStartWorkers :: AgentErrorMonad m => AgentClient -> Maybe FilePath -> m ()
+xftpStartWorkers c = withAgentEnv c . startWorkers c
+
+-- | Receive XFTP file
+xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
+xftpReceiveFile c = withAgentEnv c .: receiveFile c
+
+-- | Delete XFTP rcv file (deletes work files from file system and db records)
+xftpDeleteRcvFile :: AgentErrorMonad m => AgentClient -> RcvFileId -> m ()
+xftpDeleteRcvFile c = withAgentEnv c . deleteRcvFile c
+
+-- | Send XFTP file
+xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
+xftpSendFile c = withAgentEnv c .:. sendFile c
+
+-- | Delete XFTP snd file internally (deletes work files from file system and db records)
+xftpDeleteSndFileInternal :: AgentErrorMonad m => AgentClient -> SndFileId -> m ()
+xftpDeleteSndFileInternal c = withAgentEnv c . deleteSndFileInternal c
+
+-- | Delete XFTP snd file chunks on servers
+xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
+xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
+
 -- | Activate operations
-activateAgent :: AgentErrorMonad m => AgentClient -> m ()
-activateAgent c = withAgentEnv c $ activateAgent' c
+foregroundAgent :: MonadUnliftIO m => AgentClient -> m ()
+foregroundAgent c = withAgentEnv c $ foregroundAgent' c
 
 -- | Suspend operations with max delay to deliver pending messages
-suspendAgent :: AgentErrorMonad m => AgentClient -> Int -> m ()
+suspendAgent :: MonadUnliftIO m => AgentClient -> Int -> m ()
 suspendAgent c = withAgentEnv c . suspendAgent' c
 
 execAgentStoreSQL :: AgentErrorMonad m => AgentClient -> Text -> m [Text]
 execAgentStoreSQL c = withAgentEnv c . execAgentStoreSQL' c
 
-debugAgentLocks :: AgentErrorMonad m => AgentClient -> m AgentLocks
+getAgentMigrations :: AgentErrorMonad m => AgentClient -> m [UpMigration]
+getAgentMigrations c = withAgentEnv c $ getAgentMigrations' c
+
+debugAgentLocks :: MonadUnliftIO m => AgentClient -> m AgentLocks
 debugAgentLocks c = withAgentEnv c $ debugAgentLocks' c
 
-getAgentStats :: AgentErrorMonad m => AgentClient -> m [(AgentStatsKey, Int)]
+getAgentStats :: MonadIO m => AgentClient -> m [(AgentStatsKey, Int)]
 getAgentStats c = readTVarIO (agentStats c) >>= mapM (\(k, cnt) -> (k,) <$> readTVarIO cnt) . M.assocs
 
-resetAgentStats :: AgentErrorMonad m => AgentClient -> m ()
+resetAgentStats :: MonadIO m => AgentClient -> m ()
 resetAgentStats = atomically . TM.clear . agentStats
 
 withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
 withAgentEnv c = (`runReaderT` agentEnv c)
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => InitialAgentServers -> m AgentClient
+getAgentClient :: AgentMonad' m => InitialAgentServers -> m AgentClient
 getAgentClient initServers = ask >>= atomically . newAgentClient initServers
 
 logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
@@ -355,40 +396,43 @@ logConnection c connected =
    in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"]
 
 -- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
-runAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runAgentClient :: AgentMonad' m => AgentClient -> m ()
 runAgentClient c = race_ (subscriber c) (client c)
 
-client :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+client :: forall m. AgentMonad' m => AgentClient -> m ()
 client c@AgentClient {rcvQ, subQ} = forever $ do
-  (corrId, connId, cmd) <- atomically $ readTBQueue rcvQ
-  runExceptT (processCommand c (connId, cmd))
+  (corrId, entId, cmd) <- atomically $ readTBQueue rcvQ
+  runExceptT (processCommand c (entId, cmd))
     >>= atomically . writeTBQueue subQ . \case
-      Left e -> (corrId, connId, ERR e)
-      Right (connId', resp) -> (corrId, connId', resp)
+      Left e -> (corrId, entId, APC SAEConn $ ERR e)
+      Right (entId', resp) -> (corrId, entId', resp)
 
 -- | execute any SMP agent command
-processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent)
-processCommand c (connId, cmd) = case cmd of
-  NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing
-  JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo
-  LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
-  ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo
-  RJCT invId -> rejectContact' c connId invId $> (connId, OK)
-  SUB -> subscribeConnection' c connId $> (connId, OK)
-  SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
-  ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
-  SWCH -> switchConnection' c connId $> (connId, OK)
-  OFF -> suspendConnection' c connId $> (connId, OK)
-  DEL -> deleteConnection' c connId $> (connId, OK)
-  CHK -> (connId,) . STAT <$> getConnectionServers' c connId
+processCommand :: forall m. AgentMonad m => AgentClient -> (EntityId, APartyCmd 'Client) -> m (EntityId, APartyCmd 'Agent)
+processCommand c (connId, APC e cmd) =
+  second (APC e) <$> case cmd of
+    NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing
+    JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo
+    LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
+    ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo
+    RJCT invId -> rejectContact' c connId invId $> (connId, OK)
+    SUB -> subscribeConnection' c connId $> (connId, OK)
+    SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
+    ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
+    SWCH -> switchConnection' c connId $> (connId, OK)
+    OFF -> suspendConnection' c connId $> (connId, OK)
+    DEL -> deleteConnection' c connId $> (connId, OK)
+    CHK -> (connId,) . STAT <$> getConnectionServers' c connId
   where
     -- command interface does not support different users
+    userId :: UserId
     userId = 1
 
-createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId
-createUser' c srvs = do
+createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> m UserId
+createUser' c smp xftp = do
   userId <- withStore' c createUserRecord
-  atomically $ TM.insert userId srvs $ smpServers c
+  atomically $ TM.insert userId smp $ smpServers c
+  atomically $ TM.insert userId xftp $ xftpServers c
   pure userId
 
 deleteUser' :: AgentMonad m => AgentClient -> UserId -> Bool -> m ()
@@ -400,12 +444,12 @@ deleteUser' c userId delSMPQueues = do
   where
     delUser =
       whenM (withStore' c (`deleteUserWithoutConns` userId)) $
-        atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId)
+        atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
 
 newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId
 newConnAsync c userId corrId enableNtfs cMode = do
   connId <- newConnNoQueues c userId "" enableNtfs cMode
-  enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode)
+  enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode)
   pure connId
 
 newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> m ConnId
@@ -424,7 +468,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData
       let duplexHS = connAgentVersion /= 1
           cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False}
       connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
-      enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo
+      enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo
       pure connId
     _ -> throwError $ AGENT A_VERSION
 joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _cInfo =
@@ -434,7 +478,7 @@ allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Con
 allowConnectionAsync' c corrId connId confId ownConnInfo =
   withStore c (`getConn` connId) >>= \case
     SomeConn _ (RcvConnection _ RcvQueue {server}) ->
-      enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo
+      enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo
     _ -> throwError $ CMD PROHIBITED
 
 acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> m ConnId
@@ -461,7 +505,7 @@ ackMessageAsync' c corrId connId msgId = do
     enqueueAck :: m ()
     enqueueAck = do
       (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId
-      enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId
+      enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId
 
 deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
 deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId]
@@ -483,7 +527,7 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of
 switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ()
 switchConnectionAsync' c corrId connId =
   withStore c (`getConn` connId) >>= \case
-    SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand SWCH
+    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)
@@ -516,7 +560,7 @@ joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> Bool -> C
 joinConn c userId connId asyncMode enableNtfs cReq cInfo = do
   srv <- case cReq of
     CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
-      getNextSMPServer c userId [qServer q]
+      getNextServer c userId [qServer q]
     _ -> getSMPServer c userId
   joinConnSrv c userId connId asyncMode enableNtfs cReq cInfo srv
 
@@ -689,7 +733,7 @@ subscribeConnections' c connIds = do
       let actual = M.size rs
           expected = length connIds
       when (actual /= expected) . atomically $
-        writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
+        writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
 
 resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
 resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId]
@@ -777,10 +821,10 @@ resumeConnCmds c connId =
       queuePendingCommands c srv cmdIds
     connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
 
-cmdProcessExists :: AgentMonad m => AgentClient -> Maybe SMPServer -> m Bool
+cmdProcessExists :: AgentMonad' m => AgentClient -> Maybe SMPServer -> m Bool
 cmdProcessExists c srv = atomically $ TM.member srv (asyncCmdProcesses c)
 
-queuePendingCommands :: AgentMonad m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m ()
+queuePendingCommands :: AgentMonad' m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m ()
 queuePendingCommands c server cmdIds = atomically $ do
   q <- getPendingCommandQ c server
   mapM_ (writeTQueue q) cmdIds
@@ -804,21 +848,21 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
     cmdId <- atomically $ readTQueue cq
     atomically $ beginAgentOperation c AOSndNetwork
     E.try (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
-      Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", ERR . INTERNAL $ show e)
+      Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ INTERNAL $ show e)
       Right cmd -> processCmd (riFast ri) cmdId cmd
   where
     processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m ()
     processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of
-      AClientCommand cmd -> case cmd of
+      AClientCommand (APC _ cmd) -> case cmd of
         NEW enableNtfs (ACM cMode) -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
-          tryCommand . withNextSrv usedSrvs [] $ \srv -> do
+          tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
             (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing srv
             notify $ INV (ACR cMode cReq)
         JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) connInfo -> noServer $ do
           let initUsed = [qServer q]
           usedSrvs <- newTVarIO initUsed
-          tryCommand . withNextSrv usedSrvs initUsed $ \srv -> do
+          tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
             void $ joinConnSrv c userId connId True enableNtfs cReq connInfo srv
             notify OK
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
@@ -887,7 +931,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
           withStore c (`getConn` connId) >>= \case
             SomeConn _ conn@DuplexConnection {} -> a conn
             _ -> internalErr "command requires duplex connection"
-        tryCommand action = withRetryInterval ri $ \loop ->
+        tryCommand action = withRetryInterval ri $ \_ loop ->
           tryError action >>= \case
             Left e
               | temporaryOrHostError e -> retrySndOp c loop
@@ -896,17 +940,8 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
         tryWithLock name = tryCommand . withConnLock c connId name
         internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
         cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
-        notify cmd = atomically $ writeTBQueue subQ (corrId, connId, cmd)
-        withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m ()
-        withNextSrv usedSrvs initUsed action = do
-          used <- readTVarIO usedSrvs
-          srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId used
-          atomically $ do
-            srvs_ <- TM.lookup userId $ smpServers c
-            let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_
-                used' = if null unused then initUsed else srv : used
-            writeTVar usedSrvs $! used'
-          action srvAuth
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd)
 -- ^ ^ ^ async command processing /
 
 enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
@@ -959,7 +994,7 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
     queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
     msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c)
 
-queuePendingMsgs :: AgentMonad m => AgentClient -> SndQueue -> [InternalId] -> m ()
+queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m ()
 queuePendingMsgs c sq msgIds = atomically $ do
   modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
   -- s <- readTVar (msgDeliveryOp c)
@@ -987,13 +1022,14 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
     atomically $ throwWhenNoDelivery c sq
     msgId <- atomically $ readTQueue mq
     atomically $ beginAgentOperation c AOSndNetwork
-    atomically $ endAgentOperation c AOMsgDelivery
+    atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in queuePendingMsgs
     let mId = unId msgId
     E.try (withStore c $ \db -> getPendingMsgData db connId msgId) >>= \case
       Left (e :: E.SomeException) ->
         notify $ MERR mId (INTERNAL $ show e)
-      Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, internalTs}) ->
-        withRetryLock2 ri qLock $ \loop -> do
+      Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, msgRetryState, internalTs}) -> do
+        let ri' = maybe id updateRetryInterval2 msgRetryState ri
+        withRetryLock2 ri' qLock $ \riState loop -> do
           resp <- tryError $ case msgType of
             AM_CONN_INFO -> sendConfirmation c sq msgBody
             _ -> sendAgentMessage c sq msgFlags msgBody
@@ -1004,7 +1040,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                 SMP SMP.QUOTA -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
-                  _ -> retrySndOp c $ loop RISlow
+                  _ -> retrySndMsg RISlow
                 SMP SMP.AUTH -> case msgType of
                   AM_CONN_INFO -> connError msgId NOT_AVAILABLE
                   AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
@@ -1013,7 +1049,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                     -- because the queue must be secured by the time the confirmation or the first HELLO is received
                     | duplexHandshake == Just True -> connErr
                     | otherwise ->
-                      ifM (msgExpired helloTimeout) connErr (retrySndOp c $ loop RIFast)
+                      ifM (msgExpired helloTimeout) connErr (retrySndMsg RIFast)
                     where
                       connErr = case rq_ of
                         -- party initiating connection
@@ -1032,13 +1068,16 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
                   -- the message sending would be retried
                   | temporaryOrHostError e -> do
                     let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
-                    ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndOp c $ loop RIFast)
+                    ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
                   | otherwise -> notifyDel msgId err
               where
                 msgExpired timeoutSel = do
                   msgTimeout <- asks $ timeoutSel . config
                   currentTime <- liftIO getCurrentTime
                   pure $ diffUTCTime currentTime internalTs > msgTimeout
+                retrySndMsg riMode = do
+                  withStore' c $ \db -> updatePendingMsgRIState db connId msgId riState
+                  retrySndOp c $ loop riMode
             Right () -> do
               case msgType of
                 AM_CONN_INFO -> do
@@ -1105,9 +1144,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
   where
     delMsg :: InternalId -> m ()
     delMsg msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId
-    notify :: ACommand 'Agent -> m ()
-    notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
-    notifyDel :: InternalId -> ACommand 'Agent -> m ()
+    notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+    notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd)
+    notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> m ()
     notifyDel msgId cmd = notify cmd >> delMsg msgId
     connError msgId = notifyDel msgId . ERR . CONN
     qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE
@@ -1145,8 +1184,8 @@ switchConnection' c connId = withConnLock c connId "switchConnection" $ do
     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 _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
-      srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
+      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'
@@ -1226,7 +1265,7 @@ deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> [RcvQueue]
 deleteConnQueues c ntf rqs = do
   rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs)
   forM_ (M.assocs rs) $ \case
-    (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, DEL_CONN)
+    (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, APC SAEConn DEL_CONN)
     _ -> pure ()
   pure rs
   where
@@ -1240,7 +1279,7 @@ deleteConnQueues c ntf rqs = do
             | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r
             | otherwise -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq (Just e) $> Right ()
         pure (rq, r')
-    notifyRQ rq e_ = notify ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_)
+    notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
     notify = when ntf . atomically . writeTBQueue (subQ c)
     connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
     connResults = M.map snd . foldl' addResult M.empty
@@ -1278,7 +1317,7 @@ deleteConnections_ getConnections ntf c connIds = do
       let actual = M.size rs
           expected = length connIds
       when (actual /= expected) . atomically $
-        writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
+        writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
 
 getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
 getConnectionServers' c connId = do
@@ -1299,8 +1338,8 @@ connectionStats = \case
   NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
 
 -- | Change servers to be used for creating new queues, in Reader monad
-setSMPServers' :: AgentMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
-setSMPServers' c userId srvs = atomically $ TM.insert userId srvs $ smpServers c
+setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
+setProtocolServers' c userId srvs = atomically $ TM.insert userId srvs (userServers c)
 
 registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
@@ -1494,19 +1533,19 @@ sendNtfConnCommands c cmd = do
       Just (ConnData {enableNtfs}, _) ->
         when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
       _ ->
-        atomically $ writeTBQueue (subQ c) ("", connId, ERR $ INTERNAL "no connection data")
+        atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn $ ERR $ INTERNAL "no connection data")
 
-setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
+setNtfServers' :: AgentMonad' m => AgentClient -> [NtfServer] -> m ()
 setNtfServers' c = atomically . writeTVar (ntfServers c)
 
-activateAgent' :: AgentMonad m => AgentClient -> m ()
-activateAgent' c = do
-  atomically $ writeTVar (agentState c) ASActive
+foregroundAgent' :: AgentMonad' m => AgentClient -> m ()
+foregroundAgent' c = do
+  atomically $ writeTVar (agentState c) ASForeground
   mapM_ activate $ reverse agentOperations
   where
     activate opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = False}
 
-suspendAgent' :: AgentMonad m => AgentClient -> Int -> m ()
+suspendAgent' :: AgentMonad' m => AgentClient -> Int -> m ()
 suspendAgent' c 0 = do
   atomically $ writeTVar (agentState c) ASSuspended
   mapM_ suspend agentOperations
@@ -1531,7 +1570,10 @@ suspendAgent' c@AgentClient {agentState = as} maxDelay = do
 execAgentStoreSQL' :: AgentMonad m => AgentClient -> Text -> m [Text]
 execAgentStoreSQL' c sql = withStore' c (`execSQL` sql)
 
-debugAgentLocks' :: AgentMonad m => AgentClient -> m AgentLocks
+getAgentMigrations' :: AgentMonad m => AgentClient -> m [UpMigration]
+getAgentMigrations' c = map upMigration <$> withStore' c Migrations.getCurrent
+
+debugAgentLocks' :: AgentMonad' m => AgentClient -> m AgentLocks
 debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock = d} = do
   connLocks <- getLocks cs
   srvLocks <- getLocks rs
@@ -1543,26 +1585,7 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock =
 getSMPServer :: AgentMonad m => AgentClient -> UserId -> m SMPServerWithAuth
 getSMPServer c userId = withUserServers c userId pickServer
 
-pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth
-pickServer = \case
-  srv :| [] -> pure srv
-  servers -> do
-    gen <- asks randomServer
-    atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
-
-getNextSMPServer :: AgentMonad m => AgentClient -> UserId -> [SMPServer] -> m SMPServerWithAuth
-getNextSMPServer c userId usedSrvs = withUserServers c userId $ \srvs ->
-  case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
-    Just srvs' -> pickServer srvs'
-    _ -> pickServer srvs
-
-withUserServers :: AgentMonad m => AgentClient -> UserId -> (NonEmpty SMPServerWithAuth -> m a) -> m a
-withUserServers c userId action =
-  atomically (TM.lookup userId $ smpServers c) >>= \case
-    Just srvs -> action srvs
-    _ -> throwError $ INTERNAL "unknown userId - no SMP servers"
-
-subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+subscriber :: AgentMonad' m => AgentClient -> m ()
 subscriber c@AgentClient {msgQ} = forever $ do
   t <- atomically $ readTBQueue msgQ
   agentOperationBracket c AORcvNetwork waitUntilActive $
@@ -1570,19 +1593,71 @@ subscriber c@AgentClient {msgQ} = forever $ do
       Left e -> liftIO $ print e
       Right _ -> return ()
 
-cleanupManager :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
-cleanupManager c = do
-  threadDelay =<< asks (initialCleanupDelay . config)
+cleanupManager :: forall m. AgentMonad' m => AgentClient -> m ()
+cleanupManager c@AgentClient {subQ} = do
+  delay <- asks (initialCleanupDelay . config)
+  liftIO $ threadDelay' delay
   int <- asks (cleanupInterval . config)
   forever $ do
-    void . runExceptT $
+    void . runExceptT $ do
+      deleteConns `catchError` (notify "" . ERR)
+      deleteRcvMsgHashes `catchError` (notify "" . ERR)
+      deleteRcvFilesExpired `catchError` (notify "" . RFERR)
+      deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
+      deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
+      deleteSndFilesExpired `catchError` (notify "" . SFERR)
+      deleteSndFilesDeleted `catchError` (notify "" . SFERR)
+      deleteSndFilesPrefixPaths `catchError` (notify "" . SFERR)
+      deleteExpiredReplicasForDeletion `catchError` (notify "" . SFERR)
+    liftIO $ threadDelay' int
+  where
+    deleteConns =
       withLock (deleteLock c) "cleanupManager" $ do
         void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
-        withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted
-    threadDelay int
-  where
-    notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId)
+        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)
+      forM_ rcvExpired $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+        removePath =<< toFSFilePath p
+        withStore' c (`deleteRcvFile'` dbId)
+    deleteRcvFilesDeleted = do
+      rcvDeleted <- withStore' c getCleanupRcvFilesDeleted
+      forM_ rcvDeleted $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+        removePath =<< toFSFilePath p
+        withStore' c (`deleteRcvFile'` dbId)
+    deleteRcvFilesTmpPaths = do
+      rcvTmpPaths <- withStore' c getCleanupRcvFilesTmpPaths
+      forM_ rcvTmpPaths $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
+        removePath =<< toFSFilePath p
+        withStore' c (`updateRcvFileNoTmpPath` dbId)
+    deleteSndFilesExpired = do
+      sndFilesTTL <- asks $ sndFilesTTL . config
+      sndExpired <- withStore' c (`getSndFilesExpired` sndFilesTTL)
+      forM_ sndExpired $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        forM_ p $ removePath <=< toFSFilePath
+        withStore' c (`deleteSndFile'` dbId)
+    deleteSndFilesDeleted = do
+      sndDeleted <- withStore' c getCleanupSndFilesDeleted
+      forM_ sndDeleted $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        forM_ p $ removePath <=< toFSFilePath
+        withStore' c (`deleteSndFile'` dbId)
+    deleteSndFilesPrefixPaths = do
+      sndPrefixPaths <- withStore' c getCleanupSndFilesPrefixPaths
+      forM_ sndPrefixPaths $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        removePath =<< toFSFilePath p
+        withStore' c (`updateSndFileNoPrefixPath` dbId)
+    deleteExpiredReplicasForDeletion = do
+      rcvFilesTTL <- asks $ rcvFilesTTL . config
+      withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL)
+    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)
@@ -1628,7 +1703,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                               enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICQDelete rcvId
                             _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection"
                         _ -> pure ()
-                      tryError agentClientMsg >>= \case
+                      let encryptedMsgHash = C.sha256Hash encAgentMsg
+                      tryError (agentClientMsg encryptedMsgHash) >>= \case
                         Right (Just (msgId, msgMeta, aMessage)) -> case aMessage of
                           HELLO -> helloMsg >> ackDel msgId
                           REPLY cReq -> replyMsg cReq >> ackDel msgId
@@ -1659,11 +1735,15 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                                     logServer "<--" c srv rId "MSG <MSG>"
                                     notify $ MSG msgMeta msgFlags body
                                   _ -> pure ()
-                            _ -> throwError e
-                        Left e -> throwError e
+                            _ -> checkDuplicateHash e encryptedMsgHash >> ack
+                        Left e -> checkDuplicateHash e encryptedMsgHash >> ack
                       where
-                        agentClientMsg :: m (Maybe (InternalId, MsgMeta, AMessage))
-                        agentClientMsg = withStore c $ \db -> runExceptT $ do
+                        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
                           agentMsgBody <- agentRatchetDecrypt db connId encAgentMsg
                           liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
                             agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
@@ -1675,7 +1755,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}
+                                  rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash, encryptedMsgHash}
                               liftIO $ createRcvMsg db connId rq rcvMsg
                               pure $ Just (internalId, msgMeta, aMessage)
                             _ -> pure Nothing
@@ -1695,7 +1775,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               Just (Right clnt)
                 | sessId == sessionId clnt -> do
                   removeSubscription c connId
-                  writeTBQueue subQ ("", connId, END)
+                  notify' END
                   pure "END"
                 | otherwise -> ignored
               _ -> ignored
@@ -1704,8 +1784,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
           notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED
       where
-        notify :: ACommand 'Agent -> m ()
-        notify msg = atomically $ writeTBQueue subQ ("", connId, msg)
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify = atomically . notify'
+
+        notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM ()
+        notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg)
 
         prohibited :: m ()
         prohibited = notify . ERR $ AGENT A_PROHIBITED
@@ -1786,7 +1869,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   -- this branch is executed by the accepting party in duplexHandshake mode (v2)
                   -- and by the initiating party in v1
                   -- Also see comment where HELLO is sent.
-                  | sndStatus == Active -> atomically $ writeTBQueue subQ ("", connId, CON)
+                  | sndStatus == Active -> notify CON
                   | duplexHandshake == Just True -> enqueueDuplexHello sq
                   | otherwise -> pure ()
                 _ -> pure ()

src/Simplex/Messaging/Agent/Client.hs

@@ -15,16 +15,20 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
-    SMPTestFailure (..),
-    SMPTestStep (..),
+    ProtocolTestFailure (..),
+    ProtocolTestStep (..),
     newAgentClient,
     withConnLock,
     closeAgentClient,
     closeProtocolServerClients,
+    closeXFTPServerClient,
     runSMPServerTest,
+    runXFTPServerTest,
+    getXFTPWorkPath,
     newRcvQueue,
     subscribeQueues,
     getQueueMessage,
@@ -48,6 +52,11 @@ module Simplex.Messaging.Agent.Client
     agentNtfCreateSubscription,
     agentNtfCheckSubscription,
     agentNtfDeleteSubscription,
+    agentXFTPDownloadChunk,
+    agentXFTPNewChunk,
+    agentXFTPUploadChunk,
+    agentXFTPAddRecipients,
+    agentXFTPDeleteChunk,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -72,6 +81,7 @@ module Simplex.Messaging.Agent.Client
     throwWhenNoDelivery,
     beginAgentOperation,
     endAgentOperation,
+    waitUntilForeground,
     suspendSendingAndDatabase,
     suspendOperation,
     notifySuspended,
@@ -79,6 +89,11 @@ module Simplex.Messaging.Agent.Client
     withStore,
     withStore',
     storeError,
+    userServers,
+    pickServer,
+    getNextServer,
+    withUserServers,
+    withNextSrv,
   )
 where
 
@@ -91,6 +106,7 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
+import Crypto.Random (getRandomBytes)
 import Data.Aeson (ToJSON)
 import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
@@ -99,7 +115,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (lefts, partitionEithers)
 import Data.Functor (($>))
-import Data.List (foldl', partition)
+import Data.List (deleteFirstsBy, foldl', partition, (\\))
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -108,10 +124,18 @@ import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text.Encoding
+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import GHC.Generics (Generic)
 import Network.Socket (HostName)
+import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
+import qualified Simplex.FileTransfer.Client as X
+import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, XFTPErrorType (DIGEST))
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
+import Simplex.FileTransfer.Util (uniqueCombine)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
@@ -142,6 +166,7 @@ import Simplex.Messaging.Protocol
     NtfPublicVerifyKey,
     NtfServer,
     ProtoServer,
+    ProtoServerWithAuth (..),
     Protocol (..),
     ProtocolServer (..),
     ProtocolTypeI (..),
@@ -150,7 +175,12 @@ import Simplex.Messaging.Protocol
     RcvMessage (..),
     RcvNtfPublicDhKey,
     SMPMsgMeta (..),
+    SProtocolType (..),
     SndPublicVerifyKey,
+    UserProtocol,
+    XFTPServer,
+    XFTPServerWithAuth,
+    sameSrvAddr',
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
@@ -158,21 +188,27 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import System.Random (randomR)
 import System.Timeout (timeout)
 import UnliftIO (mapConcurrently)
+import UnliftIO.Directory (getTemporaryDirectory)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type ClientVar err msg = TMVar (Either AgentErrorType (ProtocolClient err msg))
+type ClientVar msg = TMVar (Either AgentErrorType (Client msg))
 
-type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
+type SMPClientVar = ClientVar SMP.BrokerMsg
 
-type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
+type NtfClientVar = ClientVar NtfResponse
+
+type XFTPClientVar = TMVar (Either AgentErrorType XFTPClient)
 
 type SMPTransportSession = TransportSession SMP.BrokerMsg
 
 type NtfTransportSession = TransportSession NtfResponse
 
+type XFTPTransportSession = TransportSession FileResponse
+
 data AgentClient = AgentClient
   { active :: TVar Bool,
     rcvQ :: TBQueue (ATransmission 'Client),
@@ -182,6 +218,8 @@ data AgentClient = AgentClient
     smpClients :: TMap SMPTransportSession SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfTransportSession NtfClientVar,
+    xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth),
+    xftpClients :: TMap XFTPTransportSession XFTPClientVar,
     useNetworkConfig :: TVar NetworkConfig,
     subscrConns :: TVar (Set ConnId),
     activeSubs :: TRcvQueues,
@@ -228,7 +266,7 @@ agentOperations = [ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, data
 
 data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int}
 
-data AgentState = ASActive | ASSuspending | ASSuspended
+data AgentState = ASForeground | ASSuspending | ASSuspended
   deriving (Eq, Show)
 
 data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String, delLock :: Maybe String}
@@ -246,7 +284,7 @@ data AgentStatsKey = AgentStatsKey
   deriving (Eq, Ord, Show)
 
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
+newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -256,6 +294,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
+  xftpServers <- newTVar xftp
+  xftpClients <- TM.empty
   useNetworkConfig <- newTVar netCfg
   subscrConns <- newTVar S.empty
   activeSubs <- RQ.empty
@@ -271,7 +311,7 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   msgDeliveryOp <- newTVar $ AgentOpState False 0
   sndNetworkOp <- newTVar $ AgentOpState False 0
   databaseOp <- newTVar $ AgentOpState False 0
-  agentState <- newTVar ASActive
+  agentState <- newTVar ASForeground
   getMsgLocks <- TM.empty
   connLocks <- TM.empty
   deleteLock <- createLock
@@ -290,6 +330,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
         smpClients,
         ntfServers,
         ntfClients,
+        xftpServers,
+        xftpClients,
         useNetworkConfig,
         subscrConns,
         activeSubs,
@@ -320,17 +362,41 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
 agentClientStore :: AgentClient -> SQLiteStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 
-class ProtocolServerClient err msg | msg -> err where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient err msg)
+class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where
+  type Client msg = c | c -> msg
+  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg)
   clientProtocolError :: err -> AgentErrorType
+  closeProtocolServerClient :: Client msg -> IO ()
+  clientServer :: Client msg -> String
+  clientTransportHost :: Client msg -> TransportHost
+  clientSessionTs :: Client msg -> UTCTime
 
 instance ProtocolServerClient ErrorType BrokerMsg where
+  type Client BrokerMsg = ProtocolClient ErrorType BrokerMsg
   getProtocolServerClient = getSMPServerClient
   clientProtocolError = SMP
+  closeProtocolServerClient = closeProtocolClient
+  clientServer = protocolClientServer
+  clientTransportHost = transportHost'
+  clientSessionTs = sessionTs
 
 instance ProtocolServerClient ErrorType NtfResponse where
+  type Client NtfResponse = ProtocolClient ErrorType NtfResponse
   getProtocolServerClient = getNtfServerClient
   clientProtocolError = NTF
+  closeProtocolServerClient = closeProtocolClient
+  clientServer = protocolClientServer
+  clientTransportHost = transportHost'
+  clientSessionTs = sessionTs
+
+instance ProtocolServerClient XFTPErrorType FileResponse where
+  type Client FileResponse = XFTPClient
+  getProtocolServerClient = getXFTPServerClient
+  clientProtocolError = XFTP
+  closeProtocolServerClient = X.closeXFTPClient
+  clientServer = X.xftpClientServer
+  clientTransportHost = X.xftpTransportHost
+  clientSessionTs = X.xftpSessionTs
 
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
@@ -369,15 +435,15 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv,
             atomically $ mapM_ (releaseGetLock c) qs
             unliftIO u $ reconnectServer c tSess
 
-        notifySub :: ConnId -> ACommand 'Agent -> IO ()
-        notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+        notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
+        notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
 reconnectServer :: AgentMonad m => AgentClient -> SMPTransportSession -> m ()
 reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
   where
     tryReconnectSMPClient aId = do
       ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop ->
+      withRetryInterval ri $ \_ loop ->
         reconnectSMPClient c tSess `catchError` const loop
       atomically . removeAsyncAction aId $ reconnections c
 
@@ -397,8 +463,8 @@ reconnectSMPClient c tSess@(_, srv, _) =
       let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
       liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
       mapM_ (throwError . snd) $ listToMaybe tempErrs
-    notifySub :: ConnId -> ACommand 'Agent -> IO ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+    notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
+    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
 getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
@@ -417,7 +483,28 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
     clientDisconnected client = do
       atomically $ TM.delete tSess ntfClients
       incClientStat c userId client "DISCONNECT" ""
-      atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client)
+      atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
+      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+
+getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient
+getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
+  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  atomically (getClientVar tSess xftpClients)
+    >>= either
+      (newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ())
+      (waitForProtocolClient c tSess)
+  where
+    connectClient :: m XFTPClient
+    connectClient = do
+      cfg <- asks $ xftpCfg . config
+      xftpNetworkConfig <- readTVarIO useNetworkConfig
+      liftEitherError (protocolClientError XFTP $ B.unpack $ strEncode srv) (X.getXFTPClient tSess cfg {xftpNetworkConfig} clientDisconnected)
+
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected client = do
+      atomically $ TM.delete tSess xftpClients
+      incClientStat c userId client "DISCONNECT" ""
+      atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
@@ -429,7 +516,7 @@ getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM
       TM.insert tSess var clients
       pure var
 
-waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar err msg -> m (ProtocolClient err msg)
+waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (Client msg)
 waitForProtocolClient c (_, srv, _) clientVar = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
   client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
@@ -440,24 +527,24 @@ waitForProtocolClient c (_, srv, _) clientVar = do
 
 newProtocolClient ::
   forall err msg m.
-  (AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
+  (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) =>
   AgentClient ->
   TransportSession msg ->
-  TMap (TransportSession msg) (ClientVar err msg) ->
-  m (ProtocolClient err msg) ->
+  TMap (TransportSession msg) (ClientVar msg) ->
+  m (Client msg) ->
   (AgentClient -> TransportSession msg -> m ()) ->
-  ClientVar err msg ->
-  m (ProtocolClient err msg)
+  ClientVar msg ->
+  m (Client msg)
 newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
   where
-    tryConnectClient :: (ProtocolClient err msg -> m a) -> m () -> m a
+    tryConnectClient :: (Client msg -> m a) -> m () -> m a
     tryConnectClient successAction retryAction =
       tryError connectClient >>= \r -> case r of
         Right client -> do
           logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
           atomically $ putTMVar clientVar r
           liftIO $ incClientStat c userId client "CLIENT" "OK"
-          atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
+          atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
           successAction client
         Left e -> do
           liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
@@ -472,13 +559,13 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne
     connectAsync :: Int -> m ()
     connectAsync aId = do
       ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop
+      withRetryInterval ri $ \_ loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop
       atomically . removeAsyncAction aId $ asyncClients c
 
-hostEvent :: forall err msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient err msg -> ACommand 'Agent
-hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client
+hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
+hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
 
-getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
+getClientConfig :: AgentMonad' m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
 getClientConfig AgentClient {useNetworkConfig} cfgSel = do
   cfg <- asks $ cfgSel . config
   networkConfig <- readTVarIO useNetworkConfig
@@ -489,6 +576,7 @@ closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
   closeProtocolServerClients c smpClients
   closeProtocolServerClients c ntfClients
+  closeProtocolServerClients c xftpClients
   cancelActions . actions $ reconnections c
   cancelActions . actions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
@@ -519,16 +607,24 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
   where
     k = (server, sndId)
 
-closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar err msg)) -> IO ()
+closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
-  atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient)
-  where
-    cs = clientsSel c
-    closeClient cVar = do
-      NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
-      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
-        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
-        _ -> pure ()
+  atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c)
+
+closeClient :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
+closeClient c clientSel tSess =
+  atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
+
+closeClient_ :: ProtocolServerClient err msg => AgentClient -> ClientVar msg -> IO ()
+closeClient_ c cVar = do
+  NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+  tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+    Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
+    _ -> pure ()
+
+closeXFTPServerClient :: AgentMonad' m => AgentClient -> UserId -> XFTPServer -> FileDigest -> m ()
+closeXFTPServerClient c userId server (FileDigest chunkDigest) =
+  mkTransportSession c userId server chunkDigest >>= liftIO . closeClient c xftpClients
 
 cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
 cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel)
@@ -542,29 +638,29 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur
   where
     newLock = createLock >>= \l -> TM.insert key l locks $> l
 
-withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> m a) -> m a
+withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
 withClient_ c tSess@(userId, srv, _) statCmd action = do
   cl <- getProtocolServerClient c tSess
   (action cl <* stat cl "OK") `catchError` logServerError cl
   where
     stat cl = liftIO . incClientStat c userId cl statCmd
-    logServerError :: ProtocolClient err msg -> AgentErrorType -> m a
+    logServerError :: Client msg -> AgentErrorType -> m a
     logServerError cl e = do
       logServer "<--" c srv "" $ strEncode e
       stat cl $ strEncode e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> m a) -> m a
+withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> m a) -> m a
 withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
   logServer "-->" c srv entId cmdStr
   res <- withClient_ c tSess cmdStr action
   logServer "<--" c srv entId "OK"
   return res
 
-withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
 withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
 
-withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
 withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
 
 withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
@@ -580,6 +676,17 @@ withSMPClient_ c q cmdStr action = do
 withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> m a
 withNtfClient c srv = withLogClient c (0, srv, Nothing)
 
+withXFTPClient ::
+  (AgentMonad m, ProtocolServerClient err msg) =>
+  AgentClient ->
+  (UserId, ProtoServer msg, EntityId) ->
+  ByteString ->
+  (Client msg -> ExceptT (ProtocolClientError err) IO b) ->
+  m b
+withXFTPClient c (userId, srv, entityId) cmdStr action = do
+  tSess <- mkTransportSession c userId srv entityId
+  withLogClient c tSess entityId cmdStr action
+
 liftClient :: (AgentMonad m, Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> m a
 liftClient protocolError_ = liftError . protocolClientError protocolError_
 
@@ -595,24 +702,34 @@ protocolClientError protocolError_ host = \case
   e@PCECryptoError {} -> INTERNAL $ show e
   PCEIOError {} -> BROKER host NETWORK
 
-data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
+data ProtocolTestStep
+  = TSConnect
+  | TSDisconnect
+  | TSCreateQueue
+  | TSSecureQueue
+  | TSDeleteQueue
+  | TSCreateFile
+  | TSUploadFile
+  | TSDownloadFile
+  | TSCompareFile
+  | TSDeleteFile
   deriving (Eq, Show, Generic)
 
-instance ToJSON SMPTestStep where
+instance ToJSON ProtocolTestStep where
   toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TS"
   toJSON = J.genericToJSON . enumJSON $ dropPrefix "TS"
 
-data SMPTestFailure = SMPTestFailure
-  { testStep :: SMPTestStep,
+data ProtocolTestFailure = ProtocolTestFailure
+  { testStep :: ProtocolTestStep,
     testError :: AgentErrorType
   }
   deriving (Eq, Show, Generic)
 
-instance ToJSON SMPTestFailure where
+instance ToJSON ProtocolTestFailure where
   toEncoding = J.genericToEncoding J.defaultOptions
   toJSON = J.genericToJSON J.defaultOptions
 
-runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
+runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure)
 runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- getClientConfig c smpCfg
   C.SignAlg a <- asks $ cmdSignAlg . config
@@ -628,27 +745,74 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
           liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
           liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
         ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
-        incClientStat c userId smp "TEST" "OK"
-        pure $ either Just (const Nothing) r <|> maybe (Just (SMPTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
+        incClientStat c userId smp "SMP_TEST" "OK"
+        pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
       Left e -> pure (Just $ testErr TSConnect e)
   where
     addr = B.unpack $ strEncode srv
-    testErr :: SMPTestStep -> SMPClientError -> SMPTestFailure
-    testErr step = SMPTestFailure step . protocolClientError SMP addr
+    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
+    testErr step = ProtocolTestFailure step . protocolClientError SMP addr
 
-mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
+runXFTPServerTest :: forall m. AgentMonad m => AgentClient -> UserId -> XFTPServerWithAuth -> m (Maybe ProtocolTestFailure)
+runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
+  cfg <- asks $ xftpCfg . config
+  xftpNetworkConfig <- readTVarIO $ useNetworkConfig c
+  workDir <- getXFTPWorkPath
+  filePath <- getTempFilePath workDir
+  rcvPath <- getTempFilePath workDir
+  liftIO $ do
+    let tSess = (userId, srv, Nothing)
+    X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
+      Right xftp -> do
+        (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        createTestChunk filePath
+        digest <- liftIO $ C.sha256Hash <$> B.readFile filePath
+        let file = FileInfo {sndKey, size = chSize, digest}
+            chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
+        r <- runExceptT $ do
+          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
+          liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
+          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
+          rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
+          unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP DIGEST
+          liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
+        ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
+        incClientStat c userId xftp "XFTP_TEST" "OK"
+        pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
+      Left e -> pure (Just $ testErr TSConnect e)
+  where
+    addr = B.unpack $ strEncode srv
+    testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
+    testErr step = ProtocolTestFailure step . protocolClientError XFTP addr
+    chSize :: Integral a => a
+    chSize = kb 256
+    getTempFilePath :: FilePath -> m FilePath
+    getTempFilePath workPath = do
+      ts <- liftIO getCurrentTime
+      let isoTime = formatTime defaultTimeLocale "%Y-%m-%dT%H%M%S.%6q" ts
+      uniqueCombine workPath isoTime
+    createTestChunk :: FilePath -> IO ()
+    createTestChunk fp = B.writeFile fp =<< getRandomBytes chSize
+
+getXFTPWorkPath :: AgentMonad m => m FilePath
+getXFTPWorkPath = do
+  workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
+  maybe getTemporaryDirectory pure workDir
+
+mkTransportSession :: AgentMonad' m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
 mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
 
 mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
 mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
 
-mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSession :: (AgentMonad' m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession
 mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c
 
 mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession
 mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 
-getSessionMode :: AgentMonad m => AgentClient -> m TransportSessionMode
+getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode
 getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
 
 newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
@@ -912,6 +1076,45 @@ agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -
 agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
+agentXFTPDownloadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> m ()
+agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
+  withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec
+
+agentXFTPNewChunk :: AgentMonad m => AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> m NewSndChunkReplica
+agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
+  rKeys <- xftpRcvKeys n
+  (sndKey, replicaKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
+  logServer "-->" c srv "" "FNEW"
+  tSess <- mkTransportSession c userId srv chunkDigest
+  (sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
+  logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId]
+  pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
+
+agentXFTPUploadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> m ()
+agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
+  withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec
+
+agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateSignKey))
+agentXFTPAddRecipients c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} n = do
+  rKeys <- xftpRcvKeys n
+  rIds <- withXFTPClient c (userId, server, chunkDigest) "FADD" $ \xftp -> X.addXFTPRecipients xftp replicaKey fId (L.map fst rKeys)
+  pure $ xftpRcvIdsKeys rIds rKeys
+
+agentXFTPDeleteChunk :: AgentMonad m => AgentClient -> UserId -> DeletedSndChunkReplica -> m ()
+agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} =
+  withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId
+
+xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair)
+xftpRcvKeys n = do
+  rKeys <- liftIO $ replicateM n $ C.generateSignatureKeyPair C.SEd25519
+  case L.nonEmpty rKeys of
+    Just rKeys' -> pure rKeys'
+    _ -> throwError $ INTERNAL "non-positive number of recipients"
+
+xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.ASignatureKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateSignKey)
+xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
+
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
@@ -944,11 +1147,16 @@ agentCbDecrypt dhSecret nonce msg =
 cryptoError :: C.CryptoError -> AgentErrorType
 cryptoError = \case
   C.CryptoLargeMsgError -> CMD LARGE
-  C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
-  C.AESDecryptError -> AGENT A_ENCRYPTION
-  C.CBDecryptError -> AGENT A_ENCRYPTION
+  C.CryptoHeaderError _ -> AGENT A_MESSAGE -- parsing error
   C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
+  C.AESDecryptError -> c DECRYPT_AES
+  C.CBDecryptError -> c DECRYPT_CB
+  C.CERatchetHeader -> c RATCHET_HEADER
+  C.CERatchetTooManySkipped n -> c $ RATCHET_SKIPPED n
+  C.CERatchetEarlierMessage n -> c $ RATCHET_EARLIER n
   e -> INTERNAL $ show e
+  where
+    c = AGENT . A_CRYPTO
 
 endAgentOperation :: AgentClient -> AgentOperation -> STM ()
 endAgentOperation c op = endOperation c op $ case op of
@@ -979,7 +1187,7 @@ suspendOperation c op endedAction = do
 notifySuspended :: AgentClient -> STM ()
 notifySuspended c = do
   -- unsafeIOToSTM $ putStrLn "notifySuspended"
-  writeTBQueue (subQ c) ("", "", SUSPENDED)
+  writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED)
   writeTVar (agentState c) ASSuspended
 
 endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
@@ -1009,6 +1217,9 @@ agentOperationBracket c op check action =
     (\_ -> atomically $ endAgentOperation c op)
     (const action)
 
+waitUntilForeground :: AgentClient -> STM ()
+waitUntilForeground c = unlessM ((ASForeground ==) <$> readTVar (agentState c)) retry
+
 withStore' :: AgentMonad m => AgentClient -> (DB.Connection -> IO a) -> m a
 withStore' c action = withStore c $ fmap Right . action
 
@@ -1041,7 +1252,7 @@ incStat AgentClient {agentStats} n k = do
     Just v -> modifyTVar' v (+ n)
     _ -> newTVar n >>= \v -> TM.insert k v agentStats
 
-incClientStat :: AgentClient -> UserId -> ProtocolClient err msg -> ByteString -> ByteString -> IO ()
+incClientStat :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO ()
 incClientStat c userId pc = incClientStatN c userId pc 1
 
 incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
@@ -1051,8 +1262,43 @@ incServerStat c userId ProtocolServer {host} cmd res = do
   where
     statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
 
-incClientStatN :: AgentClient -> UserId -> ProtocolClient err msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO ()
 incClientStatN c userId pc n cmd res = do
   atomically $ incStat c n statsKey
   where
-    statsKey = AgentStatsKey {userId, host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res}
+    statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res}
+
+userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (NonEmpty (ProtoServerWithAuth p))
+userServers c = case protocolTypeI @p of
+  SPSMP -> smpServers c
+  SPXFTP -> xftpServers c
+
+pickServer :: forall p m. (AgentMonad' m) => NonEmpty (ProtoServerWithAuth p) -> m (ProtoServerWithAuth p)
+pickServer = \case
+  srv :| [] -> pure srv
+  servers -> do
+    gen <- asks randomServer
+    atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
+
+getNextServer :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> [ProtocolServer p] -> m (ProtoServerWithAuth p)
+getNextServer c userId usedSrvs = withUserServers c userId $ \srvs ->
+  case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
+    Just srvs' -> pickServer srvs'
+    _ -> pickServer srvs
+
+withUserServers :: forall p m a. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> m a) -> m a
+withUserServers c userId action =
+  atomically (TM.lookup userId $ userServers c) >>= \case
+    Just srvs -> action srvs
+    _ -> throwError $ INTERNAL "unknown userId - no user servers"
+
+withNextSrv :: forall p m a. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> ((ProtoServerWithAuth p) -> m a) -> m a
+withNextSrv c userId usedSrvs initUsed action = do
+  used <- readTVarIO usedSrvs
+  srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
+  atomically $ do
+    srvs_ <- TM.lookup userId $ userServers c
+    let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_
+        used' = if null unused then initUsed else srv : used
+    writeTVar usedSrvs $! used'
+  action srvAuth

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,9 +11,8 @@
 
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
+    AgentMonad',
     AgentConfig (..),
-    AgentDatabase (..),
-    databaseFile,
     InitialAgentServers (..),
     NetworkConfig (..),
     defaultAgentConfig,
@@ -24,6 +22,7 @@ module Simplex.Messaging.Agent.Env.SQLite
     createAgentStore,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
+    XFTPAgent (..),
   )
 where
 
@@ -31,15 +30,16 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
+import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
+import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
@@ -47,7 +47,7 @@ import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
@@ -57,39 +57,36 @@ import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
 import UnliftIO.STM
 
--- | Agent monad with MonadReader Env and MonadError AgentErrorType
-type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
+type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m)
+
+type AgentMonad m = (AgentMonad' m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty SMPServerWithAuth),
     ntf :: [NtfServer],
+    xftp :: Map UserId (NonEmpty XFTPServerWithAuth),
     netCfg :: NetworkConfig
   }
 
-data AgentDatabase
-  = AgentDB SQLiteStore
-  | AgentDBFile {dbFile :: FilePath, dbKey :: String}
-
-databaseFile :: AgentDatabase -> FilePath
-databaseFile = \case
-  AgentDB SQLiteStore {dbFilePath} -> dbFilePath
-  AgentDBFile {dbFile} -> dbFile
-
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
     cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
-    database :: AgentDatabase,
-    yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
+    xftpCfg :: XFTPClientConfig,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    initialCleanupDelay :: Int,
-    cleanupInterval :: Int,
+    initialCleanupDelay :: Int64,
+    cleanupInterval :: Int64,
+    rcvMsgHashesTTL :: NominalDiffTime,
+    rcvFilesTTL :: NominalDiffTime,
+    sndFilesTTL :: NominalDiffTime,
+    xftpNotifyErrsOnRetry :: Bool,
+    xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
@@ -129,7 +126,7 @@ defaultMessageRetryInterval =
         RetryInterval
           { initialInterval = 60_000000,
             increaseAfter = 60_000000,
-            maxInterval = 1200_000000 -- 20min
+            maxInterval = 3600_000000 -- 1 hour
           }
     }
 
@@ -140,16 +137,20 @@ defaultAgentConfig =
       cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
       tbqSize = 64,
-      database = AgentDBFile {dbFile = "smp-agent.db", dbKey = ""},
-      yesToMigrations = False,
       smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
+      xftpCfg = defaultXFTPClientConfig,
       reconnectInterval = defaultReconnectInterval,
       messageRetryInterval = defaultMessageRetryInterval,
       messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
+      rcvMsgHashesTTL = 30 * nominalDay,
+      rcvFilesTTL = 2 * nominalDay,
+      sndFilesTTL = nominalDay,
+      xftpNotifyErrsOnRetry = True,
+      xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
@@ -173,21 +174,20 @@ data Env = Env
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
     randomServer :: TVar StdGen,
-    ntfSupervisor :: NtfSupervisor
+    ntfSupervisor :: NtfSupervisor,
+    xftpAgent :: XFTPAgent
   }
 
-newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} = do
-  idsDrg <- newTVarIO =<< drgNew
-  store <- case database of
-    AgentDB st -> pure st
-    AgentDBFile {dbFile, dbKey} -> liftIO $ createAgentStore dbFile dbKey yesToMigrations
+newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
+newSMPAgentEnv config@AgentConfig {initialClientId} store = do
+  idsDrg <- newTVarIO =<< liftIO drgNew
   clientCounter <- newTVarIO initialClientId
   randomServer <- newTVarIO =<< liftIO newStdGen
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
-  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
+  xftpAgent <- atomically newXFTPAgent
+  pure Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor, xftpAgent}
 
-createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
+createAgentStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
 createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
 
 data NtfSupervisor = NtfSupervisor
@@ -207,3 +207,19 @@ newNtfSubSupervisor qSize = do
   ntfWorkers <- TM.empty
   ntfSMPWorkers <- TM.empty
   pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
+
+data XFTPAgent = XFTPAgent
+  { -- if set, XFTP file paths will be considered as relative to this directory
+    xftpWorkDir :: TVar (Maybe FilePath),
+    xftpRcvWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    xftpSndWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    xftpDelWorkers :: TMap XFTPServer (TMVar (), Async ())
+  }
+
+newXFTPAgent :: STM XFTPAgent
+newXFTPAgent = do
+  xftpWorkDir <- newTVar Nothing
+  xftpRcvWorkers <- TM.empty
+  xftpSndWorkers <- TM.empty
+  xftpDelWorkers <- TM.empty
+  pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}

src/Simplex/Messaging/Agent/Lock.hs

@@ -14,7 +14,7 @@ createLock :: STM Lock
 createLock = newEmptyTMVar
 {-# INLINE createLock #-}
 
-withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
+withLock :: MonadUnliftIO m => Lock -> String -> m a -> m a
 withLock lock name =
   E.bracket_
     (atomically $ putTMVar lock name)

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -17,22 +17,19 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
   )
 where
 
-import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Except
-import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Data.Bifunctor (first)
-import Data.Fixed (Fixed (MkFixed), Pico)
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
-import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+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 (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
-import qualified Simplex.Messaging.Agent.Protocol as AP
+import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
@@ -40,17 +37,16 @@ import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol (NtfServer, ProtocolServer, SMPServer, sameSrvAddr)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tshow, unlessM)
+import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
 import System.Random (randomR)
-import UnliftIO (async)
+import UnliftIO
 import UnliftIO.Concurrent (forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
-import UnliftIO.STM
 
-runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runNtfSupervisor :: forall m. AgentMonad' m => AgentClient -> m ()
 runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
@@ -156,7 +152,7 @@ processNtfSub c (connId, cmd) = do
         Just (doWork, _) ->
           void . atomically $ tryPutTMVar doWork ()
 
-withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
+withNtfServer :: AgentMonad' m => AgentClient -> (NtfServer -> m ()) -> m ()
 withNtfServer c action = getNtfServer c >>= mapM_ action
 
 runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
@@ -175,7 +171,7 @@ runNtfWorker c srv doWork = do
         Nothing -> noWorkToDo
         Just a@(NtfSubscription {connId}, _, _) -> do
           ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
+          withRetryInterval ri $ \_ loop ->
             processAction a
               `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
@@ -259,7 +255,7 @@ runNtfSMPWorker c srv doWork = do
         Nothing -> noWorkToDo
         Just a@(NtfSubscription {connId}, _, _) -> do
           ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
+          withRetryInterval ri $ \_ loop ->
             processAction a
               `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
@@ -290,23 +286,17 @@ runNtfSMPWorker c srv doWork = do
             mapM_ (disableQueueNotifications c) rq_
             withStore' c $ \db -> deleteNtfSubscription db connId
 
-rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
+rescheduleAction :: AgentMonad' m => TMVar () -> UTCTime -> UTCTime -> m Bool
 rescheduleAction doWork ts actionTs
   | actionTs <= ts = pure False
   | otherwise = do
     void . atomically $ tryTakeTMVar doWork
     void . forkIO $ do
-      threadDelay $ diffInMicros actionTs ts
+      liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
       void . atomically $ tryPutTMVar doWork ()
     pure True
 
-fromPico :: Pico -> Integer
-fromPico (MkFixed i) = i
-
-diffInMicros :: UTCTime -> UTCTime -> Int
-diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
-
-retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
+retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
 retryOnError c name loop done e = do
   logError $ name <> " error: " <> tshow e
   case e of
@@ -325,10 +315,11 @@ workerInternalError c connId internalErrStr = do
   withStore' c $ \db -> setNullNtfSubscriptionAction db connId
   notifyInternalError c connId internalErrStr
 
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
+-- TODO change error
+notifyInternalError :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m ()
+notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
 
-getNtfToken :: AgentMonad m => m (Maybe NtfToken)
+getNtfToken :: AgentMonad' m => m (Maybe NtfToken)
 getNtfToken = do
   tkn <- asks $ ntfTkn . ntfSupervisor
   readTVarIO tkn
@@ -349,17 +340,17 @@ instantNotifications = \case
   Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
   _ -> False
 
-closeNtfSupervisor :: NtfSupervisor -> IO ()
+closeNtfSupervisor :: MonadUnliftIO m => NtfSupervisor -> m ()
 closeNtfSupervisor ns = do
   cancelNtfWorkers_ $ ntfWorkers ns
   cancelNtfWorkers_ $ ntfSMPWorkers ns
 
-cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
+cancelNtfWorkers_ :: MonadUnliftIO m => TMap (ProtocolServer s) (TMVar (), Async ()) -> m ()
 cancelNtfWorkers_ wsVar = do
   ws <- atomically $ stateTVar wsVar (,M.empty)
   mapM_ (uninterruptibleCancel . snd) ws
 
-getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
+getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do
   ntfServers <- readTVarIO $ ntfServers c
   case ntfServers of

src/Simplex/Messaging/Agent/Protocol.hs

@@ -40,13 +40,19 @@ module Simplex.Messaging.Agent.Protocol
     -- * SMP agent protocol types
     ConnInfo,
     ACommand (..),
+    APartyCmd (..),
     ACommandTag (..),
     aCommandTag,
+    aPartyCmdTag,
     ACmd (..),
+    APartyCmdTag (..),
     ACmdTag (..),
     AParty (..),
+    AEntity (..),
     SAParty (..),
+    SAEntity (..),
     APartyI (..),
+    AEntityI (..),
     MsgHash,
     MsgMeta (..),
     ConnectionStats (..),
@@ -87,15 +93,19 @@ module Simplex.Messaging.Agent.Protocol
     ConnectionErrorType (..),
     BrokerErrorType (..),
     SMPAgentError (..),
+    AgentCryptoError (..),
     ATransmission,
     ATransmissionOrError,
     ARawTransmission,
     ConnId,
+    RcvFileId,
+    SndFileId,
     ConfirmationId,
     InvitationId,
     MsgIntegrity (..),
     MsgErrorType (..),
     QueueStatus (..),
+    UserId,
     ACorrId,
     AgentMsgId,
     NotificationsMode (..),
@@ -125,6 +135,8 @@ module Simplex.Messaging.Agent.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Monad (unless)
+import Control.Monad.Except (runExceptT, throwError)
 import Control.Monad.IO.Class
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
@@ -149,10 +161,13 @@ import Data.Time.Clock.System (SystemTime)
 import Data.Time.ISO8601
 import Data.Type.Equality
 import Data.Typeable ()
+import Data.Word (Word32)
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType)
 import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
@@ -161,6 +176,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( AProtocolType,
+    EntityId,
     ErrorType,
     MsgBody,
     MsgFlags,
@@ -207,10 +223,12 @@ e2eEncUserMsgLength = 15856
 type ARawTransmission = (ByteString, ByteString, ByteString)
 
 -- | Parsed SMP agent protocol transmission.
-type ATransmission p = (ACorrId, ConnId, ACommand p)
+type ATransmission p = (ACorrId, EntityId, APartyCmd p)
 
 -- | SMP agent protocol transmission or transmission error.
-type ATransmissionOrError p = (ACorrId, ConnId, Either AgentErrorType (ACommand p))
+type ATransmissionOrError p = (ACorrId, EntityId, Either AgentErrorType (APartyCmd p))
+
+type UserId = Int64
 
 type ACorrId = ByteString
 
@@ -238,96 +256,161 @@ instance APartyI Agent where sAParty = SAgent
 
 instance APartyI Client where sAParty = SClient
 
-data ACmd = forall p. APartyI p => ACmd (SAParty p) (ACommand p)
+data AEntity = AEConn | AERcvFile | AESndFile | AENone
+  deriving (Eq, Show)
+
+data SAEntity :: AEntity -> Type where
+  SAEConn :: SAEntity AEConn
+  SAERcvFile :: SAEntity AERcvFile
+  SAESndFile :: SAEntity AESndFile
+  SAENone :: SAEntity AENone
+
+deriving instance Show (SAEntity e)
+
+deriving instance Eq (SAEntity e)
+
+instance TestEquality SAEntity where
+  testEquality SAEConn SAEConn = Just Refl
+  testEquality SAERcvFile SAERcvFile = Just Refl
+  testEquality SAESndFile SAESndFile = Just Refl
+  testEquality SAENone SAENone = Just Refl
+  testEquality _ _ = Nothing
+
+class AEntityI (e :: AEntity) where sAEntity :: SAEntity e
+
+instance AEntityI AEConn where sAEntity = SAEConn
+
+instance AEntityI AERcvFile where sAEntity = SAERcvFile
+
+instance AEntityI AESndFile where sAEntity = SAESndFile
+
+instance AEntityI AENone where sAEntity = SAENone
+
+data ACmd = forall p e. (APartyI p, AEntityI e) => ACmd (SAParty p) (SAEntity e) (ACommand p e)
 
 deriving instance Show ACmd
 
+data APartyCmd p = forall e. AEntityI e => APC (SAEntity e) (ACommand p e)
+
+instance Eq (APartyCmd p) where
+  APC e cmd == APC e' cmd' = case testEquality e e' of
+    Just Refl -> cmd == cmd'
+    Nothing -> False
+
+deriving instance Show (APartyCmd p)
+
 type ConnInfo = ByteString
 
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
-data ACommand (p :: AParty) where
-  NEW :: Bool -> AConnectionMode -> ACommand Client -- response INV
-  INV :: AConnectionRequestUri -> ACommand Agent
-  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
-  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
-  LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
-  ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  RJCT :: InvitationId -> ACommand Client
-  INFO :: ConnInfo -> ACommand Agent
-  CON :: ACommand Agent -- notification that connection is established
-  SUB :: ACommand Client
-  END :: ACommand Agent
-  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent
-  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent
-  DOWN :: SMPServer -> [ConnId] -> ACommand Agent
-  UP :: SMPServer -> [ConnId] -> ACommand Agent
-  SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent
-  SEND :: MsgFlags -> MsgBody -> ACommand Client
-  MID :: AgentMsgId -> ACommand Agent
-  SENT :: AgentMsgId -> ACommand Agent
-  MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
-  MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent
-  ACK :: AgentMsgId -> ACommand Client
-  SWCH :: ACommand Client
-  OFF :: ACommand Client
-  DEL :: ACommand Client
-  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent
-  DEL_CONN :: ACommand Agent
-  DEL_USER :: Int64 -> ACommand Agent
-  CHK :: ACommand Client
-  STAT :: ConnectionStats -> ACommand Agent
-  OK :: ACommand Agent
-  ERR :: AgentErrorType -> ACommand Agent
-  SUSPENDED :: ACommand Agent
+data ACommand (p :: AParty) (e :: AEntity) where
+  NEW :: Bool -> AConnectionMode -> ACommand Client AEConn -- response INV
+  INV :: AConnectionRequestUri -> ACommand Agent AEConn
+  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client AEConn -- response OK
+  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
+  LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
+  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
+  ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
+  RJCT :: InvitationId -> ACommand Client AEConn
+  INFO :: ConnInfo -> ACommand Agent AEConn
+  CON :: ACommand Agent AEConn -- notification that connection is established
+  SUB :: ACommand Client AEConn
+  END :: ACommand Agent AEConn
+  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
+  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
+  DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
+  UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
+  SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
+  SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
+  MID :: AgentMsgId -> ACommand Agent AEConn
+  SENT :: AgentMsgId -> ACommand Agent AEConn
+  MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
+  MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn
+  ACK :: AgentMsgId -> ACommand Client AEConn
+  SWCH :: ACommand Client AEConn
+  OFF :: ACommand Client AEConn
+  DEL :: ACommand Client AEConn
+  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent AEConn
+  DEL_CONN :: ACommand Agent AEConn
+  DEL_USER :: Int64 -> ACommand Agent AENone
+  CHK :: ACommand Client AEConn
+  STAT :: ConnectionStats -> ACommand Agent AEConn
+  OK :: ACommand Agent AEConn
+  ERR :: AgentErrorType -> ACommand Agent AEConn
+  SUSPENDED :: ACommand Agent AENone
+  -- XFTP commands and responses
+  RFPROG :: Int64 -> Int64 -> ACommand Agent AERcvFile
+  RFDONE :: FilePath -> ACommand Agent AERcvFile
+  RFERR :: AgentErrorType -> ACommand Agent AERcvFile
+  SFPROG :: Int64 -> Int64 -> ACommand Agent AESndFile
+  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile
+  SFERR :: AgentErrorType -> ACommand Agent AESndFile
 
-deriving instance Eq (ACommand p)
+deriving instance Eq (ACommand p e)
 
-deriving instance Show (ACommand p)
+deriving instance Show (ACommand p e)
 
-data ACmdTag = forall p. APartyI p => ACmdTag (SAParty p) (ACommandTag p)
+data ACmdTag = forall p e. (APartyI p, AEntityI e) => ACmdTag (SAParty p) (SAEntity e) (ACommandTag p e)
 
-data ACommandTag (p :: AParty) where
-  NEW_ :: ACommandTag Client
-  INV_ :: ACommandTag Agent
-  JOIN_ :: ACommandTag Client
-  CONF_ :: ACommandTag Agent
-  LET_ :: ACommandTag Client
-  REQ_ :: ACommandTag Agent
-  ACPT_ :: ACommandTag Client
-  RJCT_ :: ACommandTag Client
-  INFO_ :: ACommandTag Agent
-  CON_ :: ACommandTag Agent
-  SUB_ :: ACommandTag Client
-  END_ :: ACommandTag Agent
-  CONNECT_ :: ACommandTag Agent
-  DISCONNECT_ :: ACommandTag Agent
-  DOWN_ :: ACommandTag Agent
-  UP_ :: ACommandTag Agent
-  SWITCH_ :: ACommandTag Agent
-  SEND_ :: ACommandTag Client
-  MID_ :: ACommandTag Agent
-  SENT_ :: ACommandTag Agent
-  MERR_ :: ACommandTag Agent
-  MSG_ :: ACommandTag Agent
-  ACK_ :: ACommandTag Client
-  SWCH_ :: ACommandTag Client
-  OFF_ :: ACommandTag Client
-  DEL_ :: ACommandTag Client
-  DEL_RCVQ_ :: ACommandTag Agent
-  DEL_CONN_ :: ACommandTag Agent
-  DEL_USER_ :: ACommandTag Agent
-  CHK_ :: ACommandTag Client
-  STAT_ :: ACommandTag Agent
-  OK_ :: ACommandTag Agent
-  ERR_ :: ACommandTag Agent
-  SUSPENDED_ :: ACommandTag Agent
+data APartyCmdTag p = forall e. AEntityI e => APCT (SAEntity e) (ACommandTag p e)
 
-deriving instance Eq (ACommandTag p)
+instance Eq (APartyCmdTag p) where
+  APCT e cmd == APCT e' cmd' = case testEquality e e' of
+    Just Refl -> cmd == cmd'
+    Nothing -> False
 
-deriving instance Show (ACommandTag p)
+deriving instance Show (APartyCmdTag p)
 
-aCommandTag :: ACommand p -> ACommandTag p
+data ACommandTag (p :: AParty) (e :: AEntity) where
+  NEW_ :: ACommandTag Client AEConn
+  INV_ :: ACommandTag Agent AEConn
+  JOIN_ :: ACommandTag Client AEConn
+  CONF_ :: ACommandTag Agent AEConn
+  LET_ :: ACommandTag Client AEConn
+  REQ_ :: ACommandTag Agent AEConn
+  ACPT_ :: ACommandTag Client AEConn
+  RJCT_ :: ACommandTag Client AEConn
+  INFO_ :: ACommandTag Agent AEConn
+  CON_ :: ACommandTag Agent AEConn
+  SUB_ :: ACommandTag Client AEConn
+  END_ :: ACommandTag Agent AEConn
+  CONNECT_ :: ACommandTag Agent AENone
+  DISCONNECT_ :: ACommandTag Agent AENone
+  DOWN_ :: ACommandTag Agent AENone
+  UP_ :: ACommandTag Agent AENone
+  SWITCH_ :: ACommandTag Agent AEConn
+  SEND_ :: ACommandTag Client AEConn
+  MID_ :: ACommandTag Agent AEConn
+  SENT_ :: ACommandTag Agent AEConn
+  MERR_ :: ACommandTag Agent AEConn
+  MSG_ :: ACommandTag Agent AEConn
+  ACK_ :: ACommandTag Client AEConn
+  SWCH_ :: ACommandTag Client AEConn
+  OFF_ :: ACommandTag Client AEConn
+  DEL_ :: ACommandTag Client AEConn
+  DEL_RCVQ_ :: ACommandTag Agent AEConn
+  DEL_CONN_ :: ACommandTag Agent AEConn
+  DEL_USER_ :: ACommandTag Agent AENone
+  CHK_ :: ACommandTag Client AEConn
+  STAT_ :: ACommandTag Agent AEConn
+  OK_ :: ACommandTag Agent AEConn
+  ERR_ :: ACommandTag Agent AEConn
+  SUSPENDED_ :: ACommandTag Agent AENone
+  -- XFTP commands and responses
+  RFDONE_ :: ACommandTag Agent AERcvFile
+  RFPROG_ :: ACommandTag Agent AERcvFile
+  RFERR_ :: ACommandTag Agent AERcvFile
+  SFPROG_ :: ACommandTag Agent AESndFile
+  SFDONE_ :: ACommandTag Agent AESndFile
+  SFERR_ :: ACommandTag Agent AESndFile
+
+deriving instance Eq (ACommandTag p e)
+
+deriving instance Show (ACommandTag p e)
+
+aPartyCmdTag :: APartyCmd p -> APartyCmdTag p
+aPartyCmdTag (APC e cmd) = APCT e $ aCommandTag cmd
+
+aCommandTag :: ACommand p e -> ACommandTag p e
 aCommandTag = \case
   NEW {} -> NEW_
   INV _ -> INV_
@@ -363,6 +446,12 @@ aCommandTag = \case
   OK -> OK_
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
+  RFPROG {} -> RFPROG_
+  RFDONE {} -> RFDONE_
+  RFERR {} -> RFERR_
+  SFPROG {} -> SFPROG_
+  SFDONE {} -> SFDONE_
+  SFERR {} -> SFERR_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -811,6 +900,10 @@ connModeT = \case
 -- | SMP agent connection ID.
 type ConnId = ByteString
 
+type RcvFileId = ByteString
+
+type SndFileId = ByteString
+
 type ConfirmationId = ByteString
 
 type InvitationId = ByteString
@@ -1070,6 +1163,8 @@ data AgentErrorType
     SMP {smpErr :: ErrorType}
   | -- | NTF protocol errors forwarded to agent clients
     NTF {ntfErr :: ErrorType}
+  | -- | XFTP protocol errors forwarded to agent clients
+    XFTP {xftpErr :: XFTPErrorType}
   | -- | SMP server errors
     BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
@@ -1147,13 +1242,31 @@ data SMPAgentError
   | -- | incompatible version of SMP client, agent or encryption protocols
     A_VERSION
   | -- | cannot decrypt message
-    A_ENCRYPTION
+    A_CRYPTO {cryptoErr :: AgentCryptoError}
   | -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
+    -- it may also indicate a loss of ratchet synchronization (when only one message is sent via copied ratchet)
     A_DUPLICATE
   | -- | error in the message to add/delete/etc queue in connection
     A_QUEUE {queueErr :: String}
   deriving (Eq, Generic, Read, Show, Exception)
 
+data AgentCryptoError
+  = -- | AES decryption error
+    DECRYPT_AES
+  | -- CryptoBox decryption error
+    DECRYPT_CB
+  | -- | can't decrypt ratchet header, possibly ratchet out of sync due to device change
+    RATCHET_HEADER
+  | -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
+    RATCHET_EARLIER Word32
+  | -- | too many skipped messages
+    RATCHET_SKIPPED Word32
+  deriving (Eq, Generic, Read, Show, Exception)
+
+instance ToJSON AgentCryptoError where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
 instance ToJSON SMPAgentError where
   toJSON = J.genericToJSON $ sumTypeJSON id
   toEncoding = J.genericToEncoding $ sumTypeJSON id
@@ -1164,9 +1277,11 @@ instance StrEncoding AgentErrorType where
       <|> "CONN " *> (CONN <$> parseRead1)
       <|> "SMP " *> (SMP <$> strP)
       <|> "NTF " *> (NTF <$> strP)
+      <|> "XFTP " *> (XFTP <$> strP)
       <|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
       <|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
       <|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
+      <|> "AGENT CRYPTO " *> (AGENT . A_CRYPTO <$> parseRead A.takeByteString)
       <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
@@ -1177,9 +1292,11 @@ instance StrEncoding AgentErrorType where
     CONN e -> "CONN " <> bshow e
     SMP e -> "SMP " <> strEncode e
     NTF e -> "NTF " <> strEncode e
+    XFTP e -> "XFTP " <> strEncode e
     BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
     BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
     BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e
+    AGENT (A_CRYPTO e) -> "AGENT CRYPTO " <> bshow e
     AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
     AGENT e -> "AGENT " <> bshow e
     INTERNAL e -> "INTERNAL " <> bshow e
@@ -1196,6 +1313,8 @@ instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
 
 instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
 
+instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU
+
 -- | SMP agent command and response parser for commands passed via network (only parses binary length)
 networkCommandP :: Parser ACmd
 networkCommandP = commandP A.takeByteString
@@ -1205,46 +1324,61 @@ dbCommandP :: Parser ACmd
 dbCommandP = commandP $ A.take =<< (A.decimal <* "\n")
 
 instance StrEncoding ACmdTag where
-  strEncode (ACmdTag _ cmd) = strEncode cmd
+  strEncode (ACmdTag _ _ cmd) = strEncode cmd
   strP =
     A.takeTill (== ' ') >>= \case
-      "NEW" -> pure $ ACmdTag SClient NEW_
-      "INV" -> pure $ ACmdTag SAgent INV_
-      "JOIN" -> pure $ ACmdTag SClient JOIN_
-      "CONF" -> pure $ ACmdTag SAgent CONF_
-      "LET" -> pure $ ACmdTag SClient LET_
-      "REQ" -> pure $ ACmdTag SAgent REQ_
-      "ACPT" -> pure $ ACmdTag SClient ACPT_
-      "RJCT" -> pure $ ACmdTag SClient RJCT_
-      "INFO" -> pure $ ACmdTag SAgent INFO_
-      "CON" -> pure $ ACmdTag SAgent CON_
-      "SUB" -> pure $ ACmdTag SClient SUB_
-      "END" -> pure $ ACmdTag SAgent END_
-      "CONNECT" -> pure $ ACmdTag SAgent CONNECT_
-      "DISCONNECT" -> pure $ ACmdTag SAgent DISCONNECT_
-      "DOWN" -> pure $ ACmdTag SAgent DOWN_
-      "UP" -> pure $ ACmdTag SAgent UP_
-      "SWITCH" -> pure $ ACmdTag SAgent SWITCH_
-      "SEND" -> pure $ ACmdTag SClient SEND_
-      "MID" -> pure $ ACmdTag SAgent MID_
-      "SENT" -> pure $ ACmdTag SAgent SENT_
-      "MERR" -> pure $ ACmdTag SAgent MERR_
-      "MSG" -> pure $ ACmdTag SAgent MSG_
-      "ACK" -> pure $ ACmdTag SClient ACK_
-      "SWCH" -> pure $ ACmdTag SClient SWCH_
-      "OFF" -> pure $ ACmdTag SClient OFF_
-      "DEL" -> pure $ ACmdTag SClient DEL_
-      "DEL_RCVQ" -> pure $ ACmdTag SAgent DEL_RCVQ_
-      "DEL_CONN" -> pure $ ACmdTag SAgent DEL_CONN_
-      "DEL_USER" -> pure $ ACmdTag SAgent DEL_USER_
-      "CHK" -> pure $ ACmdTag SClient CHK_
-      "STAT" -> pure $ ACmdTag SAgent STAT_
-      "OK" -> pure $ ACmdTag SAgent OK_
-      "ERR" -> pure $ ACmdTag SAgent ERR_
-      "SUSPENDED" -> pure $ ACmdTag SAgent SUSPENDED_
+      "NEW" -> t NEW_
+      "INV" -> ct INV_
+      "JOIN" -> t JOIN_
+      "CONF" -> ct CONF_
+      "LET" -> t LET_
+      "REQ" -> ct REQ_
+      "ACPT" -> t ACPT_
+      "RJCT" -> t RJCT_
+      "INFO" -> ct INFO_
+      "CON" -> ct CON_
+      "SUB" -> t SUB_
+      "END" -> ct END_
+      "CONNECT" -> nt CONNECT_
+      "DISCONNECT" -> nt DISCONNECT_
+      "DOWN" -> nt DOWN_
+      "UP" -> nt UP_
+      "SWITCH" -> ct SWITCH_
+      "SEND" -> t SEND_
+      "MID" -> ct MID_
+      "SENT" -> ct SENT_
+      "MERR" -> ct MERR_
+      "MSG" -> ct MSG_
+      "ACK" -> t ACK_
+      "SWCH" -> t SWCH_
+      "OFF" -> t OFF_
+      "DEL" -> t DEL_
+      "DEL_RCVQ" -> ct DEL_RCVQ_
+      "DEL_CONN" -> ct DEL_CONN_
+      "DEL_USER" -> nt DEL_USER_
+      "CHK" -> t CHK_
+      "STAT" -> ct STAT_
+      "OK" -> ct OK_
+      "ERR" -> ct ERR_
+      "SUSPENDED" -> nt SUSPENDED_
+      "RFPROG" -> at SAERcvFile RFPROG_
+      "RFDONE" -> at SAERcvFile RFDONE_
+      "RFERR" -> at SAERcvFile RFERR_
+      "SFPROG" -> at SAESndFile SFPROG_
+      "SFDONE" -> at SAESndFile SFDONE_
+      "SFERR" -> at SAESndFile SFERR_
       _ -> fail "bad ACmdTag"
+    where
+      t = pure . ACmdTag SClient SAEConn
+      at e = pure . ACmdTag SAgent e
+      ct = at SAEConn
+      nt = at SAENone
 
-instance APartyI p => StrEncoding (ACommandTag p) where
+instance APartyI p => StrEncoding (APartyCmdTag p) where
+  strEncode (APCT _ cmd) = strEncode cmd
+  strP = (\(ACmdTag _ e t) -> checkParty $ APCT e t) <$?> strP
+
+instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
   strEncode = \case
     NEW_ -> "NEW"
     INV_ -> "INV"
@@ -1280,20 +1414,31 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     OK_ -> "OK"
     ERR_ -> "ERR"
     SUSPENDED_ -> "SUSPENDED"
-  strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
+    RFPROG_ -> "RFPROG"
+    RFDONE_ -> "RFDONE"
+    RFERR_ -> "RFERR"
+    SFPROG_ -> "SFPROG"
+    SFDONE_ -> "SFDONE"
+    SFERR_ -> "SFERR"
+  strP = (\(APCT _ t) -> checkEntity t) <$?> strP
 
 checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
 checkParty x = case testEquality (sAParty @p) (sAParty @p') of
   Just Refl -> Right x
   Nothing -> Left "bad party"
 
+checkEntity :: forall t e e'. (AEntityI e, AEntityI e') => t e' -> Either String (t e)
+checkEntity x = case testEquality (sAEntity @e) (sAEntity @e') of
+  Just Refl -> Right x
+  Nothing -> Left "bad entity"
+
 -- | SMP agent command and response parser
 commandP :: Parser ByteString -> Parser ACmd
 commandP binaryP =
   strP
     >>= \case
-      ACmdTag SClient cmd ->
-        ACmd SClient <$> case cmd of
+      ACmdTag SClient e cmd ->
+        ACmd SClient e <$> case cmd of
           NEW_ -> s (NEW <$> strP_ <*> strP)
           JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> binaryP)
           LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
@@ -1306,8 +1451,8 @@ commandP binaryP =
           OFF_ -> pure OFF
           DEL_ -> pure DEL
           CHK_ -> pure CHK
-      ACmdTag SAgent cmd ->
-        ACmd SAgent <$> case cmd of
+      ACmdTag SAgent e cmd ->
+        ACmd SAgent e <$> case cmd of
           INV_ -> s (INV <$> strP)
           CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
           REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
@@ -1330,11 +1475,23 @@ commandP binaryP =
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
+          RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
+          RFDONE_ -> s (RFDONE <$> strP)
+          RFERR_ -> s (RFERR <$> strP)
+          SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal)
+          SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP)
+          SFERR_ -> s (SFERR <$> strP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
     connections :: Parser [ConnId]
     connections = strP `A.sepBy'` A.char ','
+    sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile)
+    sfDone t =
+      let ds = T.splitOn fdSeparator t
+       in case ds of
+            [] -> Left "no sender file description"
+            sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds
     msgMetaP = do
       integrity <- strP
       recipient <- " R=" *> partyMeta A.decimal
@@ -1347,7 +1504,7 @@ parseCommand :: ByteString -> Either AgentErrorType ACmd
 parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
 
 -- | Serialize SMP agent command.
-serializeCommand :: ACommand p -> ByteString
+serializeCommand :: ACommand p e -> ByteString
 serializeCommand = \case
   NEW ntfs cMode -> s (NEW_, ntfs, cMode)
   INV cReq -> s (INV_, cReq)
@@ -1383,6 +1540,12 @@ serializeCommand = \case
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
+  RFPROG rcvd total -> s (RFPROG_, rcvd, total)
+  RFDONE fPath -> s (RFDONE_, fPath)
+  RFERR e -> s (RFERR_, e)
+  SFPROG sent total -> s (SFPROG_, sent, total)
+  SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)]
+  SFERR e -> s (SFERR_, e)
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
@@ -1390,6 +1553,7 @@ serializeCommand = \case
     showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
     connections = B.intercalate "," . map strEncode
+    sfDone sd rds = B.intercalate fdSeparator $ strEncode sd : map strEncode rds
     serializeMsgMeta :: MsgMeta -> ByteString
     serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
       B.unwords
@@ -1415,60 +1579,65 @@ tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h
 
 -- | Send SMP agent protocol command (or response) to TCP connection.
 tPut :: (Transport c, MonadIO m) => c -> ATransmission p -> m ()
-tPut h (corrId, connId, command) =
-  liftIO $ tPutRaw h (corrId, connId, serializeCommand command)
+tPut h (corrId, connId, APC _ cmd) =
+  liftIO $ tPutRaw h (corrId, connId, serializeCommand cmd)
 
 -- | Receive client and agent transmissions from TCP connection.
 tGet :: forall c m p. (Transport c, MonadIO m) => SAParty p -> c -> m (ATransmissionOrError p)
 tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
   where
     tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p)
-    tParseLoadBody t@(corrId, connId, command) = do
+    tParseLoadBody t@(corrId, entId, command) = do
       let cmd = parseCommand command >>= fromParty >>= tConnId t
       fullCmd <- either (return . Left) cmdWithMsgBody cmd
-      return (corrId, connId, fullCmd)
+      return (corrId, entId, fullCmd)
 
-    fromParty :: ACmd -> Either AgentErrorType (ACommand p)
-    fromParty (ACmd (p :: p1) cmd) = case testEquality party p of
-      Just Refl -> Right cmd
+    fromParty :: ACmd -> Either AgentErrorType (APartyCmd p)
+    fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of
+      Just Refl -> Right $ APC e cmd
       _ -> Left $ CMD PROHIBITED
 
-    tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
-    tConnId (_, connId, _) cmd = case cmd of
-      -- NEW, JOIN and ACPT have optional connId
-      NEW {} -> Right cmd
-      JOIN {} -> Right cmd
-      ACPT {} -> Right cmd
-      -- ERROR response does not always have connId
-      ERR _ -> Right cmd
-      CONNECT {} -> Right cmd
-      DISCONNECT {} -> Right cmd
-      DOWN {} -> Right cmd
-      UP {} -> Right cmd
-      -- other responses must have connId
-      _
-        | B.null connId -> Left $ CMD NO_CONN
-        | otherwise -> Right cmd
+    tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p)
+    tConnId (_, entId, _) (APC e cmd) =
+      APC e <$> case cmd of
+        -- NEW, JOIN and ACPT have optional connection ID
+        NEW {} -> Right cmd
+        JOIN {} -> Right cmd
+        ACPT {} -> Right cmd
+        -- ERROR response does not always have connection ID
+        ERR _ -> Right cmd
+        CONNECT {} -> Right cmd
+        DISCONNECT {} -> Right cmd
+        DOWN {} -> Right cmd
+        UP {} -> Right cmd
+        SUSPENDED {} -> Right cmd
+        -- other responses must have connection ID
+        _
+          | B.null entId -> Left $ CMD NO_CONN
+          | otherwise -> Right cmd
 
-    cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
-    cmdWithMsgBody = \case
-      SEND msgFlags body -> SEND msgFlags <$$> getBody body
-      MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-      JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
-      CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
-      LET confId cInfo -> LET confId <$$> getBody cInfo
-      REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
-      ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
-      INFO cInfo -> INFO <$$> getBody cInfo
-      cmd -> pure $ Right cmd
+    cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p))
+    cmdWithMsgBody (APC e cmd) =
+      APC e <$$> case cmd of
+        SEND msgFlags body -> SEND msgFlags <$$> getBody body
+        MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
+        JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
+        CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
+        LET confId cInfo -> LET confId <$$> getBody cInfo
+        REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
+        ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
+        INFO cInfo -> INFO <$$> getBody cInfo
+        _ -> pure $ Right cmd
 
     getBody :: ByteString -> m (Either AgentErrorType ByteString)
     getBody binary =
       case B.unpack binary of
         ':' : body -> return . Right $ B.pack body
         str -> case readMaybe str :: Maybe Int of
-          Just size -> liftIO $ do
-            body <- cGet h size
-            s <- getLn h
-            return $ if B.null s then Right body else Left $ CMD SIZE
+          Just size -> runExceptT $ do
+            body <- liftIO $ cGet h size
+            unless (B.length body == size) $ throwError $ CMD SIZE
+            s <- liftIO $ getLn h
+            unless (B.null s) $ throwError $ CMD SIZE
+            pure body
           Nothing -> return . Left $ CMD SYNTAX

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -1,26 +1,30 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Agent.RetryInterval
   ( RetryInterval (..),
     RetryInterval2 (..),
     RetryIntervalMode (..),
+    RI2State (..),
     withRetryInterval,
     withRetryLock2,
+    updateRetryInterval2,
   )
 where
 
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (forkIO)
 import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Simplex.Messaging.Util (whenM)
+import Data.Int (Int64)
+import Simplex.Messaging.Util (threadDelay', whenM)
 import UnliftIO.STM
 
 data RetryInterval = RetryInterval
-  { initialInterval :: Int,
-    increaseAfter :: Int,
-    maxInterval :: Int
+  { initialInterval :: Int64,
+    increaseAfter :: Int64,
+    maxInterval :: Int64
   }
 
 data RetryInterval2 = RetryInterval2
@@ -28,27 +32,40 @@ data RetryInterval2 = RetryInterval2
     riFast :: RetryInterval
   }
 
-data RetryIntervalMode = RISlow | RIFast
-  deriving (Eq)
+data RI2State = RI2State
+  { slowInterval :: Int64,
+    fastInterval :: Int64
+  }
+  deriving (Show)
 
-withRetryInterval :: forall m. MonadIO m => RetryInterval -> (m () -> m ()) -> m ()
+updateRetryInterval2 :: RI2State -> RetryInterval2 -> RetryInterval2
+updateRetryInterval2 RI2State {slowInterval, fastInterval} RetryInterval2 {riSlow, riFast} =
+  RetryInterval2
+    { riSlow = riSlow {initialInterval = slowInterval, increaseAfter = 0},
+      riFast = riFast {initialInterval = fastInterval, increaseAfter = 0}
+    }
+
+data RetryIntervalMode = RISlow | RIFast
+  deriving (Eq, Show)
+
+withRetryInterval :: forall m a. MonadIO m => RetryInterval -> (Int64 -> m a -> m a) -> m a
 withRetryInterval ri action = callAction 0 $ initialInterval ri
   where
-    callAction :: Int -> Int -> m ()
-    callAction elapsed delay = action loop
+    callAction :: Int64 -> Int64 -> m a
+    callAction elapsed delay = action delay loop
       where
         loop = do
-          liftIO $ threadDelay delay
+          liftIO $ threadDelay' delay
           let elapsed' = elapsed + delay
           callAction elapsed' $ nextDelay elapsed' delay ri
 
 -- This function allows action to toggle between slow and fast retry intervals.
-withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> ((RetryIntervalMode -> m ()) -> m ()) -> m ()
+withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
 withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
   callAction (0, initialInterval riSlow) (0, initialInterval riFast)
   where
-    callAction :: (Int, Int) -> (Int, Int) -> m ()
-    callAction slow fast = action loop
+    callAction :: (Int64, Int64) -> (Int64, Int64) -> m ()
+    callAction slow fast = action (RI2State (snd slow) (snd fast)) loop
       where
         loop = \case
           RISlow -> run slow riSlow (`callAction` fast)
@@ -56,17 +73,18 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
         run (elapsed, delay) ri call = do
           wait delay
           let elapsed' = elapsed + delay
-          call (elapsed', nextDelay elapsed' delay ri)
+              delay' = nextDelay elapsed' delay ri
+          call (elapsed', delay')
         wait delay = do
           waiting <- newTVarIO True
           _ <- liftIO . forkIO $ do
-            threadDelay delay
+            threadDelay' delay
             atomically $ whenM (readTVar waiting) $ void $ tryPutTMVar lock ()
           atomically $ do
             takeTMVar lock
             writeTVar waiting False
 
-nextDelay :: Int -> Int -> RetryInterval -> Int
+nextDelay :: Int64 -> Int64 -> RetryInterval -> Int64
 nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
   if elapsed < increaseAfter || delay == maxInterval
     then delay

src/Simplex/Messaging/Agent/Server.hs

@@ -21,6 +21,7 @@ import Data.Text.Encoding (decodeUtf8)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
 import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
 import Simplex.Messaging.Util (bshow)
@@ -31,18 +32,17 @@ import UnliftIO.STM
 -- | Runs an SMP agent as a TCP service using passed configuration.
 --
 -- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
-runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgent t cfg initServers = do
-  started <- newEmptyTMVarIO
-  runSMPAgentBlocking t started cfg initServers
+runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> m ()
+runSMPAgent t cfg initServers store =
+  runSMPAgentBlocking t cfg initServers store =<< newEmptyTMVarIO
 
 -- | Runs an SMP agent as a TCP service using passed configuration with signalling.
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
-  runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> TMVar Bool -> m ()
+runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store started = do
+  liftIO (newSMPAgentEnv cfg store) >>= runReaderT (smpAgent t)
   where
     smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
     smpAgent _ = do
@@ -60,10 +60,10 @@ connectClient h c = race_ (send h c) (receive h c)
 
 receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
 receive h c@AgentClient {rcvQ, subQ} = forever $ do
-  (corrId, connId, cmdOrErr) <- tGet SClient h
+  (corrId, entId, cmdOrErr) <- tGet SClient h
   case cmdOrErr of
-    Right cmd -> write rcvQ (corrId, connId, cmd)
-    Left e -> write subQ (corrId, connId, ERR e)
+    Right cmd -> write rcvQ (corrId, entId, cmd)
+    Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e)
   where
     write :: TBQueue (ATransmission p) -> ATransmission p -> m ()
     write q t = do
@@ -77,5 +77,5 @@ send h c@AgentClient {subQ} = forever $ do
   logClient c "<--" t
 
 logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
-logClient AgentClient {clientId} dir (corrId, connId, cmd) = do
+logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do
   logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]

src/Simplex/Messaging/Agent/Store.hs

@@ -24,6 +24,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.RetryInterval (RI2State)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
 import Simplex.Messaging.Encoding.String
@@ -264,8 +265,6 @@ data PendingCommand = PendingCommand
 
 data AgentCmdType = ACClient | ACInternal
 
-type UserId = Int64
-
 instance StrEncoding AgentCmdType where
   strEncode = \case
     ACClient -> "CLIENT"
@@ -277,20 +276,20 @@ instance StrEncoding AgentCmdType where
       _ -> fail "bad AgentCmdType"
 
 data AgentCommand
-  = AClientCommand (ACommand 'Client)
+  = AClientCommand (APartyCmd 'Client)
   | AInternalCommand InternalCommand
 
 instance StrEncoding AgentCommand where
   strEncode = \case
-    AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
+    AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd)
     AInternalCommand cmd -> strEncode (ACInternal, cmd)
   strP =
     strP_ >>= \case
-      ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
+      ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP)
       ACInternal -> AInternalCommand <$> strP
 
 data AgentCommandTag
-  = AClientCommandTag (ACommandTag 'Client)
+  = AClientCommandTag (APartyCmdTag 'Client)
   | AInternalCommandTag InternalCommandTag
   deriving (Show)
 
@@ -363,7 +362,7 @@ instance StrEncoding InternalCommandTag where
 
 agentCommandTag :: AgentCommand -> AgentCommandTag
 agentCommandTag = \case
-  AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
+  AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd
   AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
 
 internalCmdTag :: InternalCommand -> InternalCommandTag
@@ -429,7 +428,8 @@ data RcvMsgData = RcvMsgData
     msgBody :: MsgBody,
     internalRcvId :: InternalRcvId,
     internalHash :: MsgHash,
-    externalPrevSndHash :: MsgHash
+    externalPrevSndHash :: MsgHash,
+    encryptedMsgHash :: MsgHash
   }
 
 data RcvMsg = RcvMsg
@@ -455,6 +455,7 @@ data PendingMsgData = PendingMsgData
     msgType :: AgentMessageType,
     msgFlags :: MsgFlags,
     msgBody :: MsgBody,
+    msgRetryState :: Maybe RI2State,
     internalTs :: InternalTs
   }
   deriving (Show)
@@ -535,4 +536,10 @@ data StoreError
     SEX3dhKeysNotFound
   | -- | Used to wrap agent errors inside store operations to avoid race conditions
     SEAgentError AgentErrorType
+  | -- | XFTP Server not found.
+    SEXFTPServerNotFound
+  | -- | XFTP File not found.
+    SEFileNotFound
+  | -- | XFTP Deleted snd chunk replica not found.
+    SEDeletedSndChunkReplicaNotFound
   deriving (Eq, Show, Exception)

src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs

@@ -1,25 +1,38 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Migrations
   ( Migration (..),
+    MigrationsToRun (..),
+    MTRError (..),
+    DownMigration (..),
     app,
     initialize,
     get,
     run,
+    getCurrent,
+    mtrErrorDescription,
+    -- for unit tests
+    migrationsToRun,
+    toDownMigration,
   )
 where
 
 import Control.Monad (forM_, when)
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as J
 import Data.List (intercalate, sortOn)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as M
+import Data.Maybe (isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (getCurrentTime)
@@ -27,6 +40,7 @@ import Database.SQLite.Simple (Connection, Only (..), Query (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
+import GHC.Generics (Generic)
 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
@@ -41,67 +55,127 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
 
-data Migration = Migration {name :: String, up :: Text}
-  deriving (Show)
+data Migration = Migration {name :: String, up :: Text, down :: Maybe Text}
+  deriving (Eq, Show)
 
-schemaMigrations :: [(String, Query)]
+schemaMigrations :: [(String, Query, Maybe Query)]
 schemaMigrations =
-  [ ("20220101_initial", m20220101_initial),
-    ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
-    ("20220322_notifications", m20220322_notifications),
-    ("20220607_v2", m20220608_v2),
-    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
-    ("m20220811_onion_hosts", m20220811_onion_hosts),
-    ("m20220817_connection_ntfs", m20220817_connection_ntfs),
-    ("m20220905_commands", m20220905_commands),
-    ("m20220915_connection_queues", m20220915_connection_queues),
-    ("m20230110_users", m20230110_users),
-    ("m20230117_fkey_indexes", m20230117_fkey_indexes),
-    ("m20230120_delete_errors", m20230120_delete_errors),
-    ("m20230217_server_key_hash", m20230217_server_key_hash)
+  [ ("20220101_initial", m20220101_initial, Nothing),
+    ("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing),
+    ("20220322_notifications", m20220322_notifications, Nothing),
+    ("20220607_v2", m20220608_v2, Nothing),
+    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing),
+    ("m20220811_onion_hosts", m20220811_onion_hosts, Nothing),
+    ("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing),
+    ("m20220905_commands", m20220905_commands, Nothing),
+    ("m20220915_connection_queues", m20220915_connection_queues, Nothing),
+    ("m20230110_users", m20230110_users, Nothing),
+    ("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
+    ("m20230120_delete_errors", m20230120_delete_errors, Nothing),
+    ("m20230217_server_key_hash", m20230217_server_key_hash, Nothing),
+    ("m20230223_files", m20230223_files, Just down_m20230223_files),
+    ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
+    ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
+    ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
+    ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes)
   ]
 
 -- | The list of migrations in ascending order by date
 app :: [Migration]
 app = sortOn name $ map migration schemaMigrations
   where
-    migration (name, query) = Migration {name = name, up = fromQuery query}
+    migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
 
-get :: Connection -> [Migration] -> IO (Either String [Migration])
-get conn migrations =
-  migrationsToRun migrations . map fromOnly
-    <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
+get :: Connection -> [Migration] -> IO (Either MTRError MigrationsToRun)
+get db migrations = migrationsToRun migrations <$> getCurrent db
 
-run :: Connection -> [Migration] -> IO ()
-run conn ms = forM_ ms $ \Migration {name, up} -> do
-  when (name == "m20220811_onion_hosts") updateServers
-  DB.withImmediateTransaction conn $ insert name >> execSQL up
+getCurrent :: Connection -> IO [Migration]
+getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
   where
-    insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
-    execSQL = SQLite3.exec $ DB.connectionHandle conn
-    updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
-      DB.withImmediateTransaction conn $
-        let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
-         in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
+    toMigration (name, down) = Migration {name, up = "", down}
+
+run :: Connection -> MigrationsToRun -> IO ()
+run db = \case
+  MTRUp [] -> pure ()
+  MTRUp ms -> mapM_ runUp ms >> execSQL "VACUUM;"
+  MTRDown ms -> mapM_ runDown $ reverse ms
+  MTRNone -> pure ()
+  where
+    runUp Migration {name, up, down} = do
+      when (name == "m20220811_onion_hosts") updateServers
+      DB.withImmediateTransaction db $ insert >> execSQL up
+      where
+        insert = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
+        updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
+          DB.withImmediateTransaction db $
+            let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
+             in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
+    runDown DownMigration {downName, downQuery} = do
+      DB.withImmediateTransaction db $ do
+        execSQL downQuery
+        DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
+    execSQL = SQLite3.exec $ DB.connectionHandle db
 
 initialize :: Connection -> IO ()
-initialize conn =
-  DB.execute_
-    conn
-    [sql|
-      CREATE TABLE IF NOT EXISTS migrations (
-        name TEXT NOT NULL,
-        ts TEXT NOT NULL,
-        PRIMARY KEY (name)
-      );
-    |]
+initialize db = do
+  cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')"
+  case cs of
+    [] -> createMigrations
+    _ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
+  where
+    createMigrations =
+      DB.execute_
+        db
+        [sql|
+          CREATE TABLE IF NOT EXISTS migrations (
+            name TEXT NOT NULL,
+            ts TEXT NOT NULL,
+            down TEXT,
+            PRIMARY KEY (name)
+          );
+        |]
 
-migrationsToRun :: [Migration] -> [String] -> Either String [Migration]
-migrationsToRun appMs [] = Right appMs
-migrationsToRun [] dbMs = Left $ "database version is newer than the app: " <> intercalate ", " dbMs
+data DownMigration = DownMigration {downName :: String, downQuery :: Text}
+  deriving (Eq, Show)
+
+toDownMigration :: Migration -> Maybe DownMigration
+toDownMigration Migration {name, down} = DownMigration name <$> down
+
+data MigrationsToRun = MTRUp [Migration] | MTRDown [DownMigration] | MTRNone
+  deriving (Eq, Show)
+
+data MTRError
+  = MTRENoDown {dbMigrations :: [String]}
+  | MTREDifferent {appMigration :: String, dbMigration :: String}
+  deriving (Eq, Show, Generic)
+
+instance ToJSON MTRError where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "MTRE"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "MTRE"
+
+mtrErrorDescription :: MTRError -> String
+mtrErrorDescription = \case
+  MTRENoDown ms -> "database version is newer than the app, but no down migration for: " <> intercalate ", " ms
+  MTREDifferent a d -> "different migration in the app/database: " <> a <> " / " <> d
+
+migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun
+migrationsToRun [] [] = Right MTRNone
+migrationsToRun appMs [] = Right $ MTRUp appMs
+migrationsToRun [] dbMs
+  | length dms == length dbMs = Right $ MTRDown dms
+  | otherwise = Left $ MTRENoDown $ mapMaybe nameNoDown dbMs
+  where
+    dms = mapMaybe toDownMigration dbMs
+    nameNoDown m = if isNothing (down m) then Just $ name m else Nothing
 migrationsToRun (a : as) (d : ds)
-  | name a == d = migrationsToRun as ds
-  | otherwise = Left $ "different migration in the app/database: " <> name a <> " / " <> d
+  | name a == name d = migrationsToRun as ds
+  | otherwise = Left $ MTREDifferent (name a) (name d)

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230223_files :: Query
+m20230223_files =
+  [sql|
+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);
+|]
+
+-- this is for tests, older versions do not support down migrations
+down_m20230223_files :: Query
+down_m20230223_files =
+  [sql|
+DROP INDEX idx_rcv_file_chunk_replicas_xftp_server_id;
+DROP INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id;
+DROP TABLE rcv_file_chunk_replicas;
+
+DROP INDEX idx_rcv_file_chunks_rcv_file_id;
+DROP TABLE rcv_file_chunks;
+
+DROP INDEX idx_rcv_files_user_id;
+DROP TABLE rcv_files;
+
+DROP TABLE xftp_servers;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230320_retry_state.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230320_retry_state :: Query
+m20230320_retry_state =
+  [sql|
+ALTER TABLE snd_messages ADD COLUMN retry_int_slow INTEGER;
+ALTER TABLE snd_messages ADD COLUMN retry_int_fast INTEGER;
+|]
+
+-- this is for tests, older versions do not support down migrations
+down_m20230320_retry_state :: Query
+down_m20230320_retry_state =
+  [sql|
+ALTER TABLE snd_messages DROP COLUMN retry_int_fast;
+ALTER TABLE snd_messages DROP COLUMN retry_int_slow;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230401_snd_files :: Query
+m20230401_snd_files =
+  [sql|
+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);
+|]
+
+down_m20230401_snd_files :: Query
+down_m20230401_snd_files =
+  [sql|
+DROP INDEX idx_deleted_snd_chunk_replicas_xftp_server_id;
+DROP INDEX idx_deleted_snd_chunk_replicas_user_id;
+DROP TABLE deleted_snd_chunk_replicas;
+
+DROP INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id;
+DROP TABLE snd_file_chunk_replica_recipients;
+
+DROP INDEX idx_snd_file_chunk_replicas_snd_file_chunk_id;
+DROP INDEX idx_snd_file_chunk_replicas_xftp_server_id;
+DROP TABLE snd_file_chunk_replicas;
+
+DROP INDEX idx_snd_file_chunks_snd_file_id;
+DROP TABLE snd_file_chunks;
+
+DROP INDEX idx_snd_files_user_id;
+DROP TABLE snd_files;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230510_files_pending_replicas_indexes.hs

@@ -0,0 +1,22 @@
+{-# 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;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230516_encrypted_rcv_message_hashes.hs

@@ -0,0 +1,28 @@
+{-# 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;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql

@@ -1,6 +1,7 @@
 CREATE TABLE migrations(
   name TEXT NOT NULL,
   ts TEXT NOT NULL,
+  down TEXT,
   PRIMARY KEY(name)
 );
 CREATE TABLE servers(
@@ -112,6 +113,8 @@ CREATE TABLE snd_messages(
   internal_id INTEGER NOT NULL,
   internal_hash BLOB NOT NULL,
   previous_msg_hash BLOB NOT NULL DEFAULT x'',
+  retry_int_slow INTEGER,
+  retry_int_fast INTEGER,
   PRIMARY KEY(conn_id, internal_snd_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -185,7 +188,6 @@ 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,
@@ -221,8 +223,6 @@ 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,
@@ -231,15 +231,135 @@ 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);
@@ -283,3 +403,43 @@ 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 INDEX idx_rcv_files_user_id ON rcv_files(user_id);
+CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id);
+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 INDEX idx_snd_files_user_id ON snd_files(user_id);
+CREATE INDEX idx_snd_file_chunks_snd_file_id ON snd_file_chunks(snd_file_id);
+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 INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id ON snd_file_chunk_replica_recipients(
+  snd_file_chunk_replica_id
+);
+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
+);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -16,8 +16,8 @@ import Control.Concurrent.STM
 import qualified Data.Map.Strict as M
 import Data.Set (Set)
 import qualified Data.Set as S
-import Simplex.Messaging.Agent.Protocol (ConnId)
-import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId)
+import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
+import Simplex.Messaging.Agent.Store (RcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM

src/Simplex/Messaging/Client.hs

@@ -31,7 +31,7 @@ module Simplex.Messaging.Client
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
-    clientServer,
+    protocolClientServer,
     transportHost',
     transportSession',
 
@@ -70,7 +70,6 @@ module Simplex.Messaging.Client
   )
 where
 
-import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
@@ -102,7 +101,7 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (bshow, raceAny_)
+import Simplex.Messaging.Util (bshow, raceAny_, threadDelay')
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
 
@@ -171,7 +170,7 @@ data NetworkConfig = NetworkConfig
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
     -- | period for SMP ping commands (microseconds, 0 to disable)
-    smpPingInterval :: Int,
+    smpPingInterval :: Int64,
     -- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable
     smpPingCount :: Int,
     logTLSErrors :: Bool
@@ -254,8 +253,8 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
     onionHost = find isOnionHost hosts
     publicHost = find (not . isOnionHost) hosts
 
-clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
-clientServer = B.unpack . strEncode . snd3 . transportSession . client_
+protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
+protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_
   where
     snd3 (_, s, _) = s
 
@@ -348,7 +347,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
 
     ping :: ProtocolClient err msg -> IO ()
     ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
-      threadDelay smpPingInterval
+      threadDelay' smpPingInterval
       runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @err @msg) >>= \case
         Left PCEResponseTimeout -> do
           cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1)

src/Simplex/Messaging/Client/Agent.hs

@@ -156,7 +156,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
           atomically $ modifyTVar' (asyncClients ca) (a :)
         connectAsync :: ExceptT SMPClientError IO ()
         connectAsync =
-          withRetryInterval (reconnectInterval agentCfg) $ \loop ->
+          withRetryInterval (reconnectInterval agentCfg) $ \_ loop ->
             void $ tryConnectClient (const reconnectClient) loop
 
     connectClient :: ExceptT SMPClientError IO SMPClient
@@ -195,7 +195,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
 
     tryReconnectClient :: ExceptT SMPClientError IO ()
     tryReconnectClient = do
-      withRetryInterval (reconnectInterval agentCfg) $ \loop ->
+      withRetryInterval (reconnectInterval agentCfg) $ \_ loop ->
         reconnectClient `catchE` const loop
 
     reconnectClient :: ExceptT SMPClientError IO ()

src/Simplex/Messaging/Crypto.hs

@@ -127,8 +127,9 @@ module Simplex.Messaging.Crypto
     -- * pseudo-random bytes
     pseudoRandomBytes,
 
-    -- * hash
+    -- * digests
     sha256Hash,
+    sha512Hash,
 
     -- * Message padding / un-padding
     pad,
@@ -154,7 +155,7 @@ import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA256, hash)
+import Crypto.Hash (Digest, SHA256, SHA512, hash)
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
@@ -179,6 +180,7 @@ import Data.Kind (Constraint, Type)
 import Data.String
 import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
+import Data.Word (Word32)
 import Data.X509
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
@@ -718,9 +720,9 @@ data CryptoError
   | -- | header decryption error (could indicate that another key should be tried)
     CERatchetHeader
   | -- | too many skipped messages
-    CERatchetTooManySkipped
+    CERatchetTooManySkipped Word32
   | -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
-    CERatchetEarlierMessage
+    CERatchetEarlierMessage Word32
   | -- | duplicate message number
     CERatchetDuplicateMessage
   deriving (Eq, Show, Exception)
@@ -809,6 +811,10 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
 sha256Hash :: ByteString -> ByteString
 sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
 
+-- | SHA512 digest.
+sha512Hash :: ByteString -> ByteString
+sha512Hash = BA.convert . (hash :: ByteString -> Digest SHA512)
+
 -- | AEAD-GCM encryption with associated data.
 --
 -- Used as part of double ratchet encryption.
@@ -1032,6 +1038,10 @@ instance ToJSON CbNonce where
 instance FromJSON CbNonce where
   parseJSON = strParseJSON "CbNonce"
 
+instance FromField CbNonce where fromField f = CryptoBoxNonce <$> fromField f
+
+instance ToField CbNonce where toField (CryptoBoxNonce s) = toField s
+
 cbNonce :: ByteString -> CbNonce
 cbNonce s
   | len == 24 = CryptoBoxNonce s
@@ -1072,6 +1082,10 @@ instance ToJSON SbKey where
 instance FromJSON SbKey where
   parseJSON = strParseJSON "SbKey"
 
+instance FromField SbKey where fromField f = SecretBoxKey <$> fromField f
+
+instance ToField SbKey where toField (SecretBoxKey s) = toField s
+
 sbKey :: ByteString -> Either String SbKey
 sbKey s
   | B.length s == 32 = Right $ SecretBoxKey s

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -1,16 +1,17 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Crypto.Lazy
-  ( sha512Hash,
+  ( sha256Hash,
+    sha512Hash,
     pad,
     unPad,
+    splitLen,
     sbEncrypt,
     sbDecrypt,
     sbEncryptTailTag,
@@ -21,15 +22,19 @@ module Simplex.Messaging.Crypto.Lazy
     sbInit,
     sbEncryptChunk,
     sbDecryptChunk,
+    sbEncryptChunkLazy,
+    sbDecryptChunkLazy,
     sbAuth,
+    LazyByteString,
   )
 where
 
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
 import Crypto.Hash (Digest, hashlazy)
-import Crypto.Hash.Algorithms (SHA512)
+import Crypto.Hash.Algorithms (SHA256, SHA512)
 import qualified Crypto.MAC.Poly1305 as Poly1305
+import Data.Bifunctor (first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString as S
@@ -37,6 +42,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.ByteString.Lazy.Internal as LB
+import Data.Composition ((.:.))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Foreign (sizeOf)
@@ -45,6 +51,10 @@ import Simplex.Messaging.Encoding
 
 type LazyByteString = LB.ByteString
 
+-- | SHA512 digest of a lazy bytestring.
+sha256Hash :: LazyByteString -> ByteString
+sha256Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA256)
+
 -- | SHA512 digest of a lazy bytestring.
 sha512Hash :: LazyByteString -> ByteString
 sha512Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA512)
@@ -73,11 +83,14 @@ fastReplicate n c
 -- this function does not validate the length of the message to avoid consuming all chunks,
 -- so it can return a shorter string than expected
 unPad :: LazyByteString -> Either CryptoError LazyByteString
-unPad padded
+unPad = fmap snd . splitLen
+
+splitLen :: LazyByteString -> Either CryptoError (Int64, LazyByteString)
+splitLen padded
   | LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of
     Right len
       | len < 0 -> Left CryptoInvalidMsgError
-      | otherwise -> Right $ LB.take len rest
+      | otherwise -> Right (len, LB.take len rest)
     Left _ -> Left CryptoInvalidMsgError
   | otherwise = Left CryptoInvalidMsgError
   where
@@ -107,9 +120,9 @@ sbDecrypt (SbKey key) (CbNonce nonce) packet
 secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
 secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    process state = foldlChunks update ([], state) msg
-    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
-    run state = let (cs, state') = process state in BA.convert (sbAuth state') :| reverse cs
+    run state =
+      let (!cs, !state') = secretBoxLazy_ sbProcess state msg
+       in BA.convert (sbAuth state') :| reverse cs
 
 -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
 sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
@@ -131,9 +144,15 @@ sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet =
 secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
 secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    process state = foldlChunks update ([], state) msg
-    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
-    run state = let (cs, state') = process state in reverse $ BA.convert (sbAuth state') : cs
+    run state =
+      let (cs, state') = secretBoxLazy_ sbProcess state msg
+       in reverse $ BA.convert (sbAuth state') : cs
+
+-- passes lazy bytestring via initialized secret box returning the reversed list of chunks
+secretBoxLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> ([ByteString], SbState)
+secretBoxLazy_ sbProcess state = foldlChunks update ([], state)
+  where
+    update (cs, st) chunk = let (!c, !st') = sbProcess st chunk in (c : cs, st')
 
 type SbState = (XSalsa.State, Poly1305.State)
 
@@ -154,16 +173,26 @@ sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
     state1 = XSalsa.derive state0 iv1
     (rs :: ByteString, state2) = XSalsa.generate state1 32
 
+sbEncryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
+sbEncryptChunkLazy = sbProcessChunkLazy_ sbEncryptChunk
+
+sbDecryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
+sbDecryptChunkLazy = sbProcessChunkLazy_ sbDecryptChunk
+
+sbProcessChunkLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> (LazyByteString, SbState)
+sbProcessChunkLazy_ = first (LB.fromChunks . reverse) .:. secretBoxLazy_
+{-# INLINE sbProcessChunkLazy_ #-}
+
 sbEncryptChunk :: SbState -> ByteString -> (ByteString, SbState)
 sbEncryptChunk (st, authSt) chunk =
-  let (c, st') = XSalsa.combine st chunk
-      authSt' = Poly1305.update authSt c
+  let (!c, !st') = XSalsa.combine st chunk
+      !authSt' = Poly1305.update authSt c
    in (c, (st', authSt'))
 
 sbDecryptChunk :: SbState -> ByteString -> (ByteString, SbState)
 sbDecryptChunk (st, authSt) chunk =
-  let (s, st') = XSalsa.combine st chunk
-      authSt' = Poly1305.update authSt chunk
+  let (!s, !st') = XSalsa.combine st chunk
+      !authSt' = Poly1305.update authSt chunk
    in (s, (st', authSt'))
 
 sbAuth :: SbState -> Poly1305.Auth

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -423,9 +423,9 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
     skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
     skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
     skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
-      | rcNr > untilN + 1 = Left CERatchetEarlierMessage
+      | rcNr > untilN + 1 = Left $ CERatchetEarlierMessage (rcNr - untilN - 1)
       | rcNr == untilN + 1 = Left CERatchetDuplicateMessage
-      | rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
+      | rcNr + maxSkip < untilN = Left $ CERatchetTooManySkipped (untilN + 1 - rcNr)
       | rcNr == untilN = Right (r, M.empty)
       | otherwise =
         let (rcCKr', rcNr', mks) = advanceRcvRatchet (untilN - rcNr) rcCKr rcNr M.empty

src/Simplex/Messaging/Notifications/Server.hs

@@ -19,6 +19,7 @@ import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List (intercalate)
 import Data.Map.Strict (Map)
 import qualified Data.Text as T
@@ -97,11 +98,11 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
       [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> FilePath -> M ()
+    logServerStats :: Int64 -> Int64 -> FilePath -> M ()
     logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
+      liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
       let interval = 1000000 * logInterval
       withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -136,7 +137,7 @@ ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
                 weekCount sub,
                 monthCount sub
               ]
-          threadDelay interval
+          threadDelay' interval
 
 resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
 resubscribe NtfSubscriber {newSubQ} subs = do
@@ -494,7 +495,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
                 atomically $ TM.insert tknId notifier intervalNotifiers
                 where
                   intervalNotifier delay = forever $ do
-                    threadDelay delay
+                    liftIO $ threadDelay' delay
                     atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
       NtfReqNew corrId (ANE SSubscription newSub) -> do
         logDebug "SNEW - new subscription"

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -11,6 +11,7 @@ import Control.Concurrent.Async (Async)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Word (Word16)
@@ -52,8 +53,8 @@ data NtfServerConfig = NtfServerConfig
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- stats config - see SMP server config
-    logStatsInterval :: Maybe Int,
-    logStatsStartTime :: Int,
+    logStatsInterval :: Maybe Int64,
+    logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
     logTLSErrors :: Bool
@@ -73,7 +74,6 @@ data NtfEnv = NtfEnv
     store :: NtfStore,
     storeLog :: Maybe (StoreLog 'WriteMode),
     idsDrg :: TVar ChaChaDRG,
-    serverIdentity :: C.KeyHash,
     tlsServerParams :: T.ServerParams,
     serverIdentity :: C.KeyHash,
     serverStats :: NtfServerStats

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -28,7 +28,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
 ntfServerVersion :: String
-ntfServerVersion = "1.3.0"
+ntfServerVersion = "1.4.0"
 
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =

src/Simplex/Messaging/Protocol.hs

@@ -65,8 +65,10 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    SProtocolType (..),
     AProtocolType (..),
     ProtocolTypeI (..),
+    UserProtocol,
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
@@ -78,6 +80,7 @@ module Simplex.Messaging.Protocol
     pattern XFTPServer,
     XFTPServerWithAuth,
     ProtoServerWithAuth (..),
+    AProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
@@ -109,6 +112,7 @@ module Simplex.Messaging.Protocol
     SMPMsgMeta (..),
     NMsgMeta (..),
     MsgFlags (..),
+    userProtocol,
     rcvMessageMeta,
     noMsgFlags,
 
@@ -150,6 +154,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
+import Data.Constraint (Dict (..))
 import Data.Functor (($>))
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
@@ -159,7 +164,7 @@ import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
 import GHC.Generics (Generic)
-import GHC.TypeLits (type (+))
+import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import Generic.Random (genericArbitraryU)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
@@ -702,6 +707,10 @@ instance StrEncoding AProtocolType where
   strEncode (AProtocolType p) = strEncode p
   strP = aProtocolType <$> strP
 
+instance ProtocolTypeI p => ToJSON (SProtocolType p) where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
 instance ToJSON AProtocolType where
   toEncoding = strToJEncoding
   toJSON = strToJSON
@@ -720,6 +729,18 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 
 instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP
 
+type family UserProtocol (p :: ProtocolType) :: Constraint where
+  UserProtocol PSMP = ()
+  UserProtocol PXFTP = ()
+  UserProtocol a =
+    (Int ~ Bool, TypeError (Text "Servers for protocol " :<>: ShowType a :<>: Text " cannot be configured by the users"))
+
+userProtocol :: SProtocolType p -> Maybe (Dict (UserProtocol p))
+userProtocol = \case
+  SPSMP -> Just Dict
+  SPXFTP -> Just Dict
+  _ -> Nothing
+
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,
@@ -729,6 +750,8 @@ data ProtocolServer p = ProtocolServer
   }
   deriving (Eq, Ord, Show)
 
+data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p)
+
 instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 
@@ -744,7 +767,7 @@ instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
     strEncodeServer scheme (strEncode host) port keyHash Nothing
   strP =
     serverStrP >>= \case
-      (srv, Nothing) -> pure srv
+      (AProtocolServer _ srv, Nothing) -> either fail pure $ checkProtocolType srv
       _ -> fail "ProtocolServer with basic auth not allowed"
 
 instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
@@ -780,10 +803,20 @@ data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer
 instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
   fromString = parseString strDecode
 
+data AProtoServerWithAuth = forall p. ProtocolTypeI p => AProtoServerWithAuth (SProtocolType p) (ProtoServerWithAuth p)
+
+deriving instance Show AProtoServerWithAuth
+
 instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
   strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
     strEncodeServer scheme (strEncode host) port keyHash auth_
-  strP = uncurry ProtoServerWithAuth <$> serverStrP
+  strP = (\(AProtoServerWithAuth _ srv) -> checkProtocolType srv) <$?> strP
+
+instance StrEncoding AProtoServerWithAuth where
+  strEncode (AProtoServerWithAuth _ srv) = strEncode srv
+  strP =
+    serverStrP >>= \(AProtocolServer p srv, auth) ->
+      pure $ AProtoServerWithAuth p (ProtoServerWithAuth srv auth)
 
 instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
   toJSON = strToJSON
@@ -792,6 +825,13 @@ instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
 instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
   parseJSON = strParseJSON "ProtoServerWithAuth"
 
+instance ToJSON AProtoServerWithAuth where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON AProtoServerWithAuth where
+  parseJSON = strParseJSON "AProtoServerWithAuth"
+
 noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
 noAuthSrv srv = ProtoServerWithAuth srv Nothing
 
@@ -814,14 +854,15 @@ strEncodeServer scheme host port keyHash auth_ =
   where
     portStr = B.pack $ if null port then "" else ':' : port
 
-serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
+serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
 serverStrP = do
   scheme <- strP <* "://"
   keyHash <- strP
   auth_ <- optional $ A.char ':' *> strP
   TransportHosts host <- A.char '@' *> strP
   port <- portP <|> pure ""
-  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
+  pure $ case scheme of
+    AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash}, auth_)
   where
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 

src/Simplex/Messaging/Server.hs

@@ -46,6 +46,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List (intercalate)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -157,7 +158,7 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
       quota <- asks $ msgQueueQuota . config
       let interval = checkInterval expCfg * 1000000
       forever $ do
-        threadDelay interval
+        liftIO $ threadDelay' interval
         old <- liftIO $ expireBeforeEpoch expCfg
         rIds <- M.keysSet <$> readTVarIO ms
         forM_ rIds $ \rId ->
@@ -169,11 +170,11 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
       [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> FilePath -> M ()
+    logServerStats :: Int64 -> Int64 -> FilePath -> M ()
     logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
+      liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
       let interval = 1000000 * logInterval
       withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -212,7 +213,7 @@ smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
                 show qCount',
                 show msgCount'
               ]
-          threadDelay interval
+          threadDelay' interval
 
     runClient :: Transport c => TProxy c -> c -> M ()
     runClient _ h = do
@@ -292,7 +293,7 @@ disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar Sys
 disconnectTransport THandle {connection} c activeAt expCfg = do
   let interval = checkInterval expCfg * 1000000
   forever . liftIO $ do
-    threadDelay interval
+    threadDelay' interval
     old <- expireBeforeEpoch expCfg
     ts <- readTVarIO $ activeAt c
     when (systemSeconds ts < old) $ closeConnection connection
@@ -740,7 +741,8 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
       st <- asks queueStore
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
-      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
+      old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
+      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota old_) . B.lines) >>= \case
         Left e -> do
           logError . T.pack $ "error restoring messages: " <> e
           liftIO exitFailure
@@ -748,7 +750,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
           renameFile f $ f <> ".bak"
           logInfo "messages restored"
       where
-        restoreMsg st ms quota s = do
+        restoreMsg st ms quota old_ s = do
           r <- liftEither . first (msgErr "parsing") $ strDecode s
           case r of
             MLRv3 rId msg -> addToMsgQueue rId msg
@@ -758,13 +760,14 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
               addToMsgQueue rId msg'
           where
             addToMsgQueue rId msg = do
-              full <- atomically $ do
+              logFull <- atomically $ do
                 q <- getMsgQueue ms rId quota
-                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 ()
+                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))
             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

src/Simplex/Messaging/Server/CLI.hs

@@ -164,6 +164,9 @@ 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

src/Simplex/Messaging/Server/Env/STM.hs

@@ -9,6 +9,7 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -54,10 +55,10 @@ data ServerConfig = ServerConfig
     -- and check interval, seconds
     inactiveClientExpiration :: Maybe ExpirationConfig,
     -- | log SMP server usage statistics, only aggregates are logged, seconds
-    logStatsInterval :: Maybe Int,
+    logStatsInterval :: Maybe Int64,
     -- | time of the day when the stats are logged first, to log at consistent times,
     -- irrespective of when the server is started (seconds from 00:00 UTC)
-    logStatsStartTime :: Int,
+    logStatsStartTime :: Int64,
     -- | file to log stats
     serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
@@ -71,10 +72,13 @@ data ServerConfig = ServerConfig
     logTLSErrors :: Bool
   }
 
+defMsgExpirationDays :: Int64
+defMsgExpirationDays = 21
+
 defaultMessageExpiration :: ExpirationConfig
 defaultMessageExpiration =
   ExpirationConfig
-    { ttl = 30 * 86400, -- seconds, 30 days
+    { ttl = defMsgExpirationDays * 86400, -- seconds
       checkInterval = 43200 -- seconds, 12 hours
     }
 

src/Simplex/Messaging/Server/Expiration.hs

@@ -10,8 +10,19 @@ data ExpirationConfig = ExpirationConfig
   { -- time after which the entity can be expired, seconds
     ttl :: Int64,
     -- interval to check expiration, seconds
-    checkInterval :: Int
+    checkInterval :: Int64
   }
 
 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

src/Simplex/Messaging/Server/Main.hs

@@ -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)
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration, defMsgExpirationDays)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
@@ -106,7 +106,8 @@ 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\n")
+                <> ("restore_messages: " <> onOff enableStoreLog <> "\n")
+                <> ("expire_messages_days: " <> show defMsgExpirationDays <> "\n\n")
                 <> "# Log daily server statistics to CSV file\n"
                 <> ("log_stats: " <> onOff logStats <> "\n\n")
                 <> "[AUTH]\n\
@@ -140,10 +141,13 @@ 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, inactiveClientExpiration} = serverConfig
+          cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, messageExpiration, 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"
@@ -161,7 +165,7 @@ smpServerCLI cfgPath logPath =
           ServerConfig
             { transports = iniTransports ini,
               tbqSize = 32,
-              serverTbqSize = 128,
+              serverTbqSize = 1024,
               msgQueueQuota = 128,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
@@ -179,7 +183,10 @@ 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,
+              messageExpiration =
+                Just defaultMessageExpiration
+                  { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
+                  },
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
                   $> ExpirationConfig

src/Simplex/Messaging/Transport.hs

@@ -204,11 +204,10 @@ instance Transport TLS where
   tlsUnique = tlsUniq
   closeConnection tls = closeTLS $ tlsContext tls
 
+  -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
+  -- this function may return less than requested number of bytes
   cGet :: TLS -> Int -> IO ByteString
-  cGet TLS {tlsContext, tlsBuffer} n = do
-    s <- getBuffered tlsBuffer n (T.recvData tlsContext)
-    -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-    if B.length s == n then pure s else ioe_EOF
+  cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext)
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -321,10 +320,11 @@ tPutBlock THandle {connection = c, blockSize} block =
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} =
-  cGet c blockSize >>= \case
-    "" -> ioe_EOF
-    msg -> pure . first (const TELargeMsg) $ C.unPad msg
+tGetBlock THandle {connection = c, blockSize} = do
+  msg <- cGet c blockSize
+  if B.length msg == blockSize
+    then pure . first (const TELargeMsg) $ C.unPad msg
+    else ioe_EOF
 
 -- | Server SMP transport handshake.
 --

src/Simplex/Messaging/Transport/Buffer.hs

@@ -31,6 +31,8 @@ getBuffered tb@TBuffer {buffer} n getChunk = withBufferLock tb $ do
   b <- readChunks =<< readTVarIO buffer
   let (s, b') = B.splitAt n b
   atomically $ writeTVar buffer $! b'
+  -- This would prevent the need to pad auth tag in HTTP2
+  -- threadDelay 150
   pure s
   where
     readChunks :: ByteString -> IO ByteString

src/Simplex/Messaging/Transport/Client.hs

@@ -26,13 +26,14 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isAsciiLower, isDigit)
+import Data.Char (isAsciiLower, isDigit, isHexDigit)
 import Data.Default (def)
+import Data.IP
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Data.String
-import Data.Word (Word8)
+import Data.Word (Word32, Word8)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Data.X509.Validation (Fingerprint (..))
@@ -55,6 +56,7 @@ import qualified UnliftIO.Exception as E
 
 data TransportHost
   = THIPv4 (Word8, Word8, Word8, Word8)
+  | THIPv6 (Word32, Word32, Word32, Word32)
   | THOnionHost ByteString
   | THDomainName HostName
   deriving (Eq, Ord, Show)
@@ -66,11 +68,13 @@ instance Encoding TransportHost where
 instance StrEncoding TransportHost where
   strEncode = \case
     THIPv4 (a1, a2, a3, a4) -> B.intercalate "." $ map bshow [a1, a2, a3, a4]
+    THIPv6 addr -> bshow $ toIPv6w addr
     THOnionHost host -> host
     THDomainName host -> B.pack host
   strP =
     A.choice
       [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
+        maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> A.takeWhile1 (\c -> isHexDigit c || c == ':'),
         THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
         THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
       ]
@@ -129,6 +133,7 @@ runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpK
   where
     hostAddr = \case
       THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
+      THIPv6 addr -> SocksAddrIPV6 addr
       THOnionHost h -> SocksAddrDomainName h
       THDomainName h -> SocksAddrDomainName $ B.pack h
 

src/Simplex/Messaging/Transport/Server.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Server
@@ -12,11 +14,15 @@ module Simplex.Messaging.Transport.Server
   )
 where
 
+import Control.Applicative ((<|>))
 import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX
 import Data.Default (def)
+import Data.List (find)
+import Data.Maybe (fromJust)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
@@ -25,7 +31,7 @@ import qualified Network.TLS as T
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_)
+import Simplex.Messaging.Util (catchAll_, tshow)
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak, deRefWeak)
 import UnliftIO.Concurrent
@@ -70,14 +76,18 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
   where
     resolve =
       let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
-       in head <$> getAddrInfo (Just hints) Nothing (Just port)
+       in select <$> getAddrInfo (Just hints) Nothing (Just port)
+    select as = fromJust $ family AF_INET6 <|> family AF_INET
+      where
+        family f = find ((== f) . addrFamily) as
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       setSocketOption sock ReuseAddr 1
       withFdSocket sock setCloseOnExecIfNeeded
+      logInfo $ "binding to " <> tshow (addrAddress addr)
       bind sock $ addrAddress addr
       listen sock 1024
-      return sock
+      pure sock
     setStarted sock = atomically (tryPutTMVar started True) >> pure sock
 
 loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams

src/Simplex/Messaging/Util.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Util where
 
+import Control.Concurrent (threadDelay)
 import qualified Control.Exception as E
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
@@ -10,9 +12,11 @@ import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
+import Data.Time (NominalDiffTime, nominalDiffTimeToSeconds)
 import UnliftIO.Async
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -55,6 +59,10 @@ liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a)
 liftEitherError f a = liftIOEither (first f <$> a)
 {-# INLINE liftEitherError #-}
 
+liftEitherWith :: (MonadError e' m) => (e -> e') -> Either e a -> m a
+liftEitherWith f = liftEither . first f
+{-# INLINE liftEitherWith #-}
+
 tryError :: MonadError e m => m a -> m (Either e a)
 tryError action = (Right <$> action) `catchError` (pure . Left)
 {-# INLINE tryError #-}
@@ -98,3 +106,17 @@ safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
   where
     onError _ _ = Just '?'
+
+threadDelay' :: Int64 -> IO ()
+threadDelay' time
+  | time <= 0 = pure ()
+threadDelay' time = do
+  let maxWait = min time $ fromIntegral (maxBound :: Int)
+  threadDelay $ fromIntegral maxWait
+  when (maxWait /= time) $ threadDelay' (time - maxWait)
+
+diffToMicroseconds :: NominalDiffTime -> Int64
+diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer)
+
+diffToMilliseconds :: NominalDiffTime -> Int64
+diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer)

stack.yaml

@@ -48,6 +48,8 @@ extra-deps:
   - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
   - github: simplex-chat/aeson
     commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
+  - github: kazu-yamamoto/http2
+    commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
   # - ../direct-sqlcipher
   - github: simplex-chat/direct-sqlcipher
     commit: 34309410eb2069b029b8fc1872deb1e0db123294

tests/AgentTests.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PostfixOperators #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests (agentTests) where
@@ -12,6 +13,7 @@ module AgentTests (agentTests) where
 import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
+import AgentTests.MigrationTests (migrationTests)
 import AgentTests.NotificationTests (notificationTests)
 import AgentTests.SQLiteTests (storeTests)
 import AgentTests.SchemaDump (schemaDumpTest)
@@ -19,10 +21,10 @@ import Control.Concurrent
 import Control.Monad (forM_)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Type.Equality
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
 import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
-import Simplex.Messaging.Agent.Env.SQLite (AgentDatabase, databaseFile)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Encoding.String
@@ -41,6 +43,7 @@ agentTests (ATransport t) = do
   describe "Notification tests" $ notificationTests (ATransport t)
   describe "SQLite store" storeTests
   describe "SQLite schema dump" schemaDumpTest
+  describe "Migration tests" migrationTests
   describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection" $ do
     it "should connect via one server and one agent" $
@@ -81,45 +84,73 @@ agentTests (ATransport t) = do
     it "should resume delivering messages after exceeding quota once all messages are received" $
       smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
 
-tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-tGetAgent h = do
-  t@(_, _, cmd) <- tGet SAgent h
-  case cmd of
-    Right CONNECT {} -> tGetAgent h
-    Right DISCONNECT {} -> tGetAgent h
-    _ -> pure t
+type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
+
+type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e))
+
+tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
+tGetAgent = tGetAgent'
+
+tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e)
+tGetAgent' h = do
+  (corrId, connId, cmdOrErr) <- pGetAgent h
+  case cmdOrErr of
+    Right (APC e cmd) -> case testEquality e (sAEntity @e) of
+      Just Refl -> pure (corrId, connId, Right cmd)
+      _ -> error $ "unexpected command " <> show cmd
+    Left err -> pure (corrId, connId, Left err)
+
+pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent)
+pGetAgent h = do
+  (corrId, connId, cmdOrErr) <- tGet SAgent h
+  case cmdOrErr of
+    Right (APC _ CONNECT {}) -> pGetAgent h
+    Right (APC _ DISCONNECT {}) -> pGetAgent h
+    cmd -> pure (corrId, connId, cmd)
 
 -- | receive message to handle `h`
-(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
 (<#:) = tGetAgent
 
+(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+(<#:?) = pGetAgent
+
+(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone)
+(<#:.) = tGetAgent'
+
 -- | send transmission `t` to handle `h` and get response
-(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
+(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
 h #: t = tPutRaw h t >> (<#:) h
 
 -- | action and expected response
 -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
-(#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation
+(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation
 action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd)
 
 -- | action and predicate for the response
 -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`
-(=#>) :: IO (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation
+(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
 
-correctTransmission :: ATransmissionOrError a -> ATransmission a
+correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd)
 correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
   Right cmd -> (corrId, connId, cmd)
   Left e -> error $ show e
 
 -- | receive message to handle `h` and validate that it is the expected one
-(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
+(<#) :: Transport c => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
 h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)
 
+(<#.) :: Transport c => c -> AEntityTransmission 'Agent 'AENone -> Expectation
+h <#. (corrId, connId, cmd) = (h <#:.) `shouldReturn` (corrId, connId, Right cmd)
+
 -- | receive message to handle `h` and validate it using predicate `p`
-(<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
+(<#=) :: Transport c => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 
+(<#=?) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
+h <#=? p = (h <#:?) >>= (`shouldSatisfy` p . correctTransmission)
+
 -- | test that nothing is delivered to handle `h` during 10ms
 (#:#) :: Transport c => c -> String -> Expectation
 h #:# err = tryGet `shouldReturn` ()
@@ -129,7 +160,7 @@ h #:# err = tryGet `shouldReturn` ()
         Just _ -> error err
         _ -> return ()
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
@@ -288,7 +319,7 @@ testSubscrNotification t (server, _) client = do
   client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
-  client <# ("", "", DOWN testSMPServer ["conn1"])
+  client <#. ("", "", DOWN testSMPServer ["conn1"])
   withSmpServer (ATransport t) $
     client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
 
@@ -302,15 +333,15 @@ testMsgDeliveryServerRestart t alice bob = do
     alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
-  let server = (SMPServer "localhost" testPort2 testKeyHash)
-  alice <# ("", "", DOWN server ["bob"])
+  let server = SMPServer "localhost" testPort2 testKeyHash
+  alice <#. ("", "", DOWN server ["bob"])
   bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
     bob <# ("", "alice", SENT 5)
-    alice <# ("", "", UP server ["bob"])
+    alice <#. ("", "", UP server ["bob"])
     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
     alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
 
@@ -325,8 +356,8 @@ testServerConnectionAfterError t _ = do
       withServer $ do
         connect (bob, "bob") (alice, "alice")
 
-      bob <# ("", "", DOWN server ["alice"])
-      alice <# ("", "", DOWN server ["bob"])
+      bob <#. ("", "", DOWN server ["alice"])
+      alice <#. ("", "", DOWN server ["bob"])
       alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
       alice #:# "nothing else delivered before the server is restarted"
       bob #:# "nothing else delivered before the server is restarted"
@@ -336,24 +367,24 @@ testServerConnectionAfterError t _ = do
       bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       withServer $ do
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
-        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+        alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
+        alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
+        bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
+        bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
         bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
         alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
         alice <# ("", "bob", SENT 5)
         bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
 
   removeFile testStoreLogFile
-  removeFile $ databaseFile testDB
-  removeFile $ databaseFile testDB2
+  removeFile testDB
+  removeFile testDB2
   where
     server = SMPServer "localhost" testPort2 testKeyHash
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent1 = withAgent agentTestPort testDB
     withAgent2 = withAgent agentTestPort2 testDB2
-    withAgent :: String -> AgentDatabase -> (c -> IO a) -> IO a
+    withAgent :: String -> FilePath -> (c -> IO a) -> IO a
     withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
 
 testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
@@ -368,7 +399,7 @@ testMsgDeliveryAgentRestart t bob = do
       bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
       bob #:# "nothing else delivered before the server is down"
 
-    bob <# ("", "", DOWN server ["alice"])
+    bob <#. ("", "", DOWN server ["alice"])
     alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
     alice #:# "nothing else delivered before the server is restarted"
     bob #:# "nothing else delivered before the server is restarted"
@@ -381,12 +412,12 @@ testMsgDeliveryAgentRestart t bob = do
           (corrId == "3" && cmd == OK)
             || (corrId == "" && cmd == SENT 5)
         _ -> False
-      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
-      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+      bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
+      bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
       bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
-  removeFile $ databaseFile testDB
+  removeFile testDB
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort

tests/AgentTests/FunctionalAPITests.hs

@@ -8,17 +8,23 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests
   ( functionalAPITests,
     testServerMatrix2,
+    getSMPAgentClient',
     makeConnection,
     exchangeGreetingsMsgId,
     switchComplete,
     runRight,
     runRight_,
     get,
+    get',
+    rfGet,
+    sfGet,
+    nGet,
     (##>),
     (=##>),
     pattern Msg,
@@ -28,8 +34,7 @@ where
 import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
-import Control.Monad.Except (ExceptT, runExceptT, throwError)
-import Control.Monad.IO.Unlift
+import Control.Monad.Except
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight)
@@ -38,13 +43,14 @@ import qualified Data.Map as M
 import Data.Maybe (isNothing)
 import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Type.Equality
 import SMPAgentClient
 import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
-import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.Store (UserId)
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
+import Simplex.Messaging.Agent.Protocol as Agent
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
 import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -55,24 +61,47 @@ 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)
 
-(##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
+type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
+
+(##>) :: (HasCallStack, MonadIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m ()
 a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 
-(=##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
+(=##>) :: (Show a, HasCallStack, MonadIO m) => m a -> (a -> Bool) -> m ()
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
-get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
-get c = do
-  t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
+get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn)
+get = get' @'AEConn
+
+rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile)
+rfGet = get' @'AERcvFile
+
+sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile)
+sfGet = get' @'AESndFile
+
+nGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AENone)
+nGet = get' @'AENone
+
+get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e)
+get' c = do
+  (corrId, connId, APC e cmd) <- pGet c
+  case testEquality e (sAEntity @e) of
+    Just Refl -> pure (corrId, connId, cmd)
+    _ -> error $ "unexpected command " <> show cmd
+
+pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent)
+pGet c = do
+  t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c)
   case cmd of
-    CONNECT {} -> get c
-    DISCONNECT {} -> get c
+    CONNECT {} -> pGet c
+    DISCONNECT {} -> pGet c
     _ -> pure t
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
@@ -119,9 +148,13 @@ functionalAPITests t = do
       testAsyncServerOffline t
     it "should notify after HELLO timeout" $
       withSmpServer t testAsyncHelloTimeout
-  describe "Duplicate message delivery" $
+  describe "Message delivery" $ do
     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
@@ -135,8 +168,10 @@ 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 subscriptions with batching" $
-      testBatchedSubscriptions t
+    xit "should subscribe to multiple (200) subscriptions with batching" $
+      testBatchedSubscriptions 200 10 t
+    it "should subscribe to multiple (6) subscriptions with batching" $
+      testBatchedSubscriptions 6 3 t
   describe "Async agent commands" $ do
     it "should connect using async agent commands" $
       withSmpServer t testAsyncCommands
@@ -190,11 +225,11 @@ functionalAPITests t = do
     it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
     let srv1 = testSMPServer2 {keyHash = "1234"}
     it "should fail with incorrect fingerprint" $ do
-      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (SMPTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
     describe "server with password" $ do
       let auth = Just "abcd"
           srv = ProtoServerWithAuth testSMPServer2
-          authErr = Just (SMPTestFailure TSCreateQueue $ SMP AUTH)
+          authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP AUTH)
       it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing
       it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
       it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
@@ -240,8 +275,8 @@ testServerMatrix2 t runTest = do
 
 runTestCfg2 :: AgentConfig -> AgentConfig -> AgentMsgId -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
 runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do
-  alice <- getSMPAgentClient aliceCfg initAgentServers
-  bob <- getSMPAgentClient bobCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' aliceCfg initAgentServers testDB
+  bob <- getSMPAgentClient' bobCfg initAgentServers testDB2
   runTest alice bob baseMsgId
 
 runAgentClientTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
@@ -326,13 +361,13 @@ noMessages c err = tryGet `shouldReturn` ()
 
 testAsyncInitiatingOffline :: HasCallStack => IO ()
 testAsyncInitiatingOffline = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
-    alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+    alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
@@ -343,15 +378,15 @@ testAsyncInitiatingOffline = do
 
 testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO ()
 testAsyncJoiningOfflineBeforeActivation = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
     disconnectAgentClient bob
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -360,18 +395,18 @@ testAsyncJoiningOfflineBeforeActivation = do
 
 testAsyncBothOffline :: HasCallStack => IO ()
 testAsyncBothOffline = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     disconnectAgentClient bob
-    alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+    alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -380,19 +415,19 @@ testAsyncBothOffline = do
 
 testAsyncServerOffline :: HasCallStack => ATransport -> IO ()
 testAsyncServerOffline t = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   -- create connection and shutdown the server
   (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
     runRight $ createConnection alice 1 True SCMInvitation Nothing
   -- connection fails
   Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo"
-  ("", "", DOWN srv conns) <- get alice
+  ("", "", DOWN srv conns) <- nGet alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
   -- connection succeeds after server start
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    ("", "", UP srv1 conns1) <- get alice
+    ("", "", UP srv1 conns1) <- nGet alice
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
@@ -407,8 +442,8 @@ testAsyncServerOffline t = do
 testAsyncHelloTimeout :: HasCallStack => IO ()
 testAsyncHelloTimeout = do
   -- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
-  alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2, helloTimeout = 1} initAgentServers
+  alice <- getSMPAgentClient' agentCfgV1 initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg {helloTimeout = 1} initAgentServers testDB2
   runRight_ $ do
     (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
@@ -417,8 +452,8 @@ testAsyncHelloTimeout = do
 
 testDuplicateMessage :: HasCallStack => ATransport -> IO ()
 testDuplicateMessage t = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ makeConnection alice bob
     runRight_ $ do
@@ -428,7 +463,7 @@ testDuplicateMessage t = do
     disconnectAgentClient bob
 
     -- if the agent user did not send ACK, the message will be delivered again
-    bob1 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
     runRight_ $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
@@ -439,8 +474,8 @@ testDuplicateMessage t = do
 
     pure (aliceId, bobId, bob1)
 
-  get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-  get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+  nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+  nGet bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
   -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
@@ -449,8 +484,8 @@ testDuplicateMessage t = do
   disconnectAgentClient alice
   disconnectAgentClient bob1
 
-  alice2 <- getSMPAgentClient agentCfg initAgentServers
-  bob2 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     runRight_ $ do
@@ -463,6 +498,101 @@ 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
 
@@ -481,16 +611,16 @@ testInactiveClientDisconnected :: ATransport -> IO ()
 testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient agentCfg initAgentServers
+    alice <- getSMPAgentClient' agentCfg initAgentServers testDB
     runRight_ $ do
       (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing
-      get alice ##> ("", "", DOWN testSMPServer [connId])
+      nGet alice ##> ("", "", DOWN testSMPServer [connId])
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
 testActiveClientNotDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
-    alice <- getSMPAgentClient agentCfg initAgentServers
+    alice <- getSMPAgentClient' agentCfg initAgentServers testDB
     ts <- getSystemTime
     runRight_ $ do
       (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing
@@ -510,13 +640,13 @@ testActiveClientNotDisconnected t = do
           Nothing <- 800000 `timeout` get alice
           liftIO $ threadDelay 1200000
           -- and after 2 sec of inactivity DOWN is sent
-          get alice ##> ("", "", DOWN testSMPServer [connId])
+          nGet alice ##> ("", "", DOWN testSMPServer [connId])
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
 testSuspendingAgent :: IO ()
 testSuspendingAgent = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -524,17 +654,17 @@ testSuspendingAgent = do
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
     ackMessage b aId 4
     suspendAgent b 1000000
-    get b ##> ("", "", SUSPENDED)
+    get' b ##> ("", "", SUSPENDED)
     5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
     get a ##> ("", bId, SENT 5)
     Nothing <- 100000 `timeout` get b
-    activateAgent b
+    foregroundAgent b
     get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
 
 testSuspendingAgentCompleteSending :: ATransport -> IO ()
 testSuspendingAgentCompleteSending t = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -544,29 +674,29 @@ testSuspendingAgentCompleteSending t = do
     pure (aId, bId)
 
   runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
+    ("", "", DOWN {}) <- nGet a
+    ("", "", DOWN {}) <- nGet b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
     6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     liftIO $ threadDelay 100000
     suspendAgent b 5000000
 
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    ("", "", SUSPENDED) <- get b
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
+    pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, APC _ (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    ("", "", SUSPENDED) <- nGet b
 
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
+    pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
     ackMessage a bId 5
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
     ackMessage a bId 6
 
 testSuspendingAgentTimeout :: ATransport -> IO ()
 testSuspendingAgentTimeout t = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aId, _) <- withSmpServer t . runRight $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -576,42 +706,45 @@ testSuspendingAgentTimeout t = do
     pure (aId, bId)
 
   runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
+    ("", "", DOWN {}) <- nGet a
+    ("", "", DOWN {}) <- nGet b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
     6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     suspendAgent b 100000
-    ("", "", SUSPENDED) <- get b
+    ("", "", SUSPENDED) <- nGet b
     pure ()
 
-testBatchedSubscriptions :: ATransport -> IO ()
-testBatchedSubscriptions t = do
-  a <- getSMPAgentClient agentCfg initAgentServers2
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers2
+testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
+testBatchedSubscriptions nCreate nDel t = do
+  a <- getSMPAgentClient' agentCfg initAgentServers2 testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers2 testDB2
   conns <- runServers $ do
-    conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
+    conns <- forM [1 .. nCreate :: Int] . const $ makeConnection a b
     forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
-    let (aIds', bIds') = unzip $ take 10 conns
+    let (aIds', bIds') = unzip $ take nDel conns
     delete a bIds'
     delete b aIds'
     liftIO $ threadDelay 1000000
     pure conns
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get b
-  ("", "", DOWN {}) <- get b
+  ("", "", DOWN {}) <- nGet a
+  ("", "", DOWN {}) <- nGet a
+  ("", "", DOWN {}) <- nGet b
+  ("", "", DOWN {}) <- nGet b
   runServers $ do
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get b
-    ("", "", UP {}) <- get b
+    ("", "", UP {}) <- nGet a
+    ("", "", UP {}) <- nGet a
+    ("", "", UP {}) <- nGet b
+    ("", "", UP {}) <- nGet b
     liftIO $ threadDelay 1000000
     let (aIds, bIds) = unzip conns
-        conns' = drop 10 conns
+        conns' = drop nDel 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'
@@ -621,7 +754,7 @@ testBatchedSubscriptions t = do
     subscribe c cs = do
       r <- subscribeConnections c cs
       liftIO $ do
-        let dc = S.fromList $ take 10 cs
+        let dc = S.fromList $ take nDel 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
@@ -647,8 +780,8 @@ testBatchedSubscriptions t = do
 
 testAsyncCommands :: IO ()
 testAsyncCommands = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     bobId <- createConnectionAsync alice 1 "1" True SCMInvitation
     ("1", bobId', INV (ACR _ qInfo)) <- get alice
@@ -693,11 +826,11 @@ testAsyncCommands = do
 
 testAsyncCommandsRestore :: ATransport -> IO ()
 testAsyncCommandsRestore t = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
   bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation
   liftIO $ noMessages alice "alice doesn't receive INV because server is down"
   disconnectAgentClient alice
-  alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+  alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB
   withSmpServerStoreLogOn t testPort $ \_ -> do
     runRight_ $ do
       subscribeConnection alice' bobId
@@ -706,8 +839,8 @@ testAsyncCommandsRestore t = do
 
 testAcceptContactAsync :: IO ()
 testAcceptContactAsync = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (_, qInfo) <- createConnection alice 1 True SCMContact Nothing
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
@@ -748,7 +881,7 @@ testAcceptContactAsync = do
 
 testDeleteConnectionAsync :: ATransport -> IO ()
 testDeleteConnectionAsync t = do
-  a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers
+  a <- getSMPAgentClient' agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
   connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing
     (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing
@@ -766,29 +899,29 @@ testDeleteConnectionAsync t = do
 
 testUsers :: IO ()
 testUsers = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     deleteUser a auId True
     get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False
     get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
-    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     exchangeGreetingsMsgId 6 a bId b aId
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
 testDeleteUserQuietly :: IO ()
 testDeleteUserQuietly = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     deleteUser a auId False
@@ -797,33 +930,33 @@ testDeleteUserQuietly = do
 
 testUsersNoServer :: HasCallStack => ATransport -> IO ()
 testUsersNoServer t = do
-  a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     pure (aId, bId, auId, aId', bId')
-  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
-  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
-  get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
+  nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
   runRight_ $ do
     deleteUser a auId True
     get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
     get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
-    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
-    get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
+    nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
+    nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
     exchangeGreetingsMsgId 6 a bId b aId
 
 testSwitchConnection :: InitialAgentServers -> IO ()
 testSwitchConnection servers = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -876,8 +1009,8 @@ testSwitchAsync servers = do
     subscribeConnection b aId
     exchangeGreetingsMsgId 10 a bId b aId
   where
-    withAgent :: AgentConfig -> (AgentClient -> IO a) -> IO a
-    withAgent cfg' = bracket (getSMPAgentClient cfg' servers) disconnectAgentClient
+    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
@@ -885,13 +1018,13 @@ testSwitchAsync servers = do
         r <- a c
         liftIO $ threadDelay 500000
         pure r
-    withA = withAgent agentCfg
-    withB = withAgent agentCfg {database = testDB2, initialClientId = 1}
+    withA = withAgent agentCfg testDB
+    withB = withAgent agentCfg {initialClientId = 1} testDB2
 
 testSwitchDelete :: InitialAgentServers -> IO ()
 testSwitchDelete servers = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
@@ -928,18 +1061,18 @@ testCreateQueueAuth clnt1 clnt2 = do
     getClient (clntAuth, clntVersion) =
       let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
           smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
-       in getSMPAgentClient agentCfg {smpCfg} servers
+       in getSMPAgentClient' agentCfg {smpCfg} servers testDB
 
-testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe SMPTestFailure)
+testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testSMPServerConnectionTest t newQueueBasicAuth srv =
   withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
-    a <- getSMPAgentClient agentCfg initAgentServers -- initially passed server is not running
-    runRight $ testSMPServerConnection a 1 srv
+    a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
+    runRight $ testProtocolServer a 1 srv
 
 testRatchetAdHash :: IO ()
 testRatchetAdHash = do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     ad1 <- getConnectionRatchetAdHash a bId
@@ -949,8 +1082,8 @@ testRatchetAdHash = do
 testTwoUsers :: HasCallStack => IO ()
 testTwoUsers = do
   let nc = netCfg initAgentServers
-  a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  b <- getSMPAgentClient' agentCfg initAgentServers testDB2
   sessionMode nc `shouldBe` TSMUser
   runRight_ $ do
     (aId1, bId1) <- makeConnectionForUsers a 1 b 1
@@ -961,8 +1094,8 @@ testTwoUsers = do
     b `hasClients` 1
     setNetworkConfig a nc {sessionMode = TSMEntity}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 2
 
     exchangeGreetingsMsgId 6 a bId1 b aId1
@@ -970,13 +1103,13 @@ testTwoUsers = do
     liftIO $ threadDelay 250000
     setNetworkConfig a nc {sessionMode = TSMUser}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 1
 
-    aUserId2 <- createUser a [noAuthSrv testSMPServer]
+    aUserId2 <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1
     exchangeGreetings a bId2 b aId2
     (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1
@@ -985,10 +1118,10 @@ testTwoUsers = do
     b `hasClients` 1
     setNetworkConfig a nc {sessionMode = TSMEntity}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 4
     exchangeGreetingsMsgId 8 a bId1 b aId1
     exchangeGreetingsMsgId 8 a bId1' b aId1'
@@ -997,14 +1130,14 @@ testTwoUsers = do
     liftIO $ threadDelay 250000
     setNetworkConfig a nc {sessionMode = TSMUser}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 2
     exchangeGreetingsMsgId 10 a bId1 b aId1
     exchangeGreetingsMsgId 10 a bId1' b aId1'
@@ -1014,10 +1147,15 @@ testTwoUsers = do
     hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
     hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
 
+getSMPAgentClient' :: AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
+getSMPAgentClient' cfg' initServers dbPath = do
+  Right st <- liftIO $ createAgentStore dbPath "" MCError
+  getSMPAgentClient cfg' initServers st
+
 testServerMultipleIdentities :: HasCallStack => IO ()
 testServerMultipleIdentities = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
@@ -1030,7 +1168,7 @@ testServerMultipleIdentities = do
     -- this saves queue with second server identity
     Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo"
     disconnectAgentClient bob
-    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2
     subscribeConnection bob' aliceId
     exchangeGreetingsMsgId 6 alice bobId bob' aliceId
   where

tests/AgentTests/MigrationTests.hs

@@ -0,0 +1,197 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module AgentTests.MigrationTests (migrationTests) where
+
+import Control.Monad
+import Data.Maybe (fromJust)
+import Data.Word (Word32)
+import Database.SQLite.Simple (fromOnly)
+import qualified Database.SQLite.Simple as DB
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError (MEDowngrade, MEUpgrade, MigrationError), SQLiteStore, closeSQLiteStore, createSQLiteStore, upMigration, withTransaction)
+import Simplex.Messaging.Agent.Store.SQLite.Migrations
+import System.Directory (removeFile)
+import System.Random (randomIO)
+import Test.Hspec
+
+migrationTests :: Spec
+migrationTests = do
+  it "should determine migrations to run" testMigrationsToRun
+  describe "run migrations" $ do
+    -- (init migrs, tables)
+    -- (final migrs, confirm modes, final tables or error)
+    it "up 1-2 tables (yes)" $
+      testMigration
+        ([m1], [t1])
+        ([m1, m2], [MCYesUp, MCYesUpDown], Right [t1, t2])
+    it "up 1-2 tables (error)" $
+      testMigration
+        ([m1], [t1])
+        ([m1, m2], [MCError], Left $ MEUpgrade [upMigration m2])
+    it "up 1-2 tables (error, down)" $
+      testMigration
+        ([m1], [t1])
+        ([m1, m2'], [MCError], Left $ MEUpgrade [upMigration m2'])
+    it "1-2 (different)" $
+      testMigration
+        ([m2], [t2])
+        ([m1, m2], [MCYesUp, MCYesUpDown, MCError], Left $ MigrationError $ MTREDifferent (name m1) (name m2))
+    it "up 2-4 tables (yes)" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m1, m2, m3, m4], [MCYesUp, MCYesUpDown], Right [t1, t2, t3, t4])
+    it "up 2-4 tables (error)" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m1, m2, m3, m4], [MCError], Left $ MEUpgrade [upMigration m3, upMigration m4])
+    it "up 2-4 tables (error, down)" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m1, m2, m3', m4'], [MCError], Left $ MEUpgrade [upMigration m3', upMigration m4'])
+    it "no change 2 tables" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m1, m2], [MCYesUp, MCYesUpDown, MCError], Right [t1, t2])
+    it "2 tables (different order)" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m2, m1], [MCYesUp, MCYesUpDown, MCError], Left $ MigrationError $ MTREDifferent (name m2) (name m1))
+    it "down 2-1 tables (no down)" $
+      testMigration
+        ([m1, m2], [t1, t2])
+        ([m1], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTRENoDown [name m2])
+    it "down 2-1 tables (error)" $
+      testMigration
+        ([m1, m2'], [t1, t2])
+        ([m1], [MCYesUp, MCError], Left $ MEDowngrade [name m2])
+    it "down 2-1 tables (yes)" $
+      testMigration
+        ([m1, m2'], [t1, t2])
+        ([m1], [MCYesUpDown], Right [t1])
+    it "down 4-2 tables (no down)" $
+      testMigration
+        ([m1, m2, m3, m4], [t1, t2, t3, t4])
+        ([m1, m2], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTRENoDown [name m3, name m4])
+    it "down 4-2 tables (partial down)" $ do
+      testMigration
+        ([m1, m2, m3, m4'], [t1, t2, t3, t4])
+        ([m1, m2], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTRENoDown [name m3])
+      testMigration
+        ([m1, m2, m3', m4], [t1, t2, t3, t4])
+        ([m1, m2], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTRENoDown [name m4])
+    it "down 4-2 tables (error)" $
+      testMigration
+        ([m1, m2, m3', m4'], [t1, t2, t3, t4])
+        ([m1, m2], [MCYesUp, MCError], Left $ MEDowngrade [name m3, name m4])
+    it "down 4-2 tables (yes)" $
+      testMigration
+        ([m1, m2, m3', m4'], [t1, t2, t3, t4])
+        ([m1, m2], [MCYesUpDown], Right [t1, t2])
+    it "4-2 tables (different)" $
+      testMigration
+        ([m1, m2, m3', m4'], [t1, t2, t3, t4])
+        ([m1, m3], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTREDifferent (name m3) (name m2))
+    it "4-3 tables (different)" $
+      testMigration
+        ([m1, m2, m3, m4], [t1, t2, t3, t4])
+        ([m1, m2, m4], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTREDifferent (name m4) (name m3))
+
+testDB :: FilePath
+testDB = "tests/tmp/test_migrations.db"
+
+m1 :: Migration
+m1 = Migration "20230301-migration1" "create table test1 (id1 integer primary key);" Nothing
+
+m1' :: Migration
+m1' = Migration "20230301-migration1" "create table test1 (id1 integer primary key);" (Just "drop table test1;")
+
+t1 :: String
+t1 = "test1"
+
+m2 :: Migration
+m2 = Migration "20230302-migration2" "create table test2 (id2 integer primary key);" Nothing
+
+m2' :: Migration
+m2' = Migration "20230302-migration2" "create table test2 (id2 integer primary key);" (Just "drop table test2;")
+
+t2 :: String
+t2 = "test2"
+
+m3 :: Migration
+m3 = Migration "20230303-migration3" "create table test3 (id3 integer primary key);" Nothing
+
+m3' :: Migration
+m3' = Migration "20230303-migration3" "create table test3 (id3 integer primary key);" (Just "drop table test3;")
+
+t3 :: String
+t3 = "test3"
+
+m4 :: Migration
+m4 = Migration "20230304-migration4" "create table test4 (id4 integer primary key);" Nothing
+
+m4' :: Migration
+m4' = Migration "20230304-migration4" "create table test4 (id4 integer primary key);" (Just "drop table test4;")
+
+t4 :: String
+t4 = "test4"
+
+downMigration :: Migration -> DownMigration
+downMigration = fromJust . toDownMigration
+
+testMigrationsToRun :: IO ()
+testMigrationsToRun = do
+  migrationsToRun [] [] `shouldBe` Right MTRNone
+  migrationsToRun [m1] [] `shouldBe` Right (MTRUp [m1])
+  migrationsToRun [] [m1] `shouldBe` Left (MTRENoDown ["20230301-migration1"])
+  migrationsToRun [] [m1'] `shouldBe` Right (MTRDown [downMigration m1'])
+  migrationsToRun [m1, m2] [] `shouldBe` Right (MTRUp [m1, m2])
+  migrationsToRun [] [m1, m2] `shouldBe` Left (MTRENoDown ["20230301-migration1", "20230302-migration2"])
+  migrationsToRun [] [m1', m2] `shouldBe` Left (MTRENoDown ["20230302-migration2"])
+  migrationsToRun [] [m1, m2'] `shouldBe` Left (MTRENoDown ["20230301-migration1"])
+  migrationsToRun [] [m1', m2'] `shouldBe` Right (MTRDown [downMigration m1', downMigration m2'])
+  migrationsToRun [m1] [m1] `shouldBe` Right MTRNone
+  migrationsToRun [m1] [m1'] `shouldBe` Right MTRNone
+  migrationsToRun [m1'] [m1] `shouldBe` Right MTRNone
+  migrationsToRun [m1] [m2] `shouldBe` Left (MTREDifferent "20230301-migration1" "20230302-migration2")
+  migrationsToRun [m1, m2] [m1] `shouldBe` Right (MTRUp [m2])
+  migrationsToRun [m1] [m1, m2] `shouldBe` Left (MTRENoDown ["20230302-migration2"])
+  migrationsToRun [m1] [m1, m2'] `shouldBe` Right (MTRDown [downMigration m2'])
+  migrationsToRun [m1, m2, m3] [m1] `shouldBe` Right (MTRUp [m2, m3])
+  migrationsToRun [m1] [m1, m2, m3] `shouldBe` Left (MTRENoDown ["20230302-migration2", "20230303-migration3"])
+  migrationsToRun [m1] [m1, m2', m3] `shouldBe` Left (MTRENoDown ["20230303-migration3"])
+  migrationsToRun [m1] [m1, m2, m3'] `shouldBe` Left (MTRENoDown ["20230302-migration2"])
+  migrationsToRun [m1] [m1, m2', m3'] `shouldBe` Right (MTRDown [downMigration m2', downMigration m3'])
+  migrationsToRun [m1, m2] [m1, m2] `shouldBe` Right MTRNone
+  migrationsToRun [m1, m2] [m2] `shouldBe` Left (MTREDifferent "20230301-migration1" "20230302-migration2")
+  migrationsToRun [m1', m2'] [m1, m2] `shouldBe` Right MTRNone
+  migrationsToRun [m1, m2] [m1, m2'] `shouldBe` Right MTRNone
+  migrationsToRun [m1, m2, m3] [m1, m2] `shouldBe` Right (MTRUp [m3])
+  migrationsToRun [m1, m2, m3, m4] [m1, m2] `shouldBe` Right (MTRUp [m3, m4])
+  migrationsToRun [m1, m2] [m1, m2, m3, m4] `shouldBe` Left (MTRENoDown ["20230303-migration3", "20230304-migration4"])
+  migrationsToRun [m1, m2] [m1, m2, m3', m4] `shouldBe` Left (MTRENoDown ["20230304-migration4"])
+  migrationsToRun [m1, m2] [m1, m2, m3, m4'] `shouldBe` Left (MTRENoDown ["20230303-migration3"])
+  migrationsToRun [m1, m2] [m1, m2, m3', m4'] `shouldBe` Right (MTRDown [downMigration m3', downMigration m4'])
+
+testMigration ::
+  ([Migration], [String]) ->
+  ([Migration], [MigrationConfirmation], Either MigrationError [String]) ->
+  IO ()
+testMigration (initMs, initTables) (finalMs, confirmModes, tablesOrError) = forM_ confirmModes $ \confirmMode -> do
+  r <- randomIO :: IO Word32
+  let dpPath = testDB <> show r
+  Right st <- createSQLiteStore dpPath "" initMs MCError
+  st `shouldHaveTables` initTables
+  closeSQLiteStore st
+  case tablesOrError of
+    Right tables -> do
+      Right st' <- createSQLiteStore dpPath "" finalMs confirmMode
+      st' `shouldHaveTables` tables
+      closeSQLiteStore st'
+    Left e -> do
+      Left e' <- createSQLiteStore dpPath "" finalMs confirmMode
+      e `shouldBe` e'
+  removeFile dpPath
+  where
+    shouldHaveTables :: SQLiteStore -> [String] -> IO ()
+    st `shouldHaveTables` expected = do
+      tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1;")
+      tables `shouldBe` "migrations" : expected

tests/AgentTests/NotificationTests.hs

@@ -9,7 +9,7 @@
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
+import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, getSMPAgentClient', makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
@@ -20,9 +20,9 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
-import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
+import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn, xit')
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers, databaseFile)
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -44,7 +44,7 @@ removeFileIfExists filePath = do
 
 notificationTests :: ATransport -> Spec
 notificationTests t =
-  after_ (removeFile (databaseFile testDB) >> removeFileIfExists (databaseFile testDB2)) $ do
+  after_ (removeFileIfExists testDB >> removeFileIfExists testDB2) $ do
     describe "Managing notification tokens" $ do
       it "should register and verify notification token" $
         withAPNSMockServer $ \apns ->
@@ -59,7 +59,8 @@ notificationTests t =
         withAPNSMockServer $ \apns ->
           testNtfTokenServerRestart t apns
     describe "Managing notification subscriptions" $ do
-      it "should create notification subscription for existing connection" $ \_ ->
+      -- fails on Ubuntu CI?
+      xit' "should create notification subscription for existing connection" $ \_ -> do
         withSmpServer t $
           withAPNSMockServer $ \apns ->
             withNtfServer t $ testNotificationSubscriptionExistingConnection apns
@@ -91,7 +92,7 @@ notificationTests t =
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient agentCfg initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -119,7 +120,7 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient agentCfg initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -143,8 +144,8 @@ testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient agentCfg initAgentServers
-  a' <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
+  a' <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -177,7 +178,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient agentCfg initAgentServers
+  a <- getSMPAgentClient' agentCfg initAgentServers testDB
   let tkn = DeviceToken PPApnsTest "abcd"
   ntfData <- withNtfServer t . runRight $ do
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -188,7 +189,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
   threadDelay 1000000
   disconnectAgentClient a
-  a' <- getSMPAgentClient agentCfg initAgentServers
+  a' <- getSMPAgentClient' agentCfg initAgentServers testDB
   -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
   -- so that repeat verification happens without restarting the clients, when notification arrives
   withNtfServer t . runRight_ $ do
@@ -206,8 +207,8 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
@@ -239,7 +240,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  aliceNtf <- getSMPAgentClient agentCfg initAgentServers
+  aliceNtf <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
     pure ()
@@ -262,8 +263,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 
 testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     -- alice registers notification token
     DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -318,8 +319,8 @@ registerTestToken a token mode apnsQ = do
 
 testChangeNotificationsMode :: APNSMockServer -> IO ()
 testChangeNotificationsMode APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   runRight_ $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
@@ -382,8 +383,8 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
 
 testChangeToken :: APNSMockServer -> IO ()
 testChangeToken APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
@@ -405,7 +406,7 @@ testChangeToken APNSMockServer {apnsQ} = do
     pure (aliceId, bobId)
   disconnectAgentClient alice
 
-  alice1 <- getSMPAgentClient agentCfg initAgentServers
+  alice1 <- getSMPAgentClient' agentCfg initAgentServers testDB
   runRight_ $ do
     subscribeConnection alice1 bobId
     -- change notification token
@@ -425,8 +426,8 @@ testChangeToken APNSMockServer {apnsQ} = do
 
 testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
 testNotificationsStoreLog t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -451,8 +452,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
 
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  alice <- getSMPAgentClient' agentCfg initAgentServers testDB
+  bob <- getSMPAgentClient' agentCfg initAgentServers testDB2
   (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -466,12 +467,12 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     pure (aliceId, bobId)
 
   runRight_ @AgentErrorType $ do
-    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+    nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+    nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
 
   withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do
-    get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
+    nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
+    nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
     liftIO $ threadDelay 1000000
     5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT 5)
@@ -481,8 +482,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
 
 testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
 testSwitchNotifications servers APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient agentCfg servers
-  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  a <- getSMPAgentClient' agentCfg servers testDB
+  b <- getSMPAgentClient' agentCfg {initialClientId = 1} servers testDB2
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId

tests/AgentTests/SQLiteTests.hs

@@ -52,7 +52,8 @@ createStore = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  createSQLiteStore (testDB <> show r) "" Migrations.app True
+  Right st <- createSQLiteStore (testDB <> show r) "" Migrations.app MCError
+  pure st
 
 removeStore :: SQLiteStore -> IO ()
 removeStore db = do
@@ -427,7 +428,8 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
       msgFlags = SMP.noMsgFlags,
       msgBody = hw,
       internalHash,
-      externalPrevSndHash = "hash_from_sender"
+      externalPrevSndHash = "hash_from_sender",
+      encryptedMsgHash = "encrypted_msg_hash"
     }
 
 testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvQueue -> RcvMsgData -> Expectation

tests/AgentTests/SchemaDump.hs

@@ -1,29 +1,67 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module AgentTests.SchemaDump where
 
+import Control.DeepSeq
 import Control.Monad (void)
+import Data.List (dropWhileEnd)
+import Data.Maybe (fromJust, isJust)
 import Simplex.Messaging.Agent.Store.SQLite
+import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..), MigrationsToRun (..), toDownMigration)
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
+import Simplex.Messaging.Util (ifM)
+import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
 import Test.Hspec
 
 testDB :: FilePath
 testDB = "tests/tmp/test_agent_schema.db"
 
-schema :: FilePath
-schema = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql"
+appSchema :: FilePath
+appSchema = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql"
+
+testSchema :: FilePath
+testSchema = "tests/tmp/test_agent_schema.sql"
 
 schemaDumpTest :: Spec
-schemaDumpTest =
+schemaDumpTest = do
   it "verify and overwrite schema dump" testVerifySchemaDump
+  it "verify schema down migrations" testSchemaMigrations
 
 testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
-  void $ createSQLiteStore testDB "" Migrations.app False
-  void $ readCreateProcess (shell $ "touch " <> schema) ""
-  savedSchema <- readFile schema
-  savedSchema `seq` pure ()
-  void $ readCreateProcess (shell $ "sqlite3 " <> testDB <> " '.schema --indent' > " <> schema) ""
-  currentSchema <- readFile schema
-  savedSchema `shouldBe` currentSchema
+  savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
+  savedSchema `deepseq` pure ()
+  void $ createSQLiteStore testDB "" Migrations.app MCConsole
+  getSchema testDB appSchema `shouldReturn` savedSchema
+  removeFile testDB
+
+testSchemaMigrations :: IO ()
+testSchemaMigrations = do
+  let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app
+  Right st <- createSQLiteStore testDB "" noDownMigrations MCError
+  mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app
+  closeSQLiteStore st
+  removeFile testDB
+  removeFile testSchema
+  where
+    testDownMigration st m = do
+      putStrLn $ "down migration " <> name m
+      let downMigr = fromJust $ toDownMigration m
+      schema <- getSchema testDB testSchema
+      withConnection st (`Migrations.run` MTRUp [m])
+      schema' <- getSchema testDB testSchema
+      schema' `shouldNotBe` schema
+      withConnection st (`Migrations.run` MTRDown [downMigr])
+      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
+  void $ readCreateProcess (shell $ "sqlite3 " <> dpPath <> " '.schema --indent' > " <> schemaPath) ""
+  sch <- readFile schemaPath
+  sch `deepseq` pure sch

tests/CoreTests/RetryIntervalTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module CoreTests.RetryIntervalTests where
@@ -36,22 +37,50 @@ testRetryIntervalSameMode =
   it "should increase elapased time and interval when the mode stays the same" $ do
     lock <- newEmptyTMVarIO
     intervals <- newTVarIO []
+    reportedIntervals <- newTVarIO []
     ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \loop -> do
+    withRetryLock2 testRI lock $ \(RI2State slow fast) loop -> do
       ints <- addInterval intervals ts
+      atomically $ modifyTVar' reportedIntervals ((slow, fast) :)
       when (length ints < 9) $ loop RIFast
     (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4]
+    (reverse <$> readTVarIO reportedIntervals)
+      `shouldReturn` [ (20000, 10000),
+                       (20000, 10000),
+                       (20000, 15000),
+                       (20000, 22500),
+                       (20000, 33750),
+                       (20000, 40000),
+                       (20000, 40000),
+                       (20000, 40000),
+                       (20000, 40000)
+                     ]
 
 testRetryIntervalSwitchMode :: Spec
 testRetryIntervalSwitchMode =
   it "should increase elapased time and interval when the mode stays the same" $ do
     lock <- newEmptyTMVarIO
     intervals <- newTVarIO []
+    reportedIntervals <- newTVarIO []
     ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \loop -> do
+    withRetryLock2 testRI lock $ \(RI2State slow fast) loop -> do
       ints <- addInterval intervals ts
+      atomically $ modifyTVar' reportedIntervals ((slow, fast) :)
       when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow
     (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4]
+    (reverse <$> readTVarIO reportedIntervals)
+      `shouldReturn` [ (20000, 10000),
+                       (20000, 10000),
+                       (20000, 15000),
+                       (20000, 22500),
+                       (20000, 33750),
+                       (20000, 40000),
+                       (20000, 40000),
+                       (30000, 40000),
+                       (40000, 40000),
+                       (40000, 40000),
+                       (40000, 40000)
+                     ]
 
 addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
 addInterval intervals ts = do

tests/FileDescriptionTests.hs

@@ -36,10 +36,10 @@ testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTF
 testCbNonce :: C.CbNonce
 testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
 
-fileDesc :: FileDescription 'FPRecipient
+fileDesc :: FileDescription 'FRecipient
 fileDesc =
   FileDescription
-    { party = SRecipient,
+    { party = SFRecipient,
       size = FileSize $ mb 26,
       digest = FileDigest "abc",
       key = testSbKey,
@@ -93,7 +93,7 @@ fileDesc =
 yamlFileDesc :: YAMLFileDescription
 yamlFileDesc =
   YAMLFileDescription
-    { party = FPRecipient,
+    { party = FRecipient,
       size = "26mb",
       chunkSize = "8mb",
       digest = FileDigest "abc",

tests/NtfServerTests.hs

@@ -86,7 +86,8 @@ v .-> key =
 
 testNotificationSubscription :: ATransport -> Spec
 testNotificationSubscription (ATransport t) =
-  it "should create notification subscription and notify when message is received" $ do
+  -- hangs on Ubuntu 20/22
+  xit' "should create notification subscription and notify when message is received" $ do
     (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
     (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519

tests/SMPAgentClient.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
@@ -29,14 +30,16 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Agent.Store (UserId)
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
 import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
+import XFTPClient (testXFTPServer)
 
 agentTestHost :: NonEmpty TransportHost
 agentTestHost = "localhost"
@@ -50,14 +53,14 @@ agentTestPort2 = "5011"
 agentTestPort3 :: ServiceName
 agentTestPort3 = "5012"
 
-testDB :: AgentDatabase
-testDB = AgentDBFile {dbFile = "tests/tmp/smp-agent.test.protocol.db", dbKey = ""}
+testDB :: FilePath
+testDB = "tests/tmp/smp-agent.test.protocol.db"
 
-testDB2 :: AgentDatabase
-testDB2 = AgentDBFile {dbFile = "tests/tmp/smp-agent2.test.protocol.db", dbKey = ""}
+testDB2 :: FilePath
+testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
 
-testDB3 :: AgentDatabase
-testDB3 = AgentDBFile {dbFile = "tests/tmp/smp-agent3.test.protocol.db", dbKey = ""}
+testDB3 :: FilePath
+testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
 
 smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
 smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
@@ -65,8 +68,8 @@ smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
     get h = do
       t@(_, _, cmdStr) <- tGetRaw h
       case parseAll networkCommandP cmdStr of
-        Right (ACmd SAgent CONNECT {}) -> get h
-        Right (ACmd SAgent DISCONNECT {}) -> get h
+        Right (ACmd SAgent _ CONNECT {}) -> get h
+        Right (ACmd SAgent _ DISCONNECT {}) -> get h
         _ -> pure t
 
 runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a
@@ -85,10 +88,10 @@ runSmpAgentServerTest test =
 smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
 smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
 
-runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, AgentDatabase)] -> ([c] -> IO a) -> IO a
+runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO a) -> IO a
 runSmpAgentTestN agents test = withSmpServer t $ run agents []
   where
-    run :: [(ServiceName, ServiceName, AgentDatabase)] -> [c] -> IO a
+    run :: [(ServiceName, ServiceName, FilePath)] -> [c] -> IO a
     run [] hs = test hs
     run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
     t = transport @c
@@ -101,7 +104,7 @@ runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClien
     run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
     t = transport @c
 
-smpAgentTestN :: Transport c => [(ServiceName, ServiceName, AgentDatabase)] -> ([c] -> IO ()) -> Expectation
+smpAgentTestN :: Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO ()) -> Expectation
 smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
 
 smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
@@ -178,6 +181,7 @@ initAgentServers =
   InitialAgentServers
     { smp = userServers [noAuthSrv testSMPServer],
       ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
+      xftp = userServers [noAuthSrv testXFTPServer],
       netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
     }
 
@@ -189,10 +193,11 @@ agentCfg =
   defaultAgentConfig
     { tcpPort = agentTestPort,
       tbqSize = 4,
-      database = testDB,
+      -- database = testDB,
       smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS)},
       ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS)},
       reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
+      xftpNotifyErrsOnRetry = False,
       ntfWorkerDelay = 1000,
       ntfSMPWorkerDelay = 1000,
       caCertificateFile = "tests/fixtures/ca.crt",
@@ -200,24 +205,29 @@ agentCfg =
       certificateFile = "tests/fixtures/server.crt"
     }
 
-withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m () -> (ThreadId -> m a) -> m a
+type AgentTestMonad m = (MonadUnliftIO m, MonadRandom m, MonadFail m)
+
+withSmpAgentThreadOn_ :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> m () -> (ThreadId -> m a) -> m a
 withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
-  let cfg' = agentCfg {tcpPort = port', database = db'}
+  let cfg' = agentCfg {tcpPort = port'}
       initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
    in serverBracket
-        (\started -> runSMPAgentBlocking t started cfg' initServers')
+        ( \started -> do
+            Right st <- liftIO $ createAgentStore db' "" MCError
+            runSMPAgentBlocking t cfg' initServers' st started
+        )
         afterProcess
 
-userServers :: NonEmpty SMPServerWithAuth -> Map UserId (NonEmpty SMPServerWithAuth)
+userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p))
 userServers srvs = M.fromList [(1, srvs)]
 
-withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile (dbFile db')
+withSmpAgentThreadOn :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile db'
 
-withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m a -> m a
+withSmpAgentOn :: AgentTestMonad m => ATransport -> (ServiceName, ServiceName, FilePath) -> m a -> m a
 withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
 
-withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withSmpAgent :: AgentTestMonad m => ATransport -> m a -> m a
 withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
 testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a

tests/SMPClient.hs

@@ -25,6 +25,8 @@ import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Version
+import System.Environment (lookupEnv)
+import System.Info (os)
 import Test.Hspec
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
@@ -55,6 +57,14 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 testServerStatsBackupFile :: FilePath
 testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
+xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
+xit' = if os == "linux" then xit else it
+
+xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
+xit'' d t = do
+  ci <- runIO $ lookupEnv "CI"
+  (if ci == Just "true" then xit else it) d t
+
 testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
 testSMPClient client = do
   Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost

tests/ServerTests.hs

@@ -55,7 +55,9 @@ 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)" $ testRestoreMessagesV2 t
+  describe "Restore messages (old / v2)" $ do
+    testRestoreMessagesV2 t
+    testRestoreExpireMessages t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
@@ -779,6 +781,62 @@ 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
@@ -901,7 +959,8 @@ testMsgExpireOnSend t =
 
 testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
 testMsgExpireOnInterval t =
-  it "should expire messages that are not received before messageTTL after expiry interval" $ do
+  -- fails on ubuntu
+  xit' "should expire messages that are not received before messageTTL after expiry interval" $ do
     (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->

tests/Test.hs

@@ -16,6 +16,7 @@ import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
+import XFTPAgent
 import XFTPCLI
 import XFTPServerTests (xftpServerTests)
 
@@ -46,4 +47,5 @@ main = do
           describe "XFTP server" xftpServerTests
           describe "XFTP file description" fileDescriptionTests
           describe "XFTP CLI" xftpCLITests
+          describe "XFTP agent" xftpAgentTests
         describe "Server CLIs" cliTests

tests/XFTPAgent.hs

@@ -0,0 +1,411 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module XFTPAgent where
+
+import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet)
+import Control.Concurrent (threadDelay)
+import Control.Logger.Simple
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
+import Data.List (find, isSuffixOf)
+import Data.Maybe (fromJust)
+import SMPAgentClient (agentCfg, initAgentServers, testDB)
+import SMPClient (xit'')
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType (AUTH))
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
+import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
+import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory)
+import System.FilePath ((</>))
+import System.Timeout (timeout)
+import Test.Hspec
+import XFTPCLI
+import XFTPClient
+
+xftpAgentTests :: Spec
+xftpAgentTests = around_ testBracket . describe "Functional API" $ do
+  it "should send and receive file" testXFTPAgentSendReceive
+  it "should resume receiving file after restart" testXFTPAgentReceiveRestore
+  it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
+  xit'' "should resume sending file after restart" testXFTPAgentSendRestore
+  it "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
+  it "should delete sent file on server" testXFTPAgentDelete
+  it "should resume deleting file after restart" testXFTPAgentDeleteRestore
+  it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
+  describe "XFTP server test via agent API" $ do
+    it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
+    let srv1 = testXFTPServer2 {keyHash = "1234"}
+    it "should fail with incorrect fingerprint" $ do
+      testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+    describe "server with password" $ do
+      let auth = Just "abcd"
+          srv = ProtoServerWithAuth testXFTPServer2
+          authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP AUTH)
+      it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing
+      it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
+      it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
+
+rfProgress :: (MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
+rfProgress c expected = loop 0
+  where
+    loop prev = do
+      (_, _, RFPROG rcvd total) <- rfGet c
+      checkProgress (prev, expected) (rcvd, total) loop
+
+sfProgress :: (MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
+sfProgress c expected = loop 0
+  where
+    loop prev = do
+      (_, _, SFPROG sent total) <- sfGet c
+      checkProgress (prev, expected) (sent, total) loop
+
+-- checks that progress increases till it reaches total
+checkProgress :: MonadIO m => (Int64, Int64) -> (Int64, Int64) -> (Int64 -> m ()) -> m ()
+checkProgress (prev, expected) (progress, total) loop
+  | total /= expected = error "total /= expected"
+  | progress <= prev = error "progress <= prev"
+  | progress > total = error "progress > total"
+  | progress < total = loop progress
+  | otherwise = pure ()
+
+testXFTPAgentSendReceive :: IO ()
+testXFTPAgentSendReceive = withXFTPServer $ do
+  filePath <- createRandomFile
+
+  -- send file, delete snd file internally
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+  (rfd1, rfd2) <- runRight $ do
+    (sfId, _, rfd1, rfd2) <- testSend sndr filePath
+    xftpDeleteSndFileInternal sndr sfId
+    pure (rfd1, rfd2)
+
+  -- receive file, delete rcv file
+  testReceiveDelete rfd1 filePath
+  testReceiveDelete rfd2 filePath
+  where
+    testReceiveDelete rfd originalFilePath = do
+      rcp <- getSMPAgentClient' agentCfg initAgentServers testDB
+      runRight_ $ do
+        rfId <- testReceive rcp rfd originalFilePath
+        xftpDeleteRcvFile rcp rfId
+
+createRandomFile :: IO FilePath
+createRandomFile = do
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  getFileSize filePath `shouldReturn` mb 17
+  pure filePath
+
+testSend :: AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
+testSend sndr filePath = do
+  xftpStartWorkers sndr (Just senderFiles)
+  sfId <- xftpSendFile sndr 1 filePath 2
+  sfProgress sndr $ mb 18
+  ("", sfId', SFDONE sndDescr [rfd1, rfd2]) <- sfGet sndr
+  liftIO $ sfId' `shouldBe` sfId
+  pure (sfId, sndDescr, rfd1, rfd2)
+
+testReceive :: AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
+testReceive rcp rfd originalFilePath = do
+  xftpStartWorkers rcp (Just recipientFiles)
+  rfId <- xftpReceiveFile rcp 1 rfd
+  rfProgress rcp $ mb 18
+  ("", rfId', RFDONE path) <- rfGet rcp
+  liftIO $ do
+    rfId' `shouldBe` rfId
+    file <- B.readFile originalFilePath
+    B.readFile path `shouldReturn` file
+  pure rfId
+
+getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
+getFileDescription path =
+  ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
+
+logCfgNoLogs :: LogConfig
+logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
+
+testXFTPAgentReceiveRestore :: IO ()
+testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
+  filePath <- createRandomFile
+
+  rfd <- withXFTPServerStoreLogOn $ \_ -> do
+    -- send file
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight $ do
+      (_, _, rfd, _) <- testSend sndr filePath
+      pure rfd
+
+  -- receive file - should not succeed with server down
+  rcp <- getSMPAgentClient' agentCfg initAgentServers testDB
+  rfId <- runRight $ do
+    xftpStartWorkers rcp (Just recipientFiles)
+    rfId <- xftpReceiveFile rcp 1 rfd
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure rfId
+  disconnectAgentClient rcp
+
+  [prefixDir] <- listDirectory recipientFiles
+  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
+  doesDirectoryExist tmpPath `shouldReturn` True
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- receive file - should start downloading with server up
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+    ("", rfId', RFPROG _ _) <- rfGet rcp'
+    liftIO $ rfId' `shouldBe` rfId
+    disconnectAgentClient rcp'
+
+  threadDelay 100000
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- receive file - should continue downloading with server up
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+    rfProgress rcp' $ mb 18
+    ("", rfId', RFDONE path) <- rfGet rcp'
+    liftIO $ do
+      rfId' `shouldBe` rfId
+      file <- B.readFile filePath
+      B.readFile path `shouldReturn` file
+
+  -- tmp path should be removed after receiving file
+  doesDirectoryExist tmpPath `shouldReturn` False
+
+testXFTPAgentReceiveCleanup :: IO ()
+testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
+  filePath <- createRandomFile
+
+  rfd <- withXFTPServerStoreLogOn $ \_ -> do
+    -- send file
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight $ do
+      (_, _, rfd, _) <- testSend sndr filePath
+      pure rfd
+
+  -- receive file - should not succeed with server down
+  rcp <- getSMPAgentClient' agentCfg initAgentServers testDB
+  rfId <- runRight $ do
+    xftpStartWorkers rcp (Just recipientFiles)
+    rfId <- xftpReceiveFile rcp 1 rfd
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure rfId
+  disconnectAgentClient rcp
+
+  [prefixDir] <- listDirectory recipientFiles
+  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
+  doesDirectoryExist tmpPath `shouldReturn` True
+
+  withXFTPServerThreadOn $ \_ -> do
+    -- receive file - should fail with AUTH error
+    rcp' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+    ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
+    rfId' `shouldBe` rfId
+
+  -- tmp path should be removed after permanent error
+  doesDirectoryExist tmpPath `shouldReturn` False
+
+testXFTPAgentSendRestore :: IO ()
+testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
+  filePath <- createRandomFile
+
+  -- send file - should not succeed with server down
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+  sfId <- runRight $ do
+    xftpStartWorkers sndr (Just senderFiles)
+    sfId <- xftpSendFile sndr 1 filePath 2
+    liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file
+    pure sfId
+  disconnectAgentClient sndr
+
+  dirEntries <- listDirectory senderFiles
+  let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
+      prefixPath = senderFiles </> prefixDir
+      encPath = prefixPath </> "xftp.encrypted"
+  doesDirectoryExist prefixPath `shouldReturn` True
+  doesFileExist encPath `shouldReturn` True
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- send file - should start uploading with server up
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+    ("", sfId', SFPROG _ _) <- sfGet sndr'
+    liftIO $ sfId' `shouldBe` sfId
+    disconnectAgentClient sndr'
+
+  threadDelay 100000
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- send file - should continue uploading with server up
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+    sfProgress sndr' $ mb 18
+    ("", sfId', SFDONE _sndDescr [rfd1, _rfd2]) <- sfGet sndr'
+    liftIO $ sfId' `shouldBe` sfId
+
+    -- prefix path should be removed after sending file
+    doesDirectoryExist prefixPath `shouldReturn` False
+    doesFileExist encPath `shouldReturn` False
+
+    -- receive file
+    rcp <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $
+      void $ testReceive rcp rfd1 filePath
+
+testXFTPAgentSendCleanup :: IO ()
+testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
+  filePath <- createRandomFile
+
+  sfId <- withXFTPServerStoreLogOn $ \_ -> do
+    -- send file
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+    sfId <- runRight $ do
+      xftpStartWorkers sndr (Just senderFiles)
+      sfId <- xftpSendFile sndr 1 filePath 2
+      -- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server
+      forM_ [1 .. 5 :: Integer] $ \_ -> do
+        (_, _, SFPROG _ _) <- sfGet sndr
+        pure ()
+      pure sfId
+    disconnectAgentClient sndr
+    pure sfId
+
+  dirEntries <- listDirectory senderFiles
+  let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
+      prefixPath = senderFiles </> prefixDir
+      encPath = prefixPath </> "xftp.encrypted"
+  doesDirectoryExist prefixPath `shouldReturn` True
+  doesFileExist encPath `shouldReturn` True
+
+  withXFTPServerThreadOn $ \_ -> do
+    -- send file - should fail with AUTH error
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+    ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
+    sfId' `shouldBe` sfId
+
+    -- prefix path should be removed after permanent error
+    doesDirectoryExist prefixPath `shouldReturn` False
+    doesFileExist encPath `shouldReturn` False
+
+testXFTPAgentDelete :: IO ()
+testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
+  withXFTPServer $ do
+    filePath <- createRandomFile
+
+    -- send file
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+    (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
+
+    -- receive file
+    rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $
+      void $ testReceive rcp1 rfd1 filePath
+
+    length <$> listDirectory xftpServerFiles `shouldReturn` 6
+
+    -- delete file
+    runRight $ do
+      xftpStartWorkers sndr (Just senderFiles)
+      xftpDeleteSndFileRemote sndr 1 sfId sndDescr
+      Nothing <- liftIO $ 100000 `timeout` sfGet sndr
+      pure ()
+
+    threadDelay 1000000
+    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+
+    -- receive file - should fail with AUTH error
+    rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight $ do
+      xftpStartWorkers rcp2 (Just recipientFiles)
+      rfId <- xftpReceiveFile rcp2 1 rfd2
+      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
+      liftIO $ rfId' `shouldBe` rfId
+
+testXFTPAgentDeleteRestore :: IO ()
+testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
+  filePath <- createRandomFile
+
+  (sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do
+    -- send file
+    sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+    (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
+
+    -- receive file
+    rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $
+      void $ testReceive rcp1 rfd1 filePath
+
+    pure (sfId, sndDescr, rfd2)
+
+  -- delete file - should not succeed with server down
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+  runRight $ do
+    xftpStartWorkers sndr (Just senderFiles)
+    xftpDeleteSndFileRemote sndr 1 sfId sndDescr
+    liftIO $ timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt
+  disconnectAgentClient sndr
+
+  threadDelay 300000
+  length <$> listDirectory xftpServerFiles `shouldReturn` 6
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- delete file - should succeed with server up
+    sndr' <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+
+    threadDelay 1000000
+    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+
+    -- receive file - should fail with AUTH error
+    rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB
+    runRight $ do
+      xftpStartWorkers rcp2 (Just recipientFiles)
+      rfId <- xftpReceiveFile rcp2 1 rfd2
+      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
+      liftIO $ rfId' `shouldBe` rfId
+
+testXFTPAgentRequestAdditionalRecipientIDs :: IO ()
+testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
+  filePath <- createRandomFile
+
+  -- send file
+  sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
+  rfds <- runRight $ do
+    xftpStartWorkers sndr (Just senderFiles)
+    sfId <- xftpSendFile sndr 1 filePath 500
+    sfProgress sndr $ mb 18
+    ("", sfId', SFDONE _sndDescr rfds) <- sfGet sndr
+    liftIO $ do
+      sfId' `shouldBe` sfId
+      length rfds `shouldBe` 500
+    pure rfds
+
+  -- receive file using different descriptions
+  -- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed
+  testReceive' (head rfds) filePath
+  testReceive' (rfds !! 99) filePath
+  testReceive' (rfds !! 299) filePath
+  testReceive' (rfds !! 499) filePath
+  where
+    testReceive' rfd originalFilePath = do
+      rcp <- getSMPAgentClient' agentCfg initAgentServers testDB
+      runRight_ $
+        void $ testReceive rcp rfd originalFilePath
+
+testXFTPServerTest :: Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
+testXFTPServerTest newFileBasicAuth srv =
+  withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
+    a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
+    runRight $ testProtocolServer a 1 srv

tests/XFTPCLI.hs

@@ -33,66 +33,65 @@ senderFiles = "tests/tmp/xftp-sender-files"
 recipientFiles :: FilePath
 recipientFiles = "tests/tmp/xftp-recipient-files"
 
+xftpCLI :: [String] -> IO [String]
+xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
+
 testXFTPCLISendReceive :: IO ()
 testXFTPCLISendReceive = withXFTPServer $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
   getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
   testInfoFile fdRcv1 "Recipient"
   testReceiveFile fdRcv1 "testfile" file
   testInfoFile fdRcv2 "Recipient"
   testReceiveFile fdRcv2 "testfile_1" file
   testInfoFile fdSnd "Sender"
-  xftp ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
+  xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
     `shouldThrow` anyException
   where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testInfoFile fd party = do
-      xftp ["info", fd]
+      xftpCLI ["info", fd]
         `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
     testReceiveFile fd fileName file = do
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
       progress `shouldSatisfy` downloadProgress fileName
-      recvResult `shouldBe` ["File description can't be used again"]
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLISendReceive2servers :: IO ()
 testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
   getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
   testReceiveFile fdRcv1 "testfile" file
   testReceiveFile fdRcv2 "testfile_1" file
   where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testReceiveFile fd fileName file = do
-      partyStr : sizeStr : srvStr : srvs <- xftp ["info", fd]
+      partyStr : sizeStr : srvStr : srvs <- xftpCLI ["info", fd]
       partyStr `shouldContain` "Recipient file description"
       sizeStr `shouldBe` "File download size: 18mb"
       srvStr `shouldBe` "File server(s):"
@@ -102,46 +101,43 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
           srv1 `shouldContain` testXFTPServerStr
           srv2 `shouldContain` testXFTPServerStr2
         _ -> print srvs >> error "more than 2 servers returned"
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
       progress `shouldSatisfy` downloadProgress fileName
-      recvResult `shouldBe` ["File description can't be used again"]
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLIDelete :: IO ()
 testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
   getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
-  xftp ["del", fdRcv1]
+  xftpCLI ["del", fdRcv1]
     `shouldThrow` anyException
-  progress1 : recvResult <- xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp"]
+  progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
   progress1 `shouldSatisfy` downloadProgress "testfile"
-  recvResult `shouldBe` ["File description can't be used again"]
+  recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."]
   LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
   fs1 <- listDirectory xftpServerFiles
   fs2 <- listDirectory xftpServerFiles2
   length fs1 + length fs2 `shouldBe` 6
-  xftp ["del", fdSnd]
-    `shouldReturn` ["File deleted"]
+  xftpCLI ["del", fdSnd, "-y"]
+    `shouldReturn` ["File deleted!            \r", "File description " <> fdSnd <> " is deleted."]
   listDirectory xftpServerFiles >>= (`shouldBe` [])
   listDirectory xftpServerFiles2 >>= (`shouldBe` [])
-  xftp ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
+  xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
     `shouldThrow` anyException
-  where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
 
 testPrepareChunkSizes :: IO ()
 testPrepareChunkSizes = do
@@ -161,8 +157,13 @@ testPrepareChunkSizes = do
     r3 = replicate 3
 
 uploadProgress :: String -> Bool
-uploadProgress s = "Uploading file..." `isPrefixOf` s && "File uploaded!" `isInfixOf` s
+uploadProgress s =
+  "Encrypting file..." `isPrefixOf` s
+    && "Uploading file..." `isInfixOf` s
+    && "File uploaded!" `isInfixOf` s
 
 downloadProgress :: FilePath -> String -> Bool
 downloadProgress fileName s =
-  "Downloading file..." `isPrefixOf` s && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s
+  "Downloading file..." `isPrefixOf` s
+    && "Decrypting file..." `isInfixOf` s
+    && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s

tests/XFTPClient.hs

@@ -28,6 +28,12 @@ xftpTest2 test = xftpTestN 2 _test
     _test [h1, h2] = test h1 h2
     _test _ = error "expected 2 handles"
 
+xftpTest4 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> Expectation
+xftpTest4 test = xftpTestN 4 _test
+  where
+    _test [h1, h2, h3, h4] = test h1 h2 h3 h4
+    _test _ = error "expected 4 handles"
+
 runXFTPTest :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
 runXFTPTest test = withXFTPServer $ testXFTPClient test
 
@@ -39,7 +45,7 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients []
     run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
 
 withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
-withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile}
+withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
 
 withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
 withXFTPServerCfg cfg =
@@ -65,6 +71,9 @@ xftpTestPort2 = "7001"
 testXFTPServer :: XFTPServer
 testXFTPServer = fromString testXFTPServerStr
 
+testXFTPServer2 :: XFTPServer
+testXFTPServer2 = fromString testXFTPServerStr2
+
 testXFTPServerStr :: String
 testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000"
 
@@ -80,6 +89,9 @@ xftpServerFiles2 = "tests/tmp/xftp-server-files2"
 testXFTPLogFile :: FilePath
 testXFTPLogFile = "tests/tmp/xftp-server-store.log"
 
+testXFTPStatsBackupFile :: FilePath
+testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
+
 testXFTPServerConfig :: XFTPServerConfig
 testXFTPServerConfig =
   XFTPServerConfig
@@ -98,7 +110,7 @@ testXFTPServerConfig =
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
-      serverStatsBackupFile = Just "tests/tmp/xftp-server-stats.log",
+      serverStatsBackupFile = Nothing,
       logTLSErrors = True
     }
 
@@ -107,6 +119,6 @@ testXFTPClientConfig = defaultXFTPClientConfig
 
 testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
 testXFTPClient client =
-  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (pure ()) >>= \case
+  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case
     Right c -> client c
     Left e -> error $ show e

tests/XFTPServerTests.hs

@@ -41,6 +41,7 @@ xftpServerTests =
     $ do
       it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
       it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
+      it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients
       it "should delete file chunk (1 client)" testFileChunkDelete
       it "should delete file chunk (2 clients)" testFileChunkDelete2
       it "should acknowledge file chunk reception (1 client)" testFileChunkAck
@@ -83,7 +84,7 @@ runTestFileChunkDelivery s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
       chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
@@ -97,6 +98,26 @@ runTestFileChunkDelivery s r = do
   downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
 
+testFileChunkDeliveryAddRecipients :: Expectation
+testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey3, rpKey3) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId1]) <- createXFTPChunk s spKey file [rcvKey1] Nothing
+  [rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3]
+  uploadXFTPChunk s spKey sId chunkSpec
+  let testReceiveChunk r rpKey rId fPath = do
+        downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
+        liftIO $ B.readFile fPath `shouldReturn` bytes
+  testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1"
+  testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
+  testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3"
+
 testFileChunkDelete :: Expectation
 testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
 
@@ -108,7 +129,7 @@ runTestFileChunkDelete s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
       chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
@@ -136,7 +157,7 @@ runTestFileChunkAck s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
       chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
   (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
@@ -156,7 +177,7 @@ testWrongChunkSize = xftpTest $ \c -> runRight_ $ do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, _rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96)
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = kb 96, digest}
   void (createXFTPChunk c spKey file [rcvKey] Nothing)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
@@ -167,7 +188,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
     (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
-    digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+    digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
     let file = FileInfo {sndKey, size = chSize, digest}
         chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
     (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
@@ -190,7 +211,7 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
     (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
-    digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+    digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
     let file = FileInfo {sndKey, size = chSize, digest}
         chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
         download rId = do
@@ -217,7 +238,7 @@ testFileLog = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   sIdVar <- newTVarIO ""
   rIdVar1 <- newTVarIO ""
   rIdVar2 <- newTVarIO ""
@@ -235,6 +256,7 @@ testFileLog = do
     download c rpKey1 rId1 digest bytes
     download c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 3
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   withXFTPServerThreadOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
     sId <- liftIO $ readTVarIO sIdVar
@@ -257,6 +279,7 @@ testFileLog = do
     -- recipient 2 can download
     download c rpKey2 rId2 digest bytes
   logSize testXFTPLogFile `shouldReturn` 4
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   withXFTPServerStoreLogOn $ \_ -> pure () -- ack is compacted - -1 from log
   logSize testXFTPLogFile `shouldReturn` 3
@@ -273,11 +296,14 @@ testFileLog = do
     -- sender can delete - +1 to log
     deleteXFTPChunk c spKey sId
   logSize testXFTPLogFile `shouldReturn` 4
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start
   logSize testXFTPLogFile `shouldReturn` 0
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
 
   removeFile testXFTPLogFile
+  removeFile testXFTPStatsBackupFile
   where
     download c rpKey rId digest bytes = do
       downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
@@ -290,7 +316,7 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
       (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
       (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
       bytes <- liftIO $ createTestChunk testChunkPath
-      digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+      digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
       let file = FileInfo {sndKey, size = chSize, digest}
           chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
       if success