6.3.1.0

* ci: build cache, remove 20.04, minor refactor

* scripts: update build reproducibility script

* script: add postgresql reproducibility

* script: no cache when building image

* scripts: force symlinks

* scripts: also download prebuilt postgresql binary

* scripts: add missing app var

.github/workflows/build.yml

@@ -11,61 +11,123 @@ on:
 
 jobs:
   build:
-    name: build-${{ matrix.os }}-${{ matrix.ghc }}
-    runs-on: ${{ matrix.os }}
+    name: "Ubuntu: ${{ matrix.os }}, GHC: ${{ matrix.ghc }}"
+    env:
+      apps: "smp-server xftp-server ntf-server xftp"
+    runs-on: ubuntu-${{ matrix.os }}
+    services:
+      postgres:
+        image: postgres:15
+        env:
+          POSTGRES_HOST_AUTH_METHOD: trust # Allows passwordless access
+        options: >-
+          --health-cmd pg_isready
+          --health-interval 10s
+          --health-timeout 5s
+          --health-retries 5
+        ports:
+          # Maps tcp port 5432 on service container to the host
+          - 5432:5432
     strategy:
       fail-fast: false
       matrix:
         include:
-          - os: ubuntu-20.04
-            platform_name: 20_04-x86-64
+          - os: 22.04
             ghc: "8.10.7"
-          - os: ubuntu-20.04
-            platform_name: 20_04-x86-64
+            platform_name: 22_04-8.10.7
+          - os: 22.04
             ghc: "9.6.3"
-          - os: ubuntu-22.04
             platform_name: 22_04-x86-64
+          - os: 24.04
             ghc: "9.6.3"
+            platform_name: 24_04-x86-64
     steps:
       - name: Clone project
         uses: actions/checkout@v3
 
-      - name: Setup Haskell
-        uses: haskell-actions/setup@v2
+      - name: Set up Docker Buildx
+        uses: docker/setup-buildx-action@v3
+
+      - name: Build and cache Docker image
+        uses: docker/build-push-action@v6
         with:
-          ghc-version: ${{ matrix.ghc }}
-          cabal-version: "3.10.1.0"
+          context: .
+          load: true
+          file: Dockerfile.build
+          tags: build/${{ matrix.platform_name }}:latest
+          cache-from: |
+            type=gha
+            type=gha,scope=master
+          cache-to: type=gha,mode=max
+          build-args: |
+            TAG=${{ matrix.os }}
+            GHC=${{ matrix.ghc }}
 
       - name: Cache dependencies
-        uses: actions/cache@v2
+        uses: actions/cache@v4
         with:
           path: |
             ~/.cabal/store
             dist-newstyle
           key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
 
-      - name: Build
+      - name: Start container
         shell: bash
-        run: cabal build --enable-tests
+        run: |
+          docker run -t -d \
+            --name builder \
+            -v ~/.cabal:/root/.cabal \
+            -v /home/runner/work/_temp:/home/runner/work/_temp \
+            -v ${{ github.workspace }}:/project \
+            build/${{ matrix.platform_name }}:latest
 
-      - name: Test
-        timeout-minutes: 40
+      - name: Build smp-server (postgresql) and tests
+        shell: docker exec -t builder sh {0}
+        run: |
+          cabal update
+          cabal build --enable-tests -fserver_postgres
+          mkdir -p /out
+          for i in smp-server simplexmq-test; do
+            bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
+            chmod +x "$bin"
+            mv "$bin" /out/
+          done
+          strip /out/smp-server
+
+      - name: Copy simplexmq-test from container
         shell: bash
-        run: cabal test --test-show-details=direct
+        run: |
+          docker cp builder:/out/simplexmq-test .
 
-      - name: Prepare binaries
+      - name: Copy smp-server (postgresql) from container and prepare it
         if: startsWith(github.ref, 'refs/tags/v')
         shell: bash
         run: |
-          mv $(cabal list-bin smp-server) smp-server-ubuntu-${{ matrix.platform_name}}
-          mv $(cabal list-bin ntf-server) ntf-server-ubuntu-${{ matrix.platform_name}}
-          mv $(cabal list-bin xftp-server) xftp-server-ubuntu-${{ matrix.platform_name}}
-          mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
+          docker cp builder:/out/smp-server ./smp-server-postgres-ubuntu-${{ matrix.platform_name }}
+
+      - name: Build everything else (standard)
+        shell: docker exec -t builder sh {0}
+        run: |
+          cabal build
+          mkdir -p /out
+          for i in ${{ env.apps }}; do
+            bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
+            strip "$bin"
+            chmod +x "$bin"
+            mv "$bin" /out/
+          done
+
+      - name: Copy binaries from container and prepare them
+        if: startsWith(github.ref, 'refs/tags/v')
+        shell: bash
+        run: |
+          docker cp builder:/out .
+          for i in ${{ env.apps }}; do mv ./out/$i ./$i-ubuntu-${{ matrix.platform_name }}; done
 
       - name: Build changelog
         if: startsWith(github.ref, 'refs/tags/v')
         id: build_changelog
-        uses: mikepenz/release-changelog-builder-action@v1
+        uses: mikepenz/release-changelog-builder-action@v5
         with:
           configuration: .github/changelog_conf.json
           failOnError: true
@@ -76,7 +138,7 @@ jobs:
 
       - name: Create release
         if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7'
-        uses: softprops/action-gh-release@v1
+        uses: softprops/action-gh-release@v2
         with:
           body: |
             See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md).
@@ -86,10 +148,18 @@ jobs:
           prerelease: true
           files: |
             LICENSE
-            smp-server-ubuntu-${{ matrix.platform_name}}
-            ntf-server-ubuntu-${{ matrix.platform_name}}
-            xftp-server-ubuntu-${{ matrix.platform_name}}
-            xftp-ubuntu-${{ matrix.platform_name}}
+            smp-server-ubuntu-${{ matrix.platform_name }}
+            smp-server-postgres-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 }}
+
+      - name: Test
+        shell: bash
+        env:
+          PGHOST: localhost
+        run: |
+          ./simplexmq-test

.github/workflows/docker-image.yml

@@ -14,22 +14,22 @@ jobs:
       matrix:
         include:
           - app: smp-server
-            app_port: 5223
+            app_port: "443 5223"
           - app: xftp-server
-            app_port: 443 
+            app_port: 443
     steps:
       - name: Clone project
-        uses: actions/checkout@v3
+        uses: actions/checkout@v4
 
       - name: Log in to Docker Hub
-        uses: docker/login-action@v2
+        uses: docker/login-action@v3
         with:
           username: ${{ secrets.DOCKERHUB_USERNAME }}
           password: ${{ secrets.DOCKERHUB_PASSWORD }}
 
       - name: Extract metadata for Docker image
         id: meta
-        uses: docker/metadata-action@v4
+        uses: docker/metadata-action@v5
         with:
           images: ${{ secrets.DOCKERHUB_USERNAME }}/${{ matrix.app }}
           flavor: |
@@ -40,7 +40,7 @@ jobs:
             type=semver,pattern=v{{major}}
 
       - name: Build and push Docker image
-        uses: docker/build-push-action@v4
+        uses: docker/build-push-action@v6
         with:
           push: true
           build-args: |

CHANGELOG.md

@@ -1,3 +1,31 @@
+# 6.2.2
+
+SMP server:
+- add optional Prometheus metrics (#1411).
+
+Build:
+- remove three modules from client library.
+
+# 6.2.0
+
+Version 6.2.0.7
+
+Build:
+- client_library flag to build only used modules in the clients, remove package yaml
+
+SMP server:
+- journal storage for messages (BETA).
+- prevent race condition when deleting queue and to avoid "orphan" messages (#1395).
+
+SMP agent:
+- support SMP and XFTP server roles (storage/proxy) and operators (#1343).
+- treat blocked STM and other critical errors that offer restart as temporary for message delivery (#1405).
+- fix inconsistent state after app restart while accepting contact request (#1412).
+
+# 6.1.3
+
+SMP server: fix restoring notification credentials.
+
 # 6.1.2
 
 Servers: more reliable restoring of state.

Dockerfile

@@ -1,15 +1,20 @@
-ARG TAG=22.04
+# syntax=docker/dockerfile:1.7.0-labs
+ARG TAG=24.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 libssl-dev
+RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-18 llvm-18-dev libnuma-dev libssl-dev
 
 # Specify bootstrap Haskell versions
 ENV BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3
-ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.1.0
+ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.12.1.0
+
+# Do not install Stack
+ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK=true
+ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK=true
 
 # Install ghcup
 RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh
@@ -21,26 +26,42 @@ ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
 RUN ghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}" && \
     ghcup set cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
 
-COPY . /project
+# Copy only the source code
+COPY apps /project/apps/
+COPY cbits /project/cbits/
+COPY src /project/src/
+
+COPY cabal.project Setup.hs simplexmq.cabal LICENSE /project
+
 WORKDIR /project
 
+# Debug
+#ARG CACHEBUST=1
+
+#ADD --chmod=755 https://github.com/MShekow/directory-checksum/releases/download/v1.4.6/directory-checksum_1.4.6_linux_amd64 /usr/local/bin/directory-checksum
+#RUN directory-checksum --max-depth 2 .
+
+# Set build arguments and check if they exist
 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
+RUN if [ -z "$APP" ]; then printf "Please spcify \$APP build-arg.\n"; exit 1; fi
 
 # Compile app
 RUN cabal update
 RUN cabal build exe:$APP
 
+# Copy scripts
+COPY scripts /project/scripts/
+
 # 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) && \
+RUN bin="$(find /project/dist-newstyle -name "$APP" -type f -executable)" && \
     mv "$bin" ./ && \
     strip ./"$APP" &&\
-    mv /project/scripts/docker/entrypoint-"$APP" ./entrypoint
+    mv /project/scripts/docker/entrypoint-"$APP" ./entrypoint &&\
+    mv /project/scripts/main/simplex-servers-stopscript ./simplex-servers-stopscript
 
 ### Final stage
 FROM ubuntu:${TAG}
@@ -53,6 +74,8 @@ COPY --from=build /final /usr/local/bin/
 
 # Open app listening port
 ARG APP_PORT
+RUN if [ -z "$APP_PORT" ]; then printf "Please spcify \$APP_PORT build-arg.\n"; exit 1; fi
+
 EXPOSE $APP_PORT
 
 # simplexmq requires using SIGINT to correctly preserve undelivered messages and restore them on restart

Dockerfile.build

@@ -0,0 +1,31 @@
+# syntax=docker/dockerfile:1.7.0-labs
+ARG TAG=24.04
+FROM ubuntu:${TAG} AS build
+
+### Build stage
+
+ARG GHC=9.6.3
+ARG CABAL=3.14.1.1
+
+# Install curl, git and and simplexmq dependencies
+RUN apt-get update && apt-get install -y curl libpq-dev git sqlite3 libsqlite3-dev build-essential libgmp3-dev zlib1g-dev llvm llvm-dev libnuma-dev libssl-dev
+
+# Specify bootstrap Haskell versions
+ENV BOOTSTRAP_HASKELL_GHC_VERSION=${GHC}
+ENV BOOTSTRAP_HASKELL_CABAL_VERSION=${CABAL}
+
+# Do not install Stack
+ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK=true
+ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK=true
+
+# Install ghcup
+RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh
+
+# Adjust PATH
+ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
+
+# Set both as default
+RUN ghcup set ghc "${GHC}" && \
+    ghcup set cabal "${CABAL}"
+
+WORKDIR /project

cabal.project

@@ -4,6 +4,15 @@ packages: .
 -- packages: . ../http2
 -- packages: . ../network-transport
 
+-- uncomment two sections below to run tests with coverage
+-- package *
+   -- coverage: True
+   -- library-coverage: True
+
+-- package attoparsec
+   -- coverage: False
+   -- library-coverage: False
+
 index-state: 2023-12-12T00:00:00Z
 
 package cryptostore

package.yaml

@@ -1,223 +0,0 @@
-name: simplexmq
-version: 6.1.2.0
-synopsis: SimpleXMQ message broker
-description: |
-  This package includes <./docs/Simplex-Messaging-Server.html server>,
-  <./docs/Simplex-Messaging-Client.html client> and
-  <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols:
-  .
-  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md SMP protocol>
-  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md SMP agent protocol>
-  .
-  See <https://github.com/simplex-chat/simplex-chat terminal chat prototype> built with SimpleXMQ broker.
-
-homepage: https://github.com/simplex-chat/simplexmq#readme
-license: AGPL-3
-author: simplex.chat
-maintainer: chat@simplex.chat
-copyright: 2020-2022 simplex.chat
-category: Chat, Network, Web, System, Cryptography
-extra-source-files:
-  - README.md
-  - CHANGELOG.md
-  - cbits/sha512.h
-  - cbits/sntrup761.h
-  - apps/smp-server/static/*.html
-  - apps/smp-server/static/media/*
-
-dependencies:
-  - aeson == 2.2.*
-  - ansi-terminal >= 0.10 && < 0.12
-  - asn1-encoding == 0.9.*
-  - asn1-types == 0.3.*
-  - async == 2.2.*
-  - attoparsec == 0.14.*
-  - base >= 4.14 && < 5
-  - base64-bytestring >= 1.0 && < 1.3
-  - case-insensitive == 1.2.*
-  - composition == 1.0.*
-  - constraints >= 0.12 && < 0.14
-  - containers == 0.6.*
-  - crypton == 0.34.*
-  - crypton-x509 == 1.7.*
-  - crypton-x509-store == 1.6.*
-  - crypton-x509-validation == 1.6.*
-  - cryptostore == 0.3.*
-  - data-default == 0.7.*
-  - direct-sqlcipher == 2.3.*
-  - directory == 1.3.*
-  - filepath == 1.4.*
-  - hashable == 1.4.*
-  - hourglass == 0.2.*
-  - http-types == 0.12.*
-  - http2 >= 4.2.2 && < 4.3
-  - ini == 0.4.1
-  - iproute == 1.7.*
-  - iso8601-time == 0.1.*
-  - memory == 0.18.*
-  - mtl >= 2.3.1 && < 3.0
-  - network >= 3.1.2.7 && < 3.2
-  - network-info >= 0.2 && < 0.3
-  - network-transport == 0.5.6
-  - network-udp >= 0.0 && < 0.1
-  - optparse-applicative >= 0.15 && < 0.17
-  - process == 1.6.*
-  - random >= 1.1 && < 1.3
-  - simple-logger == 0.1.*
-  - socks == 0.6.*
-  - sqlcipher-simple == 0.4.*
-  - stm == 2.5.*
-  - temporary == 1.3.*
-  - time == 1.12.*
-  - time-manager == 0.0.*
-  - tls >= 1.9.0 && < 1.10
-  - transformers == 0.6.*
-  - unliftio == 0.2.*
-  - unliftio-core == 0.2.*
-  - websockets == 0.12.*
-  - yaml == 0.11.*
-  - zstd == 0.1.3.*
-
-flags:
-  swift:
-    description: Enable swift JSON format
-    manual: True
-    default: False
-  use_crypton:
-    description: Use crypton etc. in cryptostore
-    manual: True
-    default: True
-
-# cpp-options:
-#   - -Dslow_servers
-
-when:
-  - condition: flag(swift)
-    cpp-options:
-      - -DswiftJSON
-  - condition: impl(ghc >= 9.6.2)
-    dependencies:
-      - bytestring == 0.11.*
-      - template-haskell == 2.20.*
-      - text >= 2.0.1 && < 2.2
-  - condition: impl(ghc < 9.6.2)
-    dependencies:
-      - bytestring == 0.10.*
-      - template-haskell == 2.16.*
-      - text >= 1.2.3.0 && < 1.3
-
-library:
-  source-dirs: src
-  c-sources:
-    - cbits/sha512.c
-    - cbits/sntrup761.c
-  include-dirs: cbits
-  extra-libraries: crypto
-
-executables:
-  smp-server:
-    source-dirs:
-    - apps/smp-server
-    - apps/smp-server/web
-    main: Main.hs
-    dependencies:
-      - file-embed
-      - simplexmq
-      - wai
-      - wai-app-static
-      - warp ==3.3.30 # the last one before http2-5.0
-      - warp-tls ==3.4.7 # extra internals exposed
-    ghc-options:
-      - -threaded
-      - -rtsopts
-
-  ntf-server:
-    source-dirs: apps/ntf-server
-    main: Main.hs
-    dependencies:
-      - simplexmq
-    ghc-options:
-      - -threaded
-      - -rtsopts
-
-  xftp-server:
-    source-dirs: apps/xftp-server
-    main: Main.hs
-    dependencies:
-      - simplexmq
-    ghc-options:
-      - -threaded
-      - -rtsopts
-
-  xftp:
-    source-dirs: apps/xftp
-    main: Main.hs
-    dependencies:
-      - simplexmq
-    ghc-options:
-      - -threaded
-      - -rtsopts
-
-tests:
-  simplexmq-test:
-    source-dirs:
-    - tests
-    - apps/smp-server/web
-    main: Test.hs
-    dependencies:
-      - deepseq == 1.4.*
-      - file-embed
-      - generic-random == 1.5.*
-      - hspec == 2.11.*
-      - hspec-core == 2.11.*
-      - http-client
-      - http-client-tls
-      - HUnit == 1.6.*
-      - main-tester == 0.2.*
-      - QuickCheck == 2.14.*
-      - silently == 1.2.*
-      - simplexmq
-      - timeit == 2.0.*
-      - unordered-containers
-      - wai
-      - wai-app-static
-      - warp
-      - warp-tls
-    ghc-options:
-      - -threaded
-      - -rtsopts
-      - -with-rtsopts=-A64M
-      - -with-rtsopts=-N1
-
-ghc-options:
-  # - -haddock
-  - -Weverything
-  - -Wno-missing-exported-signatures
-  - -Wno-missing-import-lists
-  - -Wno-missed-specialisations
-  - -Wno-all-missed-specialisations
-  - -Wno-unsafe
-  - -Wno-safe
-  - -Wno-missing-local-signatures
-  - -Wno-missing-kind-signatures
-  - -Wno-missing-deriving-strategies
-  - -Wno-monomorphism-restriction
-  - -Wno-prepositive-qualified-module
-  - -Wno-unused-packages
-  - -Wno-implicit-prelude
-  - -Wno-missing-safe-haskell-mode
-  - -Wno-missing-export-lists
-  - -Wno-partial-fields
-  - -Wcompat
-  - -Werror=incomplete-record-updates
-  - -Werror=incomplete-patterns
-  - -Werror=incomplete-uni-patterns
-  - -Werror=missing-methods
-  - -Werror=tabs
-  - -Wredundant-constraints
-  - -Wincomplete-record-updates
-  - -Wunused-type-patterns
-  - -O2
-
-default-extensions:
-  - StrictData

rfcs/2024-09-01-smp-message-storage.md

@@ -96,7 +96,7 @@ else if write_msg = max_queue_messages:
     add quota_exceeded message to write_file
     update queue state: write_msg += 1
     append updated queue state to queue.log
-else ]
+else
     // It is required that `max_queue_messages < max_file_messages`,
     // so that we never need more than one additional write file.
     if write_msg >= max_file_messages: // queue file rotation

rfcs/2024-09-25-ios-notifications-2.md

@@ -0,0 +1,49 @@
+# iOS notifications delivery
+
+## Problem
+
+For iOS notifications to be delivered the client has to create credentials for notification subscription on SMP server using NKEY command and after that create a subscription on notification server using SNEW command. These two commands are sent in sequence, after the connections are created, and for it to happen the client needs to be online and in foreground.
+
+iOS users tend to close the app when it is not used, and iOS has very limited permissions for background activities, so these notification subscriptions are created with a substantial delay, and notifications do not work.
+
+This problem is distinct from and probably more common than other problems affecting notifications delivery described [here](./2024-07-06-ios-notifications.md).
+
+## Solution
+
+1. When the new connection is created, the client already knows if it needs to create notification subscription or not, based on the conversation setting (e.g., if the group is muted, the client will not create notification subscription as well.). We should extend NEW command to avoid the need to send additional NKEY command with an option to create notification subscription at the point where connection is created. NDEL would still be used to disable this notification, and NKEY will be used to re-enable it.
+
+2. In the same way we stopped using SDEL command (NDEL sends notification DELD to subscribed notification server) to delete notificaiton subscriptions from notification server, we should delegate creating notification subscription on notification server to SMP servers. Clients could use keys agreed with ntf server for e2e encryption and for command authorization to encrypt and sign instruction to create notification subscription that will be forwarded to notification server using protocol similar to SMP proxies. This will avoid the need for clients to separately contact notification servers that won't happen until they are online.
+
+3. Instead of making Ntf server trust DELD notifications, we could send deletion instructions signed by the client, which will only fail to send in case notification server is down (and they won't be sent later after server restart).
+
+Cons:
+- If SMP servers were to retain in the storage the information about which notification server is used for which queue, it would reduce metadata privacy. While currently it is not an issue, as all notification servers are known and operated by us, once there are other client apps, this can be used for app users fingerprinting, which would act as a deterrence from using new apps – but only if app users use servers of operators who are different from the app provider. To mitigate it, we could only store it in server memory and include notification instruction in subscription commands (SUB) and include notification subscription status in SUB responses. We don't need to mitigate the problem of server being able to store this information, as messaging servers can observe which notification servers connect to them anyway.
+- If SMP server is restarted before the subscription request is forwared to the notification server, then it will have to be forwarded again, once the client subscribes. The problem here is that if the client is offline, it will neither subscribe to the queue to send notification subscription request, nor receive notifications from this queue. Storing notification server and subscription request would mitigate that, as in this case we could send all pending requests on server start, without depending on client subscriptions.
+- "Small" agent will need to support connections to ntf servers and manage workers that retry sending pending subscription requests.
+- Until the client learns the public keys of notification server, it will not be able to decrypt notifications. It potentially can be mitigated by using the public key of the server returned when token is created, in this way different client keys (per-queue) will be combined with the same ntf server key (per-token).
+
+## Implementation details
+
+1. NEW and NKEY commands will need to be extended to include notification subscription request. As the notifier ID needs to be sent to notification server, this notifier ID will have to be client-generated and supplied as part of NEW command.
+
+now:
+
+```haskell
+NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
+NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
+```
+
+extended:
+
+```haskell
+NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Maybe NtfRequest -> Command Recipient
+
+data NtfRequest = NtfRequest NotifierId NtfPublicAuthKey RcvNtfPublicDhKey NtfServerRequest
+
+data NtfServerRequest = NtfServerRequest NtfServer EncSingedNtfCmd
+
+NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Maybe NtfServerRequest -> Command Recipient
+-- NotifierID is passed in entity ID field of the transmission
+```
+
+2. Notification server will need to support an additional command to receive "proxied" subscription commands, `SFWD`, that would include `NtfServerRequest`. This command can include both `SNEW` and `SDEL` commands.

rfcs/2024-11-25-journal-expiration.md

@@ -0,0 +1,15 @@
+# Expiring messages in journal storage
+
+## Problem
+
+The journal storage servers recently migrated to do not delete delivered or expired messages, they only update pointers to journal file lines. The messages are actually deleted when the whole journal file is deleted (when fully deleted or fully expired).
+
+The problem is that in case the queue stops receiving the new messages then writing of messages won't switch to the new journal file, and the current journal file containing delivered or expired messages would never be deleted.
+
+## Solution
+
+Remove current journal file and update queue_state.log during message expiration of "idle" queue (that is, without any new messages received or delivered within 3 hours) in case when:
+- the queue is "empty" after the expiration
+- the queue contains only quota marker(s), in which case move them to a new journal file and update the queue_state accordingly. Quota markers can be kept indefinitely to prevent writing the new messages to the dormant queues that reached capacity, so it's important to handle this case.
+
+Also remove current journal file when the queue is opened in case it is empty (as it would not be ever expired in case it remains empty), and also update queue_state.log

rfcs/2024-11-25-queue-blobs-2.md

@@ -0,0 +1,58 @@
+# Blob extensions for SMP queues 2 and queue storage
+
+This document evolves the design proposed [here](./2024-09-09-smp-blobs.md).
+
+## Problems
+
+In addition to problems in the first doc, we have these issues with in-memory queue record storage:
+- many queues are idle or rarely used, but they are loaded to memory, and currently just loading all queues uses 20gb RAM on each server, and takes 10 min to process, increasing downtimes during restarts.
+- adding blobs to memory would make this problem much worse.
+
+## Proposed solution
+
+Move queues to the same journalling approach as [used for messages](./2024-09-01-smp-message-storage.md) now, with independent file names in the same folders.
+
+Each queue change would be logged to its own file, and every time the queue is opened the whole file will be read and compacted to a single line - replacing one store log for all queues, with individual log files for each queue.
+
+Queue deletion would not be making a record in the file, instead it would be deleting the entire folder - it would reduce retention period for any metadata of deleted queues.
+
+We could additionally record deletions to the central log, for debugging, and reset it on every start. But in this case we should not remove folders at the point of deletion, but rather mark them as deleted and delete on restart. TBC
+
+It would also allow simplifying blob storage by having only one blob per queue - for example, limied to 16kb (a bit smaller to fit in block) for contact address queues and 4-8kb for invitations (to fit PQ keys and conversation preferences).
+
+We would also need to be able to lookup recipient ID via sender/notifier/link IDs.
+
+One possible solution is to use and load to memory a central index file. But it is likely to also consume a lot of memory and result in slow starts.
+
+Another solution that is probably better is to use the same folder structure and put notifier/sender/link files with the ID of the recipient queue inside the files. So to locate recipient queue the sender would have to locate folder containing the reference file pointing to the recipient queue and then to locate the actual queue data.
+
+## Implementation details
+
+Each queue folder would these files:
+
+- queue_state.log (and timestamped backups) - to store pointers to message journals (already implemented)
+- messages.randomBase64.log - message journals (already implemented)
+- queue_rec.log (and timestamped backups) - to log complete queue record every time it is changed (so only the last line needs to be read following the same logic as with queue_state.log, to prevent file corruption).
+- blob.data, blob.data.bak, blob.timestamp.data - files for data blobs (to make sure some copy of this file is readable/correct in case of write corruption) - the same two step overwrite process will be used as currently with store log compacting:
+  - on write: 1. if file exists, move it to .bak, 2. store new blob to .data, 3. move .bak to .timestamp.data
+  - on read: 1. if .bak exists, move it to .data 2. use .data
+
+Additional suggestion to reduce probability of queue_state.log and queue_rec.log file corruption is to do one of the following:
+- log end of lines in the beginning of the output, not in the end, to prevent the last line from being corrupted in case the previous line was not fully stored. The downside is that the file will not be EOL terminated, and there will be no confirmation that the output was fully made.
+- log EOL both in the beginning and at the end of output, and ignore empty lines in between - this would both confirm that the last line is fully logged and prevent corruption of the next line in case it was not.
+- check the last byte of the file and log EOL if it is not EOL. Probably cleanest approach, but with a small performance cost.
+
+If queue folder is a reference to the queue, it may have one of these files:
+- notifier.id
+- sender.id
+- link.id
+
+These files would contain a one line with the recipient ID of the queue. These files would never change, they can only be deleted when queue is deleted or when notifier/link is deleted.
+
+There is logic in code preventing using the same ID in different contexts, and the ID size is large enough to make any collisions unlikely (192 bits), so with correctly working code the queue folder would either have one of reference files, and nothing else, or the queue and message files from the beginning of this section. But even if the same ID is re-used in different context, it should not cause any problems as file names don't overlap.
+
+While we could store different types of references in different types of folders, it would have additional costs of maintaining 4 folder hierarchies. Instead we could use the fact that it is one hierarchy to prevent using the same ID in different contexts.
+
+## Protocol
+
+The only change in protocol is that there will be only one blob per queue, without markers (see the previous doc). Otherwise the protocol and proposed privacy improvement seem reasonable.

rfcs/2025-03-16-smp-queues.md

@@ -0,0 +1,255 @@
+# Protocol changes for creating and connecting to SMP queues
+
+## Problems
+
+This change is related to these problems:
+- differentiating queue retention time,
+- supporting MITM-resistant short connection links,
+- improving notifications.
+
+This RFC is based on the previous discussions about short links, blob storage and notifications ([1](./2024-06-21-short-links.md), [2](./2024-09-09-smp-blobs.md), [3](./2024-11-25-queue-blobs-2.md), [4](./2024-09-25-ios-notifications-2.md)).
+
+SMP protocol supports two types of queues - queues to communicate over and queues to send invitations. While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent.
+
+Simply designating queue types would allow to use this information to decide for how long to retain queues, and potentially extending it:
+- unsecured 1-time invitation queues with sndSecure (support of securing by sender) - e.g., 3 months.
+- contact address queues without sndSecure - e.g., 3 years without activity.
+- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and superpeer addresses for the group.
+
+This proposal also combines NEW and NKEY command to streamline notifications in preparation to reworking of the notifications protocol.
+
+## Design objectives
+
+We want to achieve these objectives:
+1. no possibility to provide incorrect SenderId inside link data (e.g. from another queue).
+2. link data cannot be accessed by the server unless it has the link.
+3. prevent MITM attack by the server, including the server that obtained the link.
+4. prevent changing of connection request by the user (to prevent MITM via break-in attack in the originating client).
+5. for one-time links, prevent accessing link data by link observers who did not compromise the server.
+6. allow changing the user-defined part of link data.
+7. avoid changing the link when user-defined part of link data changes, while preventing MITM attack by the server on user-defined part, even if it has the link.
+8. retain the quality that it is impossible to check the existense of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs).
+
+To achieve these objectives the queue data must have immutable part and mutable part.
+
+Immutable part would include:
+- full conection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response.
+- public signature key to verify mutable part of link data.
+
+Signed mutable part would inlcude:
+- any links to chat relays that should be contacted instead of this queue (not in this RFC), but would allow delegating group connections and contact request connections to prevent spam, hiding online presense, etc.
+- and user-defined data - user profile or group profile.
+
+The link itself should include both the key and auth tag from the encryption of immutable part. Accessing one-time link data should require providing sender key and signing the command (`LKEY`).
+
+## Solution
+
+Current NEW and NKEY commands:
+
+```haskell
+NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
+
+NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
+
+-- | Queue IDs and keys, returned in IDS response
+data QueueIdsKeys = QIK
+  { rcvId :: RecipientId,
+    sndId :: SenderId,
+    rcvPublicDhKey :: RcvPublicDhKey,
+    sndSecure :: SenderCanSecure
+  }
+```
+
+Proposed NEW command replaces SenderCanSecure with QueueMode, adds link data, and combines NKEY command:
+
+```haskell
+NEW :: NewQueueRequest -> Command Recipient
+
+data NewQueueRequest = NewQueueRequest
+  { rcvAuthKey :: RcvPublicAuthKey,
+    rcvDhKey :: RcvPublicDhKey,
+    basicAuth :: Maybe BasicAuth,
+    subMode :: SubscriptionMode,
+    ntfRequest :: Maybe NtfRequest,
+    queueLink :: Maybe QueueLink -- it is Maybe to allow testing and staged roll-out
+  }
+
+-- To allow updating the existing contact addresses without changing them.
+-- This command would fail on queues that support sndSecure and also on new queues created with QLMessaging.
+-- RecipientId is entity ID.
+-- The response to this command is `OK`.
+LNEW :: LinkId -> QueueLinkData -> Command Recipient
+
+-- Replaces NKEY command
+-- This avoids additional command required from the client to enable notifications.
+-- Further changes would move NotifierId generation to the client, and including a signed and encrypted command to be forwarded by SMP server to notification server.
+data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey
+
+-- QLMessaging implies that sender can secure the queue.
+-- LinkId is not used with QLMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used.
+-- LinkId is required with QLContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists.
+data QueueLink = QLMessaging QueueLinkData | QLContact LinkId QueueLinkData
+
+data QueueLinkData = QueueLinkData EncImmutableDataBytes EncUserDataBytes
+
+newtype EncImmutableDataBytes = EncImmutableDataBytes ByteString
+
+newtype EncUserDataBytes = EncUserDataBytes ByteString
+
+-- We need to use binary encoding for AConnectionRequestUri to reduce its size
+-- connReq including the full link allows connection redundancy.
+-- The clients would reject changed immutable data (based on auth tag in the link) and
+-- AConnectionRequestUri where SenderId of the queue does not match.
+data ImmutableLinkData = ImmutableLinkData
+  { signature :: SignatureEd25519, -- signature of the remaining part of immutable data
+    connReq :: AConnectionRequestUri,
+    sigKey :: PublicKeyEd25519
+  }
+
+-- This part of link data can also include any relays, but possibly we need a separate blob for it
+data UserLinkData = UserLinkData
+  { signature :: SignatureEd25519, -- signs the remaining part of the data
+    userData :: ByteString -- the max size needs to be estimated, but it is likely to be ~ 14kb
+  }
+
+-- | Updated queue IDs and keys, returned in IDS response
+data QueueIdsKeys = QIK
+  { rcvId :: RecipientId, -- server-generated
+    sndId :: SenderId, -- server-generated
+    rcvPublicDhKey :: RcvPublicDhKey,
+    sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied?
+    linkId :: Maybe LinkId, -- server-generated
+    serverNtfCreds :: Maybe ServerNtfCreds -- currently returned in NID response
+  }
+
+data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId is server-generated.
+```
+
+In addition to that we add the command allowing to update and also to retrieve and, optionally, secure the queue and get link data in one request, to have only one request:
+
+```haskell
+-- With RecipientId as entity ID, the command to update mutable part of link data
+-- The response is OK here.
+LSET :: EncUserDataBytes -> Command Recipient
+
+-- To be used with 1-time links.
+-- Sender's key provided on the first request prevents observers from undetectably accessing 1-time link data.
+-- If queue mode is QLContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY.
+-- Once queue is secured, the key must be the same in subsequent requests - to allow retries in case of network failures, and to prevent passive attacks.
+-- The difference with securing queues is that queues allow sending unsecured messages to queues that allow sndSecure (for backwards compatibility), and 1-time links will NOT allow retrieving link data without securing the queue at the same time, preventing undetected access by observers.
+-- Entity ID is LinkId here
+LKEY :: SndPublicAuthKey -> Command Sender
+
+-- If queue mode is QLMessaging the command will fail.
+-- Entity ID is LinkId here
+LGET :: Command Sender
+
+-- Response to LKEY and LGET
+-- Entity ID is LinkId here
+LINK :: SenderId -> QueueLinkData -> BrokerMsg
+```
+
+## Algorithm to prepare and to interpret queue link data.
+
+For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existense checks.
+
+**Prepare queue link data**
+
+- the queue owner generates a random 256 bit `link_key` that will be used in the link URI.
+- for 1-time links: crypto_box key and 2 nonces to encrypt link data are derived from link_uri using HKDF: `cb_key <> nonce1 <> nonce2 = HKDF(link_key, 80 bytes)` (nonce1 is used for immutable and nonce2 for user-defined parts).
+- for contact address links: key and 2 nonces and linkId will be derived: `link_id <> cb_key <> nonce1 <> nonce2 = HKDF(link_key, 104 bytes)`
+- both parts of link data are encrypted with crypto_box, and included into `NEW` or `LNEW` commands.
+
+**Retrieving queue link data**
+
+- the sender uses `LinkId` from URI (or derived from URI) as entity ID to retrieve link data.
+- for one time links the sender must authorize the request to retrieve the data, the key is provided with the first request, preventing undetected access by link observers.
+- having received the link data, the client can now decrypt it using secret_box.
+
+## Threat model
+
+**Compromised SMP server**
+
+can:
+- delete link data.
+- hide link selectively from some requests.
+
+cannot:
+- undetectably replace link data, even if they have the link (objective 3).
+- access unencrypted link data, whether it was or was not accessed by the accepting party, provided it has no link (objective 2).
+- observe IP addresses of the users accessing link data, if private routing is used.
+
+**Passive observer who observed short link**:
+
+can:
+- access original unencrypted link data for contact address links.
+
+cannot:
+- undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5).
+- undetectbly check the existense of messaging queue or 1-time link (objective 8).
+- replace or delete the link data.
+
+**Queue owner who did not comprmise the server**:
+
+cannot:
+- redirect connecting user to another queue, on the same or on another server (objective 1).
+- replace connection request in the link (objective 4).
+
+## Correlation of design objectives with design elements
+
+1. The presense of `SenderId` in `LINK` response from the server.
+2. Encryption of link data with crypto_box.
+3. Auth tag in the link prevents server modification of immutable part of link data. Signature verification key in immutable part, and signing of mutable part prevents server modification of mutable part of link data.
+4. No server command to change immutable part of link data once it's set.
+5. 1-time link data can only be accessed with `LKEY` command, that while allows retries to mitigate network failures, will require the same key for retries.
+6. `LSET` command.
+7. The link only includes auth tag for immutable part, mutable part includes signature.
+8. Temporarily public IDs (SenderId and LinkId for 1-time invitations) are generated server-side, and cannot be provided by the clients when creating the queues to check if these IDs are free.
+
+## Syntax for short links
+
+The proposed syntax:
+
+```abnf
+shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ]
+smpServerHost = <hostname> ; RFC1123, RFC5891
+linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes
+oneTimeLinkBytes = <base64url(linkId | linkKey | linkAuthTag)> ; 60 bytes / 80 base64 encoded characters
+contactLinkBytes = <base64url(linkKey | linkAuthTag)> ; 48 bytes / 64 base64 encoded characters
+; linkId - 96 bits/24 bytes
+; linkKey - 256 bits/32 bytes
+; linkAuthTag - 128 bits/16 bytes auth tag from encryption of immutable link data>
+
+serverInfo = [fingerprint "@" [hostnames "/"]] ; not needed for preset servers, required otherwise - the clients must refuse to connect if they don't have fingerprint in the code.
+
+fingerprint = <base64url(server offline certificate fingerprint)>
+hostnames = "h=" <hostname> *( "," <hostname> ) ; additional hostnames, e.g. onion
+```
+
+To have shorter links fingerpring and additional server hostnames do not need to be specified for preconfigured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint.
+
+Example one-time link for preset server (108 characters):
+
+```
+https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789
+```
+
+Example contact link for preset server (92 characters):
+
+```
+https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
+```
+
+Example contact link for user-defined server (with fingerprint, but without onion hostname - 136 characters):
+
+```
+https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
+```
+
+Example contact link for user-defined server (with fingerprint ant onion hostname - 199 characters):
+
+```
+https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
+```
+
+For the links to work in the browser the servers must provide server pages.

scripts/docker/docker-compose-smp-complete.yml

@@ -0,0 +1,67 @@
+name: SimpleX Chat - smp-server
+
+services:
+  oneshot:
+    image: ubuntu:latest
+    environment:
+      CADDYCONF: |
+        ${CADDY_OPTS:-}
+
+        http://{$$ADDR} {
+            redir https://{$$ADDR}{uri} permanent
+        }
+
+        {$$ADDR}:8443 {
+            tls {
+                key_type rsa4096
+            }
+        }
+    command: sh -c 'if [ ! -f /etc/caddy/Caddyfile ]; then printf "$${CADDYCONF}" > /etc/caddy/Caddyfile; fi'
+    volumes:
+      - ./caddy_conf:/etc/caddy
+
+  caddy:
+    image: caddy:latest
+    depends_on:
+      oneshot:
+        condition: service_completed_successfully
+    cap_add:
+      - NET_ADMIN
+    environment:
+      ADDR: ${ADDR?"Please specify the domain."}
+    volumes:
+      - ./caddy_conf:/etc/caddy
+      - caddy_data:/data
+      - caddy_config:/config
+    ports:
+      - 80:80
+    restart: unless-stopped
+    healthcheck:
+      test: "test -d /data/caddy/certificates/${CERT_PATH:-acme-v02.api.letsencrypt.org-directory}/${ADDR} || exit 1"
+      interval: 1s
+      retries: 60
+
+  smp-server:
+    image: ${SIMPLEX_IMAGE:-simplexchat/smp-server:latest}
+    depends_on:
+      caddy:
+        condition: service_healthy
+    environment:
+      ADDR: ${ADDR?"Please specify the domain."}
+      PASS: ${PASS:-}
+    volumes:
+      - ./smp_configs:/etc/opt/simplex
+      - ./smp_state:/var/opt/simplex
+      - type: volume
+        source: caddy_data
+        target: /certificates
+        volume:
+          subpath: "caddy/certificates/${CERT_PATH:-acme-v02.api.letsencrypt.org-directory}/${ADDR}"
+    ports:
+      - 443:443
+      - 5223:5223
+    restart: unless-stopped
+
+volumes:
+  caddy_data:
+  caddy_config:

scripts/docker/docker-compose-smp-manual.yml

@@ -0,0 +1,15 @@
+name: SimpleX Chat - smp-server
+
+services:
+  smp-server:
+    image: ${SIMPLEX_IMAGE:-simplexchat/smp-server:latest}
+    environment:
+      WEB_MANUAL: ${WEB_MANUAL:-1}
+      ADDR: ${ADDR?"Please specify the domain."}
+      PASS: ${PASS:-}
+    volumes:
+      - ./smp_configs:/etc/opt/simplex
+      - ./smp_state:/var/opt/simplex
+    ports:
+      - 5223:5223
+    restart: unless-stopped

scripts/docker/docker-compose-smp.env

@@ -0,0 +1,11 @@
+# Mandatory
+ADDR=your_ip_or_addr
+
+# Optional
+#PASS='123123'
+#WEB_MANUAL=1
+
+# Debug
+#SIMPLEX_SMP_IMAGE=smp-server-dev
+#CERT_PATH=acme-staging-v02.api.letsencrypt.org-directory
+#CADDY_OPTS='{\n    acme_ca https://acme-staging-v02.api.letsencrypt.org/directory\n}'

scripts/docker/docker-compose-xftp.env

@@ -0,0 +1,9 @@
+# Mandatory
+ADDR=your_ip_or_addr
+QUOTA=120gb
+
+# Optional
+#PASS='123123'
+
+# Debug
+#SIMPLEX_XFTP_IMAGE=xftp-server-dev

scripts/docker/docker-compose-xftp.yml

@@ -0,0 +1,16 @@
+name: SimpleX Chat - xftp-server
+
+services:
+  xftp-server:
+    image: ${SIMPLEX_XFTP_IMAGE:-simplexchat/xftp-server:latest}
+    environment:
+      ADDR: ${ADDR?"Please specify the domain."}
+      QUOTA: ${QUOTA?"Please specify disk quota."}
+      PASS: ${PASS:-}
+    volumes:
+      - ./xftp_configs:/etc/opt/simplex-xftp
+      - ./xftp_state:/var/opt/simplex-xftp
+      - ./xftp_files:/srv/xftp
+    ports:
+      - 443:443
+    restart: unless-stopped

scripts/docker/entrypoint-smp-server

@@ -1,48 +1,87 @@
 #!/usr/bin/env sh
+set -e
+
 confd='/etc/opt/simplex'
-logd='/var/opt/simplex/'
+cert_path='/certificates'
 
 # 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 ;;
+    '')
+      printf 'Please specify $ADDR environment variable.\n'
+      exit 1
+      ;;
+
+    # Determine domain or IPv6
     *[a-zA-Z]*)
       case "${ADDR}" in
-        *:*) set -- --ip "${ADDR}" ;;
-        *) set -- -n "${ADDR}" ;;
+        # IPv6
+        *:*)
+          set -- --ip "${ADDR}"
+          ;;
+
+        # Domain
+        *)
+          case "${ADDR}" in
+            # It's in domain format
+            *.*)
+              # Determine the base domain
+              ADDR_BASE="$(printf '%s' "$ADDR" | awk -F. '{print $(NF-1)"."$NF}')"
+              set -- --fqdn "${ADDR}" --own-domains="${ADDR_BASE}"
+              ;;
+
+            # Incorrect domain
+            *)
+              printf 'Incorrect $ADDR environment variable. Please specify the correct one in format: smp1.example.org / example.org \n'
+              exit 1
+              ;;
+          esac
       esac
       ;;
-    *) set -- --ip "${ADDR}" ;;
+
+    # Assume everything else is IPv4
+    *)
+      set -- --ip "${ADDR}" ;;
   esac
 
   # Optionally, set password
   case "${PASS}" in
-    '') set -- "$@" --no-password ;;
-    *) set -- "$@" --password "${PASS}" ;;
+    # Empty value = no password
+    '')
+      set -- "$@" --no-password
+      ;;
+
+    # Assume that everything else is a password
+    *)
+      set -- "$@" --password "${PASS}"
+      ;;
   esac
 
   # And init certificates and configs
-  smp-server init -y -l "$@"
+  smp-server init --yes \
+                  --store-log \
+                  --daily-stats \
+                  --source-code \
+                  "$@" > /dev/null 2>&1
+
+  # Fix path to certificates
+  if [ -n "${WEB_MANUAL}" ]; then
+    sed -i -e 's|^[^#]*https: |#&|' \
+           -e 's|^[^#]*cert: |#&|' \
+           -e 's|^[^#]*key: |#&|' \
+           -e 's|^port:.*|port: 5223|' \
+           "${confd}/smp-server.ini"
+  else
+    sed -i -e "s|cert: /etc/opt/simplex/web.crt|cert: $cert_path/$ADDR.crt|" \
+           -e "s|key: /etc/opt/simplex/web.key|key: $cert_path/$ADDR.key|" \
+           "${confd}/smp-server.ini"
+  fi
 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
+DOCKER=true /usr/local/bin/simplex-servers-stopscript smp-server
 
 # 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

@@ -1,50 +1,90 @@
 #!/usr/bin/env sh
+set -eu
+
 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 ;;
+    '')
+      printf 'Please specify $ADDR environment variable.\n'
+      exit 1
+      ;;
+
+    # Determine domain or IPv6
     *[a-zA-Z]*)
       case "${ADDR}" in
-        *:*) set -- --ip "${ADDR}" ;;
-        *) set -- -n "${ADDR}" ;;
+        # IPv6
+        *:*)
+          set -- --ip "${ADDR}"
+          ;;
+
+        # Domain
+        *)
+          case "${ADDR}" in
+            # Check if format is correct
+            *.*)
+              set -- --fqdn "${ADDR}"
+              ;;
+
+            # Incorrect domain
+            *)
+              printf 'Incorrect $ADDR environment variable. Please specify the correct one in format: smp1.example.org / example.org \n'
+              exit 1
+              ;;
+          esac
+          ;;
       esac
       ;;
-    *) set -- --ip "${ADDR}" ;;
+
+    # Assume everything else is IPv4
+    *)
+      set -- --ip "${ADDR}"
+      ;;
   esac
 
-  # Set quota
+  # Set global disk quota
   case "${QUOTA}" in
-    '') printf 'Please specify $QUOTA environment variable.\n'; exit 1 ;;
-    *GB) QUOTA="$(printf ${QUOTA} | tr '[:upper:]' '[:lower:]')"; set -- "$@" --quota "${QUOTA}" ;;
-    *gb) set -- "$@" --quota "${QUOTA}" ;;
-    *) printf 'Wrong format. Format should be: 1gb, 10gb, 100gb.\n'; exit 1 ;;
+    '')
+      printf 'Please specify $QUOTA environment variable.\n'
+      exit 1
+      ;;
+
+    # Incorrect format in uppercase, but automagically workaround this, replacing characters to lowercase
+    *GB)
+      QUOTA="$(printf '%s' "${QUOTA}" | tr '[:upper:]' '[:lower:]')"
+      set -- "$@" --quota "${QUOTA}"
+      ;;
+
+    # Correct format  
+    *gb)
+      set -- "$@" --quota "${QUOTA}"
+      ;;
+
+    # Incorrect format
+    *)
+      printf 'Wrong format. Format should be: 1gb, 10gb, 100gb.\n'
+      exit 1
+      ;;
   esac
 
   # Init the certificates and configs
-  xftp-server init -l -p /srv/xftp "$@"
+  xftp-server init --store-log \
+                   --path /srv/xftp \
+                   "$@" > /dev/null 2>&1
+
+  # Optionally, set password
+  if [ -n "${PASS}" ]; then
+    sed -i -e "/^# create_password:/a create_password: $PASS" \
+           "${confd}/file-server.ini"
+  fi
 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
+
+DOCKER=true /usr/local/bin/simplex-servers-stopscript xftp-server
 
 # 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-stopscript

@@ -148,8 +148,10 @@ xftp_cleanup() {
 
 main() {
 	type="${1:-}"
-  
-	checks
+
+  if [ -z "${DOCKER+x}" ]; then
+  	checks
+  fi
 
 	case "$type" in
 		smp-server)

scripts/main/simplex-servers-update

@@ -1,13 +1,8 @@
 #!/usr/bin/env sh
 set -eu
 
-# Links to scripts/configs
-scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
-scripts_systemd_smp="$scripts/smp-server.service"
-scripts_systemd_xftp="$scripts/xftp-server.service"
-scripts_update="$scripts/simplex-servers-update"
-scripts_uninstall="$scripts/simplex-servers-uninstall"
-scripts_stopscript="$scripts/simplex-servers-stopscript"
+# Make sure that PATH variable contains /usr/local/bin
+PATH="/usr/local/bin:$PATH"
 
 # Default installation paths
 path_bin="/usr/local/bin"
@@ -22,7 +17,9 @@ 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="/tmp/simplex-servers"
+path_tmp_bin_smp="$path_tmp_bin/smp-server"
+path_tmp_bin_xftp="$path_tmp_bin/xftp-server"
 path_tmp_bin_update="$path_tmp_bin/simplex-servers-update"
 path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall"
 path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
@@ -37,203 +34,549 @@ BLU='\033[1;36m'
 YLW='\033[1;33m'
 RED='\033[0;31m'
 NC='\033[0m'
+BLD='\033[1m'
+UNDRL='\033[4m'
+
+NL='
+'
+
+# Set VER globally and only once
+VER="${VER:-latest}"
 
 # Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
 
-os_test() {
- . /etc/os-release
+######################
+### Misc functions ###
+######################
 
- case "$VERSION_ID" in
-  20.04|22.04) : ;;
-  24.04) VERSION_ID='22.04' ;;
-  *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
- esac
+# Checks "sanity" of downloaded thing, e.g. if it's really a script or binary
+check_sanity() {
+  path="$1"
+  criteria="$2"
 
- version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
- arch="$(uname -p)"
+  case "$criteria" in
+    string:*)
+      pattern="$(printf '%s' "$criteria" | awk '{print $2}')"
+      
+      if grep -q "$pattern" "$path"; then
+        sane=0
+      else
+        sane=1
+      fi
+      ;;
+    file:*)
+      pattern="$(printf '%s' "$criteria" | awk '{print $2}')"
 
- case "$arch" in
-  x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
-  *)  printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
- esac
+      if file "$path" | grep -q "$pattern"; then
+        sane=0
+      else
+        sane=1
+      fi
+      ;;
+    *) printf 'Unknown criteria.\n'; sane=1 ;;
+  esac
 
- bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
- bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
+  unset path string
+
+  return "$sane"
 }
 
-installed_test() {
+# Checks if old thing and new thing is different
+change_check() {
+  old="$1"
+  new="$2"
+
+  if [ -x "$new" ] || [ -f "$new" ]; then
+    type="$(file $new)"
+  else
+    type='string'
+  fi
+
+  case "$type" in
+    *script*|*text*)
+      if diff -q "$old" "$new" > /dev/null 2>&1; then
+        changed=1
+      else
+        changed=0
+      fi
+      ;;
+    string)
+      if [ "$old" = "$new" ]; then
+        changed=1
+      else
+        changed=0
+      fi
+      ;;
+  esac
+
+  return "$changed"
+}
+
+##########################
+### Misc functions END ###
+##########################
+
+#########################
+### Support functions ###
+#########################
+
+# Sets local/remote versions and "apps" variables
+check_versions() {
+  # Sets:
+  # - ver
+  # - bin_url
+  # - remote_version
+  # - local_version
+  # - apps
+
+  case "$VER" in 
+    latest)
+      remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest 2>/dev/null | grep -i "tag_name" | awk -F \" '{print $4}')"
+
+      if [ -z "$remote_version" ]; then
+        printf "${RED}Something went wrong when ${YLW}resolving the lastest version${NC}: either you don't have connection to Github or you're rate-limited.\n"
+        exit 1
+      fi
+      ;;
+    *)
+      # Check if this version really exist
+      ver_check="https://github.com/simplex-chat/simplexmq/releases/tag/${VER}"
+      
+      if curl -o /dev/null --proto '=https' --tlsv1.2 -sf -L "${ver_check}"; then
+        remote_version="${VER}"
+      else
+        printf "Provided version ${BLU}%s${NC} ${RED}doesn't exist${NC}! Switching to ${BLU}latest${NC}.\n" "${VER}"
+        VER='latest'
+
+        # Re-execute check
+        check_versions
+
+        # Everything has been done, so return from the function
+        return 0
+      fi
+      ;;
+  esac
+
+  # Links to scripts/configs
+  bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${remote_version}"
+  scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/refs/tags/${remote_version}/scripts/main"
+  scripts_url_systemd_smp="$scripts_url/smp-server.service"
+  scripts_url_systemd_xftp="$scripts_url/xftp-server.service"
+  scripts_url_update="$scripts_url/simplex-servers-update"
+  scripts_url_uninstall="$scripts_url/simplex-servers-uninstall"
+  scripts_url_stopscript="$scripts_url/simplex-servers-stopscript"
+
   set +u
-  for i in $path_conf_etc/*; do
-    if [ -d "$i" ]; then
-      case "$i" in
-        *simplex) apps="smp $apps" ;;
-        *simplex-xftp) apps="xftp $apps" ;;
-      esac
+  for i in smp xftp; do
+    # Only check local directory where binaries are installed by the script
+    if command -v "/usr/local/bin/$i-server" >/dev/null; then
+      apps="$i $apps"
     fi
   done
   set -u
-}
 
-set_version() {
-  ver="${VER:-latest}"
-
-  case "$ver" in 
-    latest)
-      bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-      remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
-      ;;
-    *)
-      bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
-      remote_version="${ver}"
-      ;;
-  esac
-}
-
-update_scripts() {
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_tmp_bin_uninstall" && chmod +x "$path_tmp_bin_uninstall"
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_tmp_bin_stopscript" && chmod +x "$path_tmp_bin_stopscript"
-
-  if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null 2>&1; then
-    printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n"
-    rm "$path_tmp_bin_uninstall"
-  else
-    printf -- "- Updating uninstall script..."
-    mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
-    printf "${GRN}Done!${NC}\n"
+  if [ -z "$apps" ]; then
+    printf "${RED}No simplex servers installed! Aborting.${NC}\n"
+    exit 1
   fi
 
-  if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
-    printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
-    rm "$path_tmp_bin_stopscript"
-  else
-    printf -- "- Updating stopscript script..."
-    mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
-    printf "${GRN}Done!${NC}\n"
-  fi
+  for server in $apps; do
+    # Check if info file is present
+    if [ -f "$path_conf_info/release" ]; then
+      # If present, source it
+      . "$path_conf_info/release" 2>/dev/null
 
-  if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
-    printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
-    rm "$path_tmp_bin_update"
-  else
-    printf -- "- Updating update script..."
-    mv "$path_tmp_bin_update" "$path_bin_update"
-    printf "${GRN}Done!${NC}\n"
-    printf -- "- Re-executing Update script with latest updates..."
-    exec sh "$path_bin_update" "continue"
-  fi
-}
-
-update_systemd() {
-  service="${1}-server"
-  eval "scripts_systemd=\$scripts_systemd_${1}"
-  eval "path_systemd=\$path_systemd_${1}"
-  eval "path_tmp_systemd=\$path_tmp_systemd_${1}"
-   
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_tmp_systemd"
-
-  if diff -q "$path_systemd" "$path_tmp_systemd" > /dev/null 2>&1; then
-    printf -- "- ${YLW}%s service is up-to-date${NC}.\n" "$service"
-    rm "$path_tmp_systemd"
-  else
-    printf -- "- Updating %s service..." "$service"
-    mv "$path_tmp_systemd" "$path_systemd"
-    systemctl daemon-reload
-    printf "${GRN}Done!${NC}\n"
-  fi
-
-  unset service scripts_systemd path_systemd path_tmp_systemd
-}
-
-update_bins() {
-  service="${1}-server"
-  eval "bin=\$bin_${1}"
-  eval "path_bin=\$path_bin_${1}"
-
-  set_ver() {
-    local_version='unset'
-    sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release"
-  }
-
-  if [ -f "$path_conf_info/release" ]; then
-    . "$path_conf_info/release" 2>/dev/null
-
-    set +u
-    eval "local_version=\$local_version_${1}"
-    set -u
-
-    if [ -z "${local_version}" ]; then
-            set_ver "$1"
-    fi
-  else
-    printf 'local_version_xftp=\nlocal_version_smp=\n' > "$path_conf_info/release"
-    set_ver "$1"
-  fi
-
-  if [ "$local_version" != "$remote_version" ]; then
-    if systemctl is-active --quiet "$service"; then
-      printf -- "- Stopping %s service..." "$service"
-      systemctl stop "$service"
-      printf "${GRN}Done!${NC}\n"
-
-      printf -- "- Updating %s to %s..." "$service" "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
-      printf "${GRN}Done!${NC}\n"
-      
-      printf -- "- Starting %s service..." "$service"
-      systemctl start "$service"
-      printf "${GRN}Done!${NC}\n"
+      # Check if line containing local version exists in file
+      if grep -q "local_version_${server}" "$path_conf_info/release"; then
+        # if exists, set the var
+        eval "local_version=\$local_version_${server}"
+      else
+        # If it doesn't, append it to file
+        printf "local_version_${server}=unset\n" >> "$path_conf_info/release"
+        # And set it in script (so we don't have to re-source the file)
+        eval "local_version_${server}=unset"
+      fi
     else
-      printf -- "- Updating %s to %s..." "$service" "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
-      printf "${GRN}Done!${NC}\n"
+      # If there isn't info file, populate it
+      printf "local_version_${server}=unset\n" >> "$path_conf_info/release"
     fi
-  else
-    printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service"
-  fi
+  done
 
-  set_ver "$1"
-
-  unset service bin path_bin local_version
+  # Return 
+  return 0
 }
 
+# Checks the distro and sets the urls variables
+check_distro() {
+  . /etc/os-release
+
+  case "$VERSION_ID" in
+    20.04|22.04) : ;;
+    24.04) VERSION_ID='22.04' ;;
+    *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
+  esac
+
+  version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
+  arch="$(uname -p)"
+
+  case "$arch" in
+    x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
+    *)  printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
+  esac
+
+  bin_url_smp="$bin_url/smp-server-ubuntu-${version}-${arch}"
+  bin_url_xftp="$bin_url/xftp-server-ubuntu-${version}-${arch}"
+
+  return 0
+}
+
+# General checks that must be performed on the initial execution of script
 checks() {
   if [ "$(id -u)" -ne 0 ]; then
     printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n"
     exit 1
   fi
 
-  set_version
-  os_test
-  installed_test
+  check_versions
+  check_distro
 
-  mkdir -p $path_conf_info
+  mkdir -p $path_conf_info $path_tmp_bin
+
+  return 0
 }
 
-main() {
-  checks
+#############################
+### Support functions END ###
+#############################
 
-  set +u
-  if [ "$1" != "continue" ]; then
-    set -u
-    printf "Updating scripts...\n"
-    update_scripts
-  else
-    set -u
+######################
+### Main functions ###
+######################
+
+# Downloads thing to directory and checks its sanity
+download_thing() {
+  thing="$1"
+  path="$2"
+  check_pattern="$3"
+  err_msg="$4"
+  
+  if ! curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path"; then
+    printf "${RED}Something went wrong when downloading ${YLW}%s${NC}: either you don't have connection to Github or you're rate-limited.\n" "$err_msg"
+    exit 1
+  fi
+
+  type="$(file "$path")"
+
+  case "$type" in
+    *script*|*executable*) chmod +x "$path" ;;
+  esac
+
+  if ! check_sanity "$path" "$check_pattern"; then
+    printf "${RED}Something went wrong with downloaded ${YLW}%s${NC}: file is corrupted.\n" "$err_msg"
+    exit 1
+  fi
+
+  return 0
+}
+
+# Downloads all necessary files to temp dir and set update messages for the menu
+download_all() {
+  download_thing "$scripts_url_update" "$path_tmp_bin_update" 'string: /usr/bin/env' 'Update script'
+  if change_check "$path_tmp_bin_update" "$path_bin_update"; then
+    msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-update${NC}"
+    msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}update"
+  fi
+
+  download_thing "$scripts_url_stopscript" "$path_tmp_bin_stopscript" 'string: /usr/bin/env' 'Stop script'
+  if change_check "$path_tmp_bin_stopscript" "$path_bin_stopscript"; then
+    msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-stopscript${NC}"
+    msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}stop"
+  fi
+
+  download_thing "$scripts_url_uninstall" "$path_tmp_bin_uninstall" 'string: /usr/bin/env' 'Uninstall script'
+  if change_check "$path_tmp_bin_uninstall" "$path_bin_uninstall"; then
+    msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-uninstall${NC}"
+    msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}uninstall"
+  fi
+
+  for i in $apps; do
+    service="${i}-server"
+    eval "scripts_url_systemd_final=\$scripts_url_systemd_${i}"
+    eval "path_tmp_systemd_final=\$path_tmp_systemd_${i}"
+    eval "path_systemd_final=\$path_systemd_${i}"
+   
+    download_thing "$scripts_url_systemd_final" "$path_tmp_systemd_final" 'string: [Unit]' "$service systemd service"
+    if change_check "$path_tmp_systemd_final" "$path_systemd_final"; then
+      msg_services="${msg_services+$msg_services, }${YLW}$service.service${NC}"
+      msg_services_raw="${msg_services_raw+$msg_services_raw/}$service"
+    fi
+  done
+
+  for i in $apps; do
+    service="${i}-server"
+    eval "local_version=\$local_version_${i}"
+
+    if change_check "$local_version" "$remote_version"; then
+      msg_bins="${msg_bins+$msg_bins$NL}  - ${YLW}$service${NC}: from ${BLU}$local_version${NC} to ${BLU}$remote_version${NC}"
+      msg_bins_alt="${msg_bins_alt+$msg_bins_alt, }${YLW}$service${NC}"
+      msg_bins_raw="${msg_bins_raw+$msg_bins_raw/}$service"
+    fi
+  done
+
+  return 0
+}
+
+# Updates systemd and scripts. This function depends om variables from "download_all"
+update_misc() {
+  OLD_IFS="$IFS"
+
+  IFS='/'
+  for script in ${msg_scripts_raw:-}; do
+    case "$script" in
+      update)
+        printf -- "- Updating update script..."
+        mv "$path_tmp_bin_update" "$path_bin_update"
+        printf "${GRN}Done!${NC}\n"
+        printf -- "- Re-executing Update script..."
+        exec env UPDATE_SCRIPT_DONE=1 VER="$remote_version" "$path_bin_update" "${selection}"
+        ;;
+      stop)
+        printf -- "- Updating stopscript script..."
+        mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
+        printf "${GRN}Done!${NC}\n"
+        ;;
+      uninstall)
+        printf -- "- Updating uninstall script..."
+        mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
+        printf "${GRN}Done!${NC}\n"
+        ;;
+    esac
+  done
+
+  for service in ${msg_services_raw:-}; do
+    app="${service%%-*}"
+    eval "path_systemd=\$path_systemd_${app}"
+    eval "path_tmp_systemd=\$path_tmp_systemd_${app}"
+
+    printf -- "- Updating %s service..." "$service"
+    mv "$path_tmp_systemd" "$path_systemd"
+    systemctl daemon-reload
+    printf "${GRN}Done!${NC}\n"
+  done
+
+  IFS="$OLD_IFS"
+  return 0
+}
+
+# Updates binaries. This function depends on variables from "download_all"
+update_bins() {
+  OLD_IFS="$IFS"
+
+  IFS='/'
+  for service in ${msg_bins_raw:-}; do
+    app="${service%%-*}"
+    eval "local_version=\$local_version_${app}"
+    eval "bin_url_final=\$bin_url_${app}"
+    eval "path_tmp_bin_final=\$path_tmp_bin_${app}"
+    eval "path_bin_final=\$path_bin_${app}"
+
+    # If systemd service is active
+    if systemctl is-active --quiet "$service"; then
+      printf -- "- Stopping %s service..." "$service"
+      systemctl stop "$service"
+      printf "${GRN}Done!${NC}\n"
+
+      printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version"
+      download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
+      mv "$path_tmp_bin_final" "$path_bin_final"
+      printf "${GRN}Done!${NC}\n"
+      
+      printf -- "- Starting %s service..." "$service"
+      systemctl start "$service"
+      printf "${GRN}Done!${NC}\n"
+    else
+      # If systemd service is NOT active
+      printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version"
+      download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
+      mv "$path_tmp_bin_final" "$path_bin_final"
+      printf "${GRN}Done!${NC}\n"
+    fi
+
+    # Don't forget to set version
+    sed -i -- "s|local_version_${app}=.*|local_version_${app}='${remote_version}'|" "$path_conf_info/release"
+  done
+
+  IFS="$OLD_IFS"
+  return 0
+}
+
+# Just download binaries
+download_bins() {
+  OLD_IFS="$IFS"
+
+  IFS='/'
+  for service in ${msg_bins_raw:-}; do
+    app="${service%%-*}"
+    eval "local_version=\$local_version_${app}"
+    eval "bin_url_final=\$bin_url_${app}"
+    eval "path_tmp_bin_final=\$path_tmp_bin_${app}"
+    eval "path_bin_final=\$path_bin_${app}"
+
+    printf -- "- Downloading ${YLW}%s${NC} binary..." "$service"
+    download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service"
+    printf "${GRN}Done!${NC}\n"
+  done
+
+  IFS="$OLD_IFS"
+  return 0
+}
+
+menu_init_help() {
+  menu_help="Update script for SimpleX servers and scripts.${NL}${NL}"
+  menu_help="${menu_help}${BLD}${UNDRL}Usage:${NC} [<VARIABLE>] ${BLD}simplex-servers-update${NC}${NL}       [<VARIABLE>] ${BLD}simplex-servers-update${NC} [<SUBCOMMAND>]${NL}${NL}"
+  menu_help="${menu_help}${BLD}${UNDRL}Subcommands:${NC}${NL}"
+  menu_help_sub="  ${BLD}[a]ll${NC}		Update everything without confirmation${NL}"
+  menu_help_sub="${menu_help_sub}  ${BLD}[b]inaries${NC}	Update binaries only without confirmation${NL}"
+  menu_help_sub="${menu_help_sub}  ${BLD}[d]ownload${NC}	Download everything without updating${NL}"
+  menu_help_sub="${menu_help_sub}  ${BLD}[h]elp${NC}	Print this message${NL}${NL}"
+  menu_help="${menu_help}${menu_help_sub}"
+  menu_help="${menu_help}${BLD}${UNDRL}Variables:${NC}${NL}"
+  menu_help="${menu_help}  ${BLD}VER=v3.2.1-beta.0${NC}	Update binaries to specified version${NL}"
+
+  return 0
+}
+
+menu_init() {
+  menu_end="${RED}x${NC}) Exit${NL}${NL}Selection: "
+  menu_option_download="${GRN}d${NC}) Download files only${NL}"
+
+  if [ -n "${msg_scripts:-}" ]; then
+    menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}}  - script(s): ${msg_scripts}"
+  fi
+
+  if [ -n "${msg_services:-}" ]; then
+    menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}}  - systemd service file(s): ${msg_services}"
+  fi
+
+  menu_option_all="${GRN}a${NC}) Update all: ${BLU}(recommended)${NC}${NL}${menu_option_misc_raw+${menu_option_misc_raw}${NL}}${msg_bins+${msg_bins}${NL}}"
+
+  if [ -n "${msg_bins:-}" ]; then
+    menu_option_bins="${GRN}b${NC}) Update server binaries: ${msg_bins_alt}${NL}"
+  fi
+
+  # Abort early if there's neither update binaries, nor update scripts options
+  if [ -z "${menu_option_bins:-}" ] && [ -z "${menu_option_misc_raw:-}" ]; then
+    printf "${YLW}Everything is up-to-date${NC}.\n"
+    exit 0
+  fi
+
+  menu="${menu_option_all}${menu_option_bins:-}${menu_option_download}${menu_end}"
+
+  return 0
+}
+
+options_parse() {
+  selection="$1"
+  
+  case "$selection" in
+    a|all)
+      check=0
+      if [ -z "${menu_option_misc_raw:-}" ] && [ -z "${menu_option_bins:-}" ]; then
+        printf "${YLW}Everything is up-to-date${NC}.\n"
+      else
+        if [ -n "${menu_option_misc_raw:-}" ]; then
+          update_misc
+        fi
+        if [ -n "${menu_option_bins:-}" ]; then
+          update_bins
+        fi
+      fi
+      ;;
+    b|binaries)
+      check=0
+      if [ -n "${menu_option_bins:-}" ]; then
+        update_bins
+      else
+        printf "${YLW}Binaries is up-to-date${NC}.\n"
+      fi
+      ;;
+    d|download)
+      check=0
+      if [ -n "${menu_option_bins:-}" ]; then
+        download_bins
+      fi
+
+      printf "\n${YLW}Scripts${NC}/${YLW}services${NC}/${YLW}binaries${NC} has been downloaded to ${BLU}%s${NC}\n" "$path_tmp_bin"
+      ;;
+    x)
+      check=0
+      ;;
+    *)
+      check=1
+      ;;
+  esac
+
+  return "$check"
+}
+
+##########################
+### Main functions END ###
+##########################
+
+############
+### Init ###
+############
+
+main() {
+  # Early hook to print Done after script re-execution
+  if [ -n "${UPDATE_SCRIPT_DONE:-}" ]; then
     printf "${GRN}Done!${NC}\n"
   fi
 
-  printf "Updating systemd services...\n"
-  for i in $apps; do
-    update_systemd "$i"
-  done
-  
-  printf "Updating simplex servers...\n"
-  for i in $apps; do
-    update_bins "$i"
-  done
+  # Early help menu
+  menu_init_help
 
-  rm -rf "$path_tmp_bin"
+  case "${1:-}" in
+    h|help)
+      printf '%b' "$menu_help"
+      exit 0
+      ;;
+  esac
+
+  checks
+  download_all
+  menu_init
+
+  onetime=0
+  while true; do
+    if [ "$onetime" = 0 ]; then
+      onetime=1
+
+      if [ -n "${1:-}" ]; then
+        selection="$1"
+      else
+        printf '%b' "$menu"
+        read selection
+      fi
+    else
+      read selection
+    fi
+    
+    if options_parse "$selection"; then
+      break
+    else
+      # Rerender whole menu if the first non-interactive option was bogus
+      if [ -n "${1:-}" ]; then
+        onetime=0
+        shift 1
+      else
+        # Erase last line
+        printf '\e[A\e[K'
+        # Only rerended selection
+        printf 'Selection: '
+      fi
+    fi
+  done
 }
 
 main "$@"

scripts/main/smp-server.service

@@ -5,12 +5,21 @@ Description=SMP server
 User=smp
 Group=smp
 Type=simple
+
 ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS 
 ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
+
 LimitNOFILE=65535
 KillSignal=SIGINT
+
 TimeoutStartSec=infinity
 TimeoutStopSec=infinity
+
+Restart=on-failure
+RestartSec=10s
+StartLimitBurst=3
+StartLimitInterval=60s
+
 AmbientCapabilities=CAP_NET_BIND_SERVICE
 
 [Install]

scripts/main/xftp-server.service

@@ -5,12 +5,21 @@ Description=XFTP server
 User=xftp
 Group=xftp
 Type=simple
+
 ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
 ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
+
 LimitNOFILE=65535
 KillSignal=SIGINT
+
 TimeoutStartSec=infinity
 TimeoutStopSec=infinity
+
+Restart=on-failure
+RestartSec=10s
+StartLimitBurst=3
+StartLimitInterval=60s
+
 AmbientCapabilities=CAP_NET_BIND_SERVICE
    
 [Install]

scripts/reproduce-builds.sh

@@ -0,0 +1,81 @@
+#!/usr/bin/env sh
+set -eu
+
+TAG="$1"
+
+tempdir="$(mktemp -d)"
+init_dir="$PWD"
+
+mkdir -p "$init_dir/$TAG/from-source" "$init_dir/$TAG/prebuilt"
+
+git -C "$tempdir" clone https://github.com/simplex-chat/simplexmq.git &&\
+	cd "$tempdir/simplexmq" &&\
+	git checkout "$TAG"
+
+for os in 20.04 22.04 24.04; do
+	os_url="$(printf '%s' "$os" | tr '.' '_')"
+	mkdir -p "$init_dir/cache/cabal/builder-${os}" "$init_dir/cache/dist-newstyle/builder-${os}"
+	chmod g+wX "$init_dir/cache"
+
+	docker build \
+		--no-cache \
+		-f "$tempdir/simplexmq/Dockerfile.build" \
+		--build-arg TAG=${os} \
+		-t repro-${os} \
+		.
+
+	docker run \
+		-t \
+		-d \
+		-v "$init_dir/cache/cabal/builder-${os}:/root/.cabal" \
+		-v "$init_dir/cache/dist-newstyle/builder-${os}:/dist-newstyle" \
+		-v "$tempdir/simplexmq:/project" \
+		--name builder-${os} \
+		repro-${os}
+	
+	
+	apps='smp-server xftp-server ntf-server xftp'
+
+	# Regular build (all)
+	docker exec \
+		-t \
+		-e apps="$apps" \
+		builder-${os} \
+		sh -c 'ln -fs /dist-newstyle ./dist-newstyle && cabal update && cabal build && mkdir -p /out && for i in $apps; do bin=$(find /dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done'
+
+	docker cp \
+		builder-${os}:/out \
+		out-${os}
+
+	# PostgreSQL build (only smp-server)
+	docker exec \
+		-t \
+		builder-${os} \
+		sh -c 'ln -fs /dist-newstyle ./dist-newstyle && cabal update && cabal build -fserver_postgres exe:smp-server && mkdir -p /out && bin=$(find /dist-newstyle -name "smp-server" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/'
+
+	docker cp \
+		builder-${os}:/out/smp-server \
+		"$init_dir/$TAG/from-source/smp-server-postgres-ubuntu-${os_url}-x86-64"
+
+	curl -L \
+		--output-dir "$init_dir/$TAG/prebuilt/" \
+		-O \
+		"https://github.com/simplex-chat/simplexmq/releases/download/${TAG}/smp-server-postgres-ubuntu-${os_url}-x86-64"
+	
+	for app in $apps; do
+		curl -L \
+			--output-dir "$init_dir/$TAG/prebuilt/" \
+			-O \
+		       	"https://github.com/simplex-chat/simplexmq/releases/download/${TAG}/${app}-ubuntu-${os_url}-x86-64"
+
+		mv "./out-${os}/$app" "$init_dir/$TAG/from-source/${app}-ubuntu-${os_url}-x86-64"
+	done
+
+	docker stop builder-${os}
+	docker rm builder-${os} 
+	docker image rm repro-${os}
+done
+
+# Cleanup
+cd "$init_dir"
+rm -rf "$tempdir"

simplexmq.cabal

@@ -1,11 +1,7 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.0.
---
--- see: https://github.com/sol/hpack
-
 name:           simplexmq
-version:        6.1.2.0
+version:        6.3.1.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -66,24 +62,31 @@ flag use_crypton
   manual: True
   default: True
 
+flag client_library
+  description: Don't build server-related code.
+  manual: True
+  default: False
+
+flag client_postgres
+  description: Build with PostgreSQL instead of SQLite.
+  manual: True
+  default: False
+
+flag server_postgres
+  description: Build server with support of PostgreSQL.
+  manual: True
+  default: False
+
 library
   exposed-modules:
       Simplex.FileTransfer.Agent
       Simplex.FileTransfer.Chunks
       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
-      Simplex.FileTransfer.Server.Control
-      Simplex.FileTransfer.Server.Env
-      Simplex.FileTransfer.Server.Main
-      Simplex.FileTransfer.Server.Stats
-      Simplex.FileTransfer.Server.Store
-      Simplex.FileTransfer.Server.StoreLog
       Simplex.FileTransfer.Transport
       Simplex.FileTransfer.Types
       Simplex.FileTransfer.Util
@@ -97,46 +100,14 @@ library
       Simplex.Messaging.Agent.RetryInterval
       Simplex.Messaging.Agent.Stats
       Simplex.Messaging.Agent.Store
-      Simplex.Messaging.Agent.Store.SQLite
-      Simplex.Messaging.Agent.Store.SQLite.Common
-      Simplex.Messaging.Agent.Store.SQLite.DB
-      Simplex.Messaging.Agent.Store.SQLite.Migrations
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
-      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.Store.SQLite.Migrations.M20230531_switch_status
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
-      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
+      Simplex.Messaging.Agent.Store.AgentStore
+      Simplex.Messaging.Agent.Store.Common
+      Simplex.Messaging.Agent.Store.DB
+      Simplex.Messaging.Agent.Store.Interface
+      Simplex.Messaging.Agent.Store.Migrations
+      Simplex.Messaging.Agent.Store.Migrations.App
+      Simplex.Messaging.Agent.Store.Postgres.Options
+      Simplex.Messaging.Agent.Store.Shared
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
@@ -154,34 +125,13 @@ library
       Simplex.Messaging.Encoding.String
       Simplex.Messaging.Notifications.Client
       Simplex.Messaging.Notifications.Protocol
-      Simplex.Messaging.Notifications.Server
-      Simplex.Messaging.Notifications.Server.Control
-      Simplex.Messaging.Notifications.Server.Env
-      Simplex.Messaging.Notifications.Server.Main
-      Simplex.Messaging.Notifications.Server.Push.APNS
-      Simplex.Messaging.Notifications.Server.Push.APNS.Internal
-      Simplex.Messaging.Notifications.Server.Stats
-      Simplex.Messaging.Notifications.Server.Store
-      Simplex.Messaging.Notifications.Server.StoreLog
       Simplex.Messaging.Notifications.Transport
       Simplex.Messaging.Notifications.Types
       Simplex.Messaging.Parsers
       Simplex.Messaging.Protocol
-      Simplex.Messaging.Server
-      Simplex.Messaging.Server.CLI
-      Simplex.Messaging.Server.Control
-      Simplex.Messaging.Server.Env.STM
       Simplex.Messaging.Server.Expiration
-      Simplex.Messaging.Server.Information
-      Simplex.Messaging.Server.Main
-      Simplex.Messaging.Server.MsgStore
-      Simplex.Messaging.Server.MsgStore.STM
-      Simplex.Messaging.Server.NtfStore
-      Simplex.Messaging.Server.QueueStore
+      Simplex.Messaging.Server.QueueStore.Postgres.Config
       Simplex.Messaging.Server.QueueStore.QueueInfo
-      Simplex.Messaging.Server.QueueStore.STM
-      Simplex.Messaging.Server.Stats
-      Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.ServiceScheme
       Simplex.Messaging.Session
       Simplex.Messaging.TMap
@@ -195,7 +145,6 @@ library
       Simplex.Messaging.Transport.HTTP2.Server
       Simplex.Messaging.Transport.KeepAlive
       Simplex.Messaging.Transport.Server
-      Simplex.Messaging.Transport.WebSockets
       Simplex.Messaging.Util
       Simplex.Messaging.Version
       Simplex.Messaging.Version.Internal
@@ -204,13 +153,116 @@ library
       Simplex.RemoteControl.Discovery.Multicast
       Simplex.RemoteControl.Invitation
       Simplex.RemoteControl.Types
+  if flag(client_postgres)
+      exposed-modules:
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.App
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
+  else
+      exposed-modules:
+          Simplex.Messaging.Agent.Store.SQLite
+          Simplex.Messaging.Agent.Store.SQLite.Common
+          Simplex.Messaging.Agent.Store.SQLite.DB
+          Simplex.Messaging.Agent.Store.SQLite.Migrations
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.App
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
+          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.Store.SQLite.Migrations.M20230531_switch_status
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
+  if !flag(client_library)
+      exposed-modules:
+          Simplex.FileTransfer.Client.Main
+          Simplex.FileTransfer.Server
+          Simplex.FileTransfer.Server.Control
+          Simplex.FileTransfer.Server.Env
+          Simplex.FileTransfer.Server.Main
+          Simplex.FileTransfer.Server.Stats
+          Simplex.FileTransfer.Server.Store
+          Simplex.FileTransfer.Server.StoreLog
+          Simplex.Messaging.Notifications.Server
+          Simplex.Messaging.Notifications.Server.Control
+          Simplex.Messaging.Notifications.Server.Env
+          Simplex.Messaging.Notifications.Server.Main
+          Simplex.Messaging.Notifications.Server.Push.APNS
+          Simplex.Messaging.Notifications.Server.Push.APNS.Internal
+          Simplex.Messaging.Notifications.Server.Stats
+          Simplex.Messaging.Notifications.Server.Store
+          Simplex.Messaging.Notifications.Server.StoreLog
+          Simplex.Messaging.Server
+          Simplex.Messaging.Server.CLI
+          Simplex.Messaging.Server.Control
+          Simplex.Messaging.Server.Env.STM
+          Simplex.Messaging.Server.Information
+          Simplex.Messaging.Server.Main
+          Simplex.Messaging.Server.Main.Init
+          Simplex.Messaging.Server.MsgStore
+          Simplex.Messaging.Server.MsgStore.Journal
+          Simplex.Messaging.Server.MsgStore.Journal.SharedLock
+          Simplex.Messaging.Server.MsgStore.STM
+          Simplex.Messaging.Server.MsgStore.Types
+          Simplex.Messaging.Server.NtfStore
+          Simplex.Messaging.Server.Prometheus
+          Simplex.Messaging.Server.QueueStore
+          Simplex.Messaging.Server.QueueStore.STM
+          Simplex.Messaging.Server.QueueStore.Types
+          Simplex.Messaging.Server.Stats
+          Simplex.Messaging.Server.StoreLog
+          Simplex.Messaging.Server.StoreLog.ReadWrite
+          Simplex.Messaging.Server.StoreLog.Types
+          Simplex.Messaging.Transport.WebSockets
+      if flag(client_postgres) || flag(server_postgres)
+          exposed-modules:
+              Simplex.Messaging.Agent.Store.Postgres
+              Simplex.Messaging.Agent.Store.Postgres.Common
+              Simplex.Messaging.Agent.Store.Postgres.DB
+              Simplex.Messaging.Agent.Store.Postgres.Migrations
+              Simplex.Messaging.Agent.Store.Postgres.Util
+
+      if flag(server_postgres)
+          exposed-modules:
+              Simplex.Messaging.Server.QueueStore.Postgres
+              Simplex.Messaging.Server.QueueStore.Postgres.Migrations
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
       src
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
   include-dirs:
       cbits
   c-sources:
@@ -220,14 +272,12 @@ library
       crypto
   build-depends:
       aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
     , asn1-encoding ==0.9.*
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
     , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
@@ -237,14 +287,11 @@ library
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
     , iproute ==1.7.*
     , iso8601-time ==0.1.*
     , memory ==0.18.*
@@ -253,38 +300,55 @@ library
     , network-info ==0.2.*
     , network-transport ==0.5.6
     , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
-    , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
     , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
-    , websockets ==0.12.*
     , yaml ==0.11.*
     , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
+  if !flag(client_library)
+    build-depends:
+        case-insensitive ==1.2.*
+      , hashable ==1.4.*
+      , ini ==0.4.1
+      , optparse-applicative >=0.15 && <0.17
+      , process ==1.6.*
+      , temporary ==1.3.*
+      , websockets ==0.12.*
+  if flag(client_postgres) || flag(server_postgres)
+    build-depends:
+        postgresql-libpq >=0.10.0.0
+      , postgresql-simple ==0.7.*
+      , raw-strings-qq ==1.1.*
+  if flag(client_postgres)
+    cpp-options: -DdbPostgres
+  else
+    build-depends:
+        direct-sqlcipher ==2.3.*
+      , sqlcipher-simple ==0.4.*
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres
   if impl(ghc >= 9.6.2)
     build-depends:
         bytestring ==0.11.*
-      , template-haskell ==2.20.*
       , text >=2.0.1 && <2.2
   if impl(ghc < 9.6.2)
     build-depends:
         bytestring ==0.10.*
-      , template-haskell ==2.16.*
       , text >=1.2.3.0 && <1.3
 
 executable ntf-server
+  if flag(client_library)
+      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
@@ -292,75 +356,16 @@ executable ntf-server
       apps/ntf-server
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , crypton ==0.34.*
-    , crypton-x509 ==1.7.*
-    , crypton-x509-store ==1.6.*
-    , crypton-x509-validation ==1.6.*
-    , cryptostore ==0.3.*
-    , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
-    , filepath ==1.4.*
-    , hashable ==1.4.*
-    , hourglass ==0.2.*
-    , http-types ==0.12.*
-    , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
-    , iproute ==1.7.*
-    , iso8601-time ==0.1.*
-    , memory ==0.18.*
-    , mtl >=2.3.1 && <3.0
-    , network >=3.1.2.7 && <3.2
-    , network-info ==0.2.*
-    , network-transport ==0.5.6
-    , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
+      base
+    , simple-logger
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , temporary ==1.3.*
-    , time ==1.12.*
-    , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
-    , transformers ==0.6.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
-    , websockets ==0.12.*
-    , yaml ==0.11.*
-    , zstd ==0.1.3.*
   default-language: Haskell2010
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  if impl(ghc >= 9.6.2)
-    build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
-    build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
 
 executable smp-server
+  if flag(client_library)
+      buildable: False
   main-is: Main.hs
   other-modules:
       Static
@@ -371,80 +376,27 @@ executable smp-server
       apps/smp-server/web
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , crypton ==0.34.*
-    , crypton-x509 ==1.7.*
-    , crypton-x509-store ==1.6.*
-    , crypton-x509-validation ==1.6.*
-    , cryptostore ==0.3.*
-    , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
+      base
+    , bytestring
+    , directory
     , file-embed
-    , filepath ==1.4.*
-    , hashable ==1.4.*
-    , hourglass ==0.2.*
-    , http-types ==0.12.*
-    , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
-    , iproute ==1.7.*
-    , iso8601-time ==0.1.*
-    , memory ==0.18.*
-    , mtl >=2.3.1 && <3.0
-    , network >=3.1.2.7 && <3.2
-    , network-info ==0.2.*
-    , network-transport ==0.5.6
-    , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
+    , filepath
+    , network
+    , simple-logger
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , temporary ==1.3.*
-    , time ==1.12.*
-    , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
-    , transformers ==0.6.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
+    , text
+    , unliftio
     , wai
     , wai-app-static
     , warp ==3.3.30
     , warp-tls ==3.4.7
-    , websockets ==0.12.*
-    , yaml ==0.11.*
-    , zstd ==0.1.3.*
   default-language: Haskell2010
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  if impl(ghc >= 9.6.2)
-    build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
-    build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
 
 executable xftp
+  if flag(client_library)
+      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
@@ -452,75 +404,15 @@ executable xftp
       apps/xftp
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , crypton ==0.34.*
-    , crypton-x509 ==1.7.*
-    , crypton-x509-store ==1.6.*
-    , crypton-x509-validation ==1.6.*
-    , cryptostore ==0.3.*
-    , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
-    , filepath ==1.4.*
-    , hashable ==1.4.*
-    , hourglass ==0.2.*
-    , http-types ==0.12.*
-    , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
-    , iproute ==1.7.*
-    , iso8601-time ==0.1.*
-    , memory ==0.18.*
-    , mtl >=2.3.1 && <3.0
-    , network >=3.1.2.7 && <3.2
-    , network-info ==0.2.*
-    , network-transport ==0.5.6
-    , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
+      base
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , temporary ==1.3.*
-    , time ==1.12.*
-    , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
-    , transformers ==0.6.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
-    , websockets ==0.12.*
-    , yaml ==0.11.*
-    , zstd ==0.1.3.*
   default-language: Haskell2010
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  if impl(ghc >= 9.6.2)
-    build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
-    build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
 
 executable xftp-server
+  if flag(client_library)
+      buildable: False
   main-is: Main.hs
   other-modules:
       Paths_simplexmq
@@ -528,75 +420,16 @@ executable xftp-server
       apps/xftp-server
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
   build-depends:
-      aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , crypton ==0.34.*
-    , crypton-x509 ==1.7.*
-    , crypton-x509-store ==1.6.*
-    , crypton-x509-validation ==1.6.*
-    , cryptostore ==0.3.*
-    , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
-    , filepath ==1.4.*
-    , hashable ==1.4.*
-    , hourglass ==0.2.*
-    , http-types ==0.12.*
-    , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
-    , iproute ==1.7.*
-    , iso8601-time ==0.1.*
-    , memory ==0.18.*
-    , mtl >=2.3.1 && <3.0
-    , network >=3.1.2.7 && <3.2
-    , network-info ==0.2.*
-    , network-transport ==0.5.6
-    , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
+      base
+    , simple-logger
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , temporary ==1.3.*
-    , time ==1.12.*
-    , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
-    , transformers ==0.6.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
-    , websockets ==0.12.*
-    , yaml ==0.11.*
-    , zstd ==0.1.3.*
   default-language: Haskell2010
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  if impl(ghc >= 9.6.2)
-    build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
-    build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
 
 test-suite simplexmq-test
+  if flag(client_library)
+      buildable: False
   type: exitcode-stdio-1.0
   main-is: Test.hs
   other-modules:
@@ -607,13 +440,13 @@ test-suite simplexmq-test
       AgentTests.FunctionalAPITests
       AgentTests.MigrationTests
       AgentTests.NotificationTests
-      AgentTests.SchemaDump
-      AgentTests.SQLiteTests
+      AgentTests.ServerChoice
       CLITests
       CoreTests.BatchingTests
       CoreTests.CryptoFileTests
       CoreTests.CryptoTests
       CoreTests.EncodingTests
+      CoreTests.MsgStoreTests
       CoreTests.RetryIntervalTests
       CoreTests.SOCKSSettings
       CoreTests.StoreLogTests
@@ -636,92 +469,75 @@ test-suite simplexmq-test
       Static
       Static.Embedded
       Paths_simplexmq
+  if flag(client_postgres)
+      other-modules:
+          Fixtures
+  else
+      other-modules:
+          AgentTests.SchemaDump
+          AgentTests.SQLiteTests
   hs-source-dirs:
       tests
       apps/smp-server/web
   default-extensions:
       StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
+  -- add -fhpc to ghc-options to run tests with coverage
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
   build-depends:
-      HUnit ==1.6.*
-    , QuickCheck ==2.14.*
-    , aeson ==2.2.*
-    , ansi-terminal >=0.10 && <0.12
-    , asn1-encoding ==0.9.*
-    , asn1-types ==0.3.*
-    , async ==2.2.*
-    , attoparsec ==0.14.*
-    , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , crypton ==0.34.*
-    , crypton-x509 ==1.7.*
-    , crypton-x509-store ==1.6.*
-    , crypton-x509-validation ==1.6.*
-    , cryptostore ==0.3.*
-    , data-default ==0.7.*
-    , deepseq ==1.4.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
+      base
+    , aeson
+    , async
+    , base64-bytestring
+    , bytestring
+    , containers
+    , crypton
+    , crypton-x509
+    , crypton-x509-store
+    , crypton-x509-validation
+    , directory
     , file-embed
-    , filepath ==1.4.*
+    , filepath
     , generic-random ==1.5.*
-    , hashable ==1.4.*
-    , hourglass ==0.2.*
+    , hashable
     , hspec ==2.11.*
-    , hspec-core ==2.11.*
     , http-client
-    , http-client-tls
-    , http-types ==0.12.*
-    , http2 >=4.2.2 && <4.3
-    , ini ==0.4.1
-    , iproute ==1.7.*
-    , iso8601-time ==0.1.*
+    , http-types
+    , http2
+    , HUnit ==1.6.*
+    , ini
+    , iso8601-time
     , main-tester ==0.2.*
-    , memory ==0.18.*
-    , mtl >=2.3.1 && <3.0
-    , network >=3.1.2.7 && <3.2
-    , network-info ==0.2.*
-    , network-transport ==0.5.6
-    , network-udp ==0.0.*
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
+    , mtl
+    , network
+    , QuickCheck ==2.14.*
+    , random
     , silently ==1.2.*
-    , simple-logger ==0.1.*
+    , simple-logger
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , temporary ==1.3.*
-    , time ==1.12.*
-    , time-manager ==0.0.*
+    , stm
+    , text
+    , time
     , timeit ==2.0.*
-    , tls >=1.9.0 && <1.10
-    , transformers ==0.6.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
+    , transformers
+    , unliftio
+    , unliftio-core
     , unordered-containers
     , wai
     , wai-app-static
     , warp
     , warp-tls
-    , websockets ==0.12.*
-    , yaml ==0.11.*
-    , zstd ==0.1.3.*
+    , yaml
   default-language: Haskell2010
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  if impl(ghc >= 9.6.2)
+  if flag(client_postgres)
+    cpp-options: -DdbPostgres
+  else
     build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
+        deepseq ==1.4.*
+      , memory
+      , process
+      , sqlcipher-simple
+  if flag(client_postgres) || flag(server_postgres)
     build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
+        postgresql-simple ==0.7.*
+  if flag(server_postgres)
+    cpp-options: -DdbServerPostgres

src/Simplex/FileTransfer/Agent.hs

@@ -51,8 +51,7 @@ import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Simplex.FileTransfer.Chunks (toKB)
-import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
-import Simplex.FileTransfer.Client.Main
+import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize)
 import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
@@ -66,8 +65,8 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
-import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import Simplex.Messaging.Agent.Store.AgentStore
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -461,14 +460,14 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
           pure srv
           where
             tryCreate = do
-              usedSrvs <- newTVarIO ([] :: [XFTPServer])
+              triedHosts <- newTVarIO S.empty
               let AgentClient {xftpServers} = c
               userSrvCount <- liftIO $ length <$> TM.lookupIO userId xftpServers
               withRetryIntervalCount (riFast ri) $ \n _ loop -> do
                 liftIO $ waitWhileSuspended c
                 liftIO $ waitForUserNetwork c
                 let triedAllSrvs = n > userSrvCount
-                createWithNextSrv usedSrvs
+                createWithNextSrv triedHosts
                   `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
               where
                 -- we don't do closeXFTPServerClient here to not risk closing connection for concurrent chunk upload
@@ -477,10 +476,10 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
                     when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e
                   liftIO $ assertAgentForeground c
                   loop
-            createWithNextSrv usedSrvs = do
+            createWithNextSrv triedHosts = do
               deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
               when deleted $ throwE $ FILE NO_FILE
-              withNextSrv c userId usedSrvs [] $ \srvAuth -> do
+              withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
                 replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
                 pure (replica, srvAuth)
 
@@ -546,8 +545,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
         withStore' c $ \db -> updateSndFileComplete db sndFileId
       where
         addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
-        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
-          | length rcvIdsKeys > numRecipients = throwE $ INTERNAL "too many recipients"
+        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {sndChunkReplicaId, rcvIdsKeys}
+          | length rcvIdsKeys > numRecipients = throwE $ INTERNAL ("too many recipients, sndChunkReplicaId = " <> show sndChunkReplicaId)
           | length rcvIdsKeys == numRecipients = pure cr
           | otherwise = do
               let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients

src/Simplex/FileTransfer/Client.hs

@@ -20,16 +20,19 @@ import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
 import Data.Int (Int64)
+import Data.List (foldl')
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (listToMaybe)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
+import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
-import Simplex.FileTransfer.Server.Env (supportedXFTPhandshakes)
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
@@ -299,3 +302,41 @@ noFile HTTP2Body {bodyPart} a = case bodyPart of
 
 -- FACK :: FileCommand Recipient
 -- PING :: FileCommand Recipient
+
+singleChunkSize :: Int64 -> Maybe Word32
+singleChunkSize size' =
+  listToMaybe $ dropWhile (< chunkSize) serverChunkSizes
+  where
+    chunkSize = fromIntegral size'
+
+prepareChunkSizes :: Int64 -> [Word32]
+prepareChunkSizes size' = prepareSizes size'
+  where
+    (smallSize, bigSize)
+      | size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
+      | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
+      | otherwise = (chunkSize0, chunkSize1)
+    size34 sz = (fromIntegral sz * 3) `div` 4
+    prepareSizes 0 = []
+    prepareSizes size
+      | size >= fromIntegral bigSize = replicate (fromIntegral n1) bigSize <> prepareSizes remSz
+      | size > size34 bigSize = [bigSize]
+      | otherwise = replicate (fromIntegral n2') smallSize
+      where
+        (n1, remSz) = size `divMod` fromIntegral bigSize
+        n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallSize) in if remSz2 == 0 then n2 else n2 + 1
+
+prepareChunkSpecs :: FilePath -> [Word32] -> [XFTPChunkSpec]
+prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) chunkSizes
+  where
+    addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec])
+    addSpec (chunkOffset, specs) sz =
+      let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = sz}
+       in (chunkOffset + fromIntegral sz, spec : specs)
+
+getChunkDigest :: XFTPChunkSpec -> IO ByteString
+getChunkDigest XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
+  withFile chunkPath ReadMode $ \h -> do
+    hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+    chunk <- LB.hGet h (fromIntegral chunkSize)
+    pure $! LC.sha256Hash chunk

src/Simplex/FileTransfer/Client/Main.hs

@@ -19,11 +19,7 @@ module Simplex.FileTransfer.Client.Main
     singleChunkSize,
     prepareChunkSizes,
     prepareChunkSpecs,
-    maxFileSize,
-    maxFileSizeHard,
-    fileSizeLen,
     getChunkDigest,
-    SentRecipientReplica (..),
   )
 where
 
@@ -34,7 +30,6 @@ import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
-import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
@@ -45,7 +40,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.Word (Word32)
 import GHC.Records (HasField (getField))
@@ -80,20 +75,6 @@ import UnliftIO.Directory
 xftpClientVersion :: String
 xftpClientVersion = "1.0.1"
 
--- | Soft limit for XFTP clients. Should be checked and reported to user.
-maxFileSize :: Int64
-maxFileSize = gb 1
-
-maxFileSizeStr :: String
-maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
-
--- | Hard internal limit for XFTP agent after which it refuses to prepare chunks.
-maxFileSizeHard :: Int64
-maxFileSizeHard = gb 5
-
-fileSizeLen :: Int64
-fileSizeLen = 8
-
 newtype CLIError = CLIError String
   deriving (Eq, Show, Exception)
 
@@ -231,16 +212,6 @@ data SentFileChunkReplica = SentFileChunkReplica
   }
   deriving (Show)
 
-data SentRecipientReplica = SentRecipientReplica
-  { chunkNo :: Int,
-    server :: XFTPServer,
-    rcvNo :: Int,
-    replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateAuthKey,
-    digest :: FileDigest,
-    chunkSize :: FileSize Word32
-  }
-
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
@@ -414,13 +385,6 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       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
-    chunk <- LB.hGet h (fromIntegral chunkSize)
-    pure $! LC.sha256Hash chunk
-
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
   getFileDescription' fileDescription >>= receive
@@ -536,37 +500,6 @@ getFileDescription' path =
   getFileDescription path >>= \case
     AVFD fd -> either (throwE . CLIError) pure $ checkParty fd
 
-singleChunkSize :: Int64 -> Maybe Word32
-singleChunkSize size' =
-  listToMaybe $ dropWhile (< chunkSize) serverChunkSizes
-  where
-    chunkSize = fromIntegral size'
-
-prepareChunkSizes :: Int64 -> [Word32]
-prepareChunkSizes size' = prepareSizes size'
-  where
-    (smallSize, bigSize)
-      | size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
-      | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
-      | otherwise = (chunkSize0, chunkSize1)
-    size34 sz = (fromIntegral sz * 3) `div` 4
-    prepareSizes 0 = []
-    prepareSizes size
-      | size >= fromIntegral bigSize = replicate (fromIntegral n1) bigSize <> prepareSizes remSz
-      | size > size34 bigSize = [bigSize]
-      | otherwise = replicate (fromIntegral n2') smallSize
-      where
-        (n1, remSz) = size `divMod` fromIntegral bigSize
-        n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallSize) in if remSz2 == 0 then n2 else n2 + 1
-
-prepareChunkSpecs :: FilePath -> [Word32] -> [XFTPChunkSpec]
-prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) chunkSizes
-  where
-    addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec])
-    addSpec (chunkOffset, specs) sz =
-      let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = sz}
-       in (chunkOffset + fromIntegral sz, spec : specs)
-
 getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
 getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path
 

src/Simplex/FileTransfer/Description.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
@@ -37,6 +38,10 @@ module Simplex.FileTransfer.Description
     FileClientData,
     fileDescriptionURI,
     qrSizeLimit,
+    maxFileSize,
+    maxFileSizeStr,
+    maxFileSizeHard,
+    fileSizeLen,
   )
 where
 
@@ -62,11 +67,10 @@ import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
 import qualified Data.Yaml as Y
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.Messaging.Agent.QueryString
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, parseAll)
@@ -109,6 +113,9 @@ fdSeparator = "################################\n"
 
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
+  deriving newtype (FromField)
+
+instance ToField FileDigest where toField (FileDigest s) = toField $ Binary s
 
 instance StrEncoding FileDigest where
   strEncode (FileDigest fd) = strEncode fd
@@ -122,10 +129,6 @@ 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,
@@ -266,6 +269,21 @@ instance StrEncoding FileDescriptionURI where
 qrSizeLimit :: Int
 qrSizeLimit = 1002 -- ~2 chunks in URLencoded YAML with some spare size for server hosts
 
+-- | Soft limit for XFTP clients. Should be checked and reported to user.
+maxFileSize :: Int64
+maxFileSize = gb 1
+
+maxFileSizeStr :: String
+maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
+
+-- | Hard internal limit for XFTP agent after which it refuses to prepare chunks.
+maxFileSizeHard :: Int64
+maxFileSizeHard = gb 5
+
+fileSizeLen :: Int64
+fileSizeLen = 8
+
+
 instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strEncode (FileSize b)
     | b' /= 0 = bshow b
@@ -288,9 +306,9 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
 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
+deriving newtype instance FromField a => FromField (FileSize a)
 
-instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s
+deriving newtype instance ToField a => ToField (FileSize a)
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [NonEmpty FileServerReplica]
 groupReplicasByServer defChunkSize =

src/Simplex/FileTransfer/Protocol.hs

@@ -25,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
-import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, xftpClientHandshakeStub)
+import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub)
 import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -276,12 +276,14 @@ data FileResponse
 
 instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
   type Tag FileResponse = FileResponseTag
-  encodeProtocol _v = \case
+  encodeProtocol v = \case
     FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
     FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
     FROk -> e FROk_
-    FRErr err -> e (FRErr_, ' ', err)
+    FRErr err -> case err of
+      BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH)
+      _ -> e (FRErr_, ' ', err)
     FRPong -> e FRPong_
     where
       e :: Encoding a => a -> ByteString

src/Simplex/FileTransfer/Server.hs

@@ -53,11 +53,11 @@ 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 (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
+import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -181,6 +181,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
     stopServer = do
       withFileLog closeStoreLog
       saveServerStats
+      logInfo "Server stopped"
 
     expireFilesThread_ :: XFTPServerConfig -> [M ()]
     expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
@@ -286,11 +287,15 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               CPDelete fileId -> withUserRole $ unliftIO u $ do
                 fs <- asks store
                 r <- runExceptT $ do
-                  let asSender = ExceptT . atomically $ getFile fs SFSender fileId
-                  let asRecipient = ExceptT . atomically $ getFile fs SFRecipient fileId
-                  (fr, _) <- asSender `catchError` const asRecipient
+                  (fr, _) <- ExceptT $ atomically $ getFile fs SFRecipient fileId
                   ExceptT $ deleteServerFile_ fr
                 liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r
+              CPBlock fileId info -> withUserRole $ unliftIO u $ do
+                fs <- asks store
+                r <- runExceptT $ do
+                  (fr, _) <- ExceptT $ atomically $ getFile fs SFRecipient fileId
+                  ExceptT $ blockServerFile fr info
+                liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r
               CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
@@ -320,7 +325,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
               let THandleParams {thAuth} = thParams
               verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
                 VRVerified req -> uncurry send =<< processXFTPRequest body req
-                VRFailed -> send (FRErr AUTH) Nothing
+                VRFailed e -> send (FRErr e) Nothing
             Left e -> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
@@ -354,7 +359,7 @@ randomDelay = do
     threadDelay $ (d * (1000 + pc)) `div` 1000
 #endif
 
-data VerificationResult = VRVerified XFTPRequest | VRFailed
+data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
 
 verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
 verifyXFTPTransmission auth_ tAuth authorized fId cmd =
@@ -366,13 +371,19 @@ verifyXFTPTransmission auth_ tAuth authorized fId cmd =
     verifyCmd :: SFileParty p -> M VerificationResult
     verifyCmd party = do
       st <- asks store
-      atomically $ verify <$> getFile st party fId
+      atomically $ verify =<< getFile st party fId
       where
         verify = \case
-          Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
-          _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed
+          Right (fr, k) -> result <$> readTVar (fileStatus fr)
+            where
+              result = \case
+                EntityActive -> XFTPReqCmd fId fr cmd `verifyWith` k
+                EntityBlocked info -> VRFailed $ BLOCKED info
+                EntityOff -> noFileAuth
+          Left _ -> pure noFileAuth
+        noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH
     -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed
+    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -389,7 +400,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     FACK -> noFile =<< ackFileReception fId fr
     -- it should never get to the commands below, they are passed in other constructors of XFTPRequest
     FNEW {} -> noFile $ FRErr INTERNAL
-    PING -> noFile FRPong
+    PING -> noFile $ FRErr INTERNAL
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
@@ -404,7 +415,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         sId <- ExceptT $ addFileRetry st file 3 ts
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> do
-          logAddFile sl sId file ts
+          logAddFile sl sId file ts EntityActive
           logAddRecipients sl sId rcps
         stats <- asks serverStats
         lift $ incFileStat filesCreated
@@ -415,7 +426,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts =
       retryAdd n $ \sId -> runExceptT $ do
-        ExceptT $ addFile st sId file ts
+        ExceptT $ addFile st sId file ts EntityActive
         pure sId
     addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient)
     addRecipientRetry st n sId rpk =
@@ -517,15 +528,24 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       pure FROk
 
 deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
-deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
+deleteServerFile_ fr@FileRec {senderId} = do
   withFileLog (`logDeleteFile` senderId)
-  runExceptT $ do
-    path <- readTVarIO filePath
-    stats <- asks serverStats
-    ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
-    st <- asks store
-    void $ atomically $ deleteFile st senderId
-    lift $ incFileStat filesDeleted
+  deleteOrBlockServerFile_ fr filesDeleted (`deleteFile` senderId)
+
+-- this also deletes the file from storage, but doesn't include it in delete statistics
+blockServerFile :: FileRec -> BlockingInfo -> M (Either XFTPErrorType ())
+blockServerFile fr@FileRec {senderId} info = do
+  withFileLog $ \sl -> logBlockFile sl senderId info
+  deleteOrBlockServerFile_ fr filesBlocked $ \st -> blockFile st senderId info True
+
+deleteOrBlockServerFile_ :: FileRec -> (FileServerStats -> IORef Int) -> (FileStore -> STM (Either XFTPErrorType ())) -> M (Either XFTPErrorType ())
+deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExceptT $ do
+  path <- readTVarIO filePath
+  stats <- asks serverStats
+  ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
+  st <- asks store
+  void $ atomically $ storeAction st
+  lift $ incFileStat stat
   where
     deletedStats stats = do
       liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)

src/Simplex/FileTransfer/Server/Control.hs

@@ -6,12 +6,13 @@ module Simplex.FileTransfer.Server.Control where
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Simplex.FileTransfer.Protocol (XFTPFileId)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth)
+import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo)
 
 data ControlProtocol
   = CPAuth BasicAuth
   | CPStatsRTS
   | CPDelete XFTPFileId
+  | CPBlock XFTPFileId BlockingInfo
   | CPHelp
   | CPQuit
   | CPSkip
@@ -21,6 +22,7 @@ instance StrEncoding ControlProtocol where
     CPAuth tok -> "auth " <> strEncode tok
     CPStatsRTS -> "stats-rts"
     CPDelete fId -> strEncode (Str "delete", fId)
+    CPBlock fId info -> strEncode (Str "block", fId, info)
     CPHelp -> "help"
     CPQuit -> "quit"
     CPSkip -> ""
@@ -29,6 +31,7 @@ instance StrEncoding ControlProtocol where
       "auth" -> CPAuth <$> _strP
       "stats-rts" -> pure CPStatsRTS
       "delete" -> CPDelete <$> _strP
+      "block" -> CPBlock <$> _strP <*> _strP
       "help" -> pure CPHelp
       "quit" -> pure CPQuit
       "" -> pure CPSkip

src/Simplex/FileTransfer/Server/Env.hs

@@ -28,7 +28,6 @@ import Simplex.FileTransfer.Transport (VersionRangeXFTP)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
@@ -96,9 +95,6 @@ defaultFileExpiration =
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 
-supportedXFTPhandshakes :: [ALPN]
-supportedXFTPhandshakes = ["xftp/1"]
-
 newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do
   random <- C.newRandom

src/Simplex/FileTransfer/Server/Main.hs

@@ -51,7 +51,9 @@ xftpServerCLI cfgPath logPath = do
         True -> readIniFile iniFile >>= either exitError runServer
         _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      confirmOrExit
+        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+        "Server NOT deleted"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"

src/Simplex/FileTransfer/Server/Stats.hs

@@ -20,6 +20,7 @@ data FileServerStats = FileServerStats
     filesUploaded :: IORef Int,
     filesExpired :: IORef Int,
     filesDeleted :: IORef Int,
+    filesBlocked :: IORef Int,
     filesDownloaded :: PeriodStats,
     fileDownloads :: IORef Int,
     fileDownloadAcks :: IORef Int,
@@ -34,6 +35,7 @@ data FileServerStatsData = FileServerStatsData
     _filesUploaded :: Int,
     _filesExpired :: Int,
     _filesDeleted :: Int,
+    _filesBlocked :: Int,
     _filesDownloaded :: PeriodStatsData,
     _fileDownloads :: Int,
     _fileDownloadAcks :: Int,
@@ -50,12 +52,13 @@ newFileServerStats ts = do
   filesUploaded <- newIORef 0
   filesExpired <- newIORef 0
   filesDeleted <- newIORef 0
+  filesBlocked <- newIORef 0
   filesDownloaded <- newPeriodStats
   fileDownloads <- newIORef 0
   fileDownloadAcks <- newIORef 0
   filesCount <- newIORef 0
   filesSize <- newIORef 0
-  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
+  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesBlocked, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
 
 getFileServerStatsData :: FileServerStats -> IO FileServerStatsData
 getFileServerStatsData s = do
@@ -65,12 +68,13 @@ getFileServerStatsData s = do
   _filesUploaded <- readIORef $ filesUploaded s
   _filesExpired <- readIORef $ filesExpired s
   _filesDeleted <- readIORef $ filesDeleted s
+  _filesBlocked <- readIORef $ filesBlocked s
   _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
   _fileDownloads <- readIORef $ fileDownloads s
   _fileDownloadAcks <- readIORef $ fileDownloadAcks s
   _filesCount <- readIORef $ filesCount s
   _filesSize <- readIORef $ filesSize s
-  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
 
 -- this function is not thread safe, it is used on server start only
 setFileServerStats :: FileServerStats -> FileServerStatsData -> IO ()
@@ -81,6 +85,7 @@ setFileServerStats s d = do
   writeIORef (filesUploaded s) $! _filesUploaded d
   writeIORef (filesExpired s) $! _filesExpired d
   writeIORef (filesDeleted s) $! _filesDeleted d
+  writeIORef (filesBlocked s) $! _filesBlocked d
   setPeriodStats (filesDownloaded s) $! _filesDownloaded d
   writeIORef (fileDownloads s) $! _fileDownloads d
   writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d
@@ -88,7 +93,7 @@ setFileServerStats s d = do
   writeIORef (filesSize s) $! _filesSize d
 
 instance StrEncoding FileServerStatsData where
-  strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =
+  strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "filesCreated=" <> strEncode _filesCreated,
@@ -96,6 +101,7 @@ instance StrEncoding FileServerStatsData where
         "filesUploaded=" <> strEncode _filesUploaded,
         "filesExpired=" <> strEncode _filesExpired,
         "filesDeleted=" <> strEncode _filesDeleted,
+        "filesBlocked=" <> strEncode _filesBlocked,
         "filesCount=" <> strEncode _filesCount,
         "filesSize=" <> strEncode _filesSize,
         "filesDownloaded:",
@@ -110,9 +116,12 @@ instance StrEncoding FileServerStatsData where
     _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine
     _filesExpired <- "filesExpired=" *> strP <* A.endOfLine <|> pure 0
     _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine
+    _filesBlocked <- opt "filesBlocked="
     _filesCount <- "filesCount=" *> strP <* A.endOfLine <|> pure 0
     _filesSize <- "filesSize=" *> strP <* A.endOfLine <|> pure 0
     _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine
     _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine
     _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine
-    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+    where
+      opt s = A.string s *> strP <* A.endOfLine <|> pure 0

src/Simplex/FileTransfer/Server/Store.hs

@@ -13,6 +13,7 @@ module Simplex.FileTransfer.Server.Store
     setFilePath,
     addRecipient,
     deleteFile,
+    blockFile,
     deleteRecipient,
     expiredFilePath,
     getFile,
@@ -22,6 +23,7 @@ module Simplex.FileTransfer.Server.Store
 where
 
 import Control.Concurrent.STM
+import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Int (Int64)
 import Data.Set (Set)
@@ -30,8 +32,8 @@ import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId
 import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
+import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..), ServerEntityStatus (..))
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, ($>>=))
@@ -47,7 +49,8 @@ data FileRec = FileRec
     fileInfo :: FileInfo,
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
-    createdAt :: RoundedSystemTime
+    createdAt :: RoundedSystemTime,
+    fileStatus :: TVar ServerEntityStatus
   }
 
 fileTimePrecision :: Int64
@@ -67,18 +70,19 @@ newFileStore = do
   usedStorage <- newTVarIO 0
   pure FileStore {files, recipients, usedStorage}
 
-addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
-addFile FileStore {files} sId fileInfo createdAt =
+addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM (Either XFTPErrorType ())
+addFile FileStore {files} sId fileInfo createdAt status =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
-    f <- newFileRec sId fileInfo createdAt
+    f <- newFileRec sId fileInfo createdAt status
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
-newFileRec senderId fileInfo createdAt = do
+newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM FileRec
+newFileRec senderId fileInfo createdAt status = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt}
+  fileStatus <- newTVar status
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
 
 setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
 setFilePath st sId fPath =
@@ -109,6 +113,14 @@ deleteFile FileStore {files, recipients, usedStorage} senderId = do
       pure $ Right ()
     _ -> pure $ Left AUTH
 
+-- this function must be called after the file is deleted from the file system
+blockFile :: FileStore -> SenderId -> BlockingInfo -> Bool -> STM (Either XFTPErrorType ())
+blockFile st@FileStore {usedStorage} senderId info deleted =
+  withFile st senderId $ \FileRec {fileInfo, fileStatus} -> do
+    when deleted $ modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo)
+    writeTVar fileStatus $! EntityBlocked info
+    pure $ Right ()
+
 deleteRecipient :: FileStore -> RecipientId -> FileRec -> STM ()
 deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
   TM.delete rId recipients

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -14,16 +14,18 @@ module Simplex.FileTransfer.Server.StoreLog
     logPutFile,
     logAddRecipients,
     logDeleteFile,
+    logBlockFile,
     logAckFile,
   )
 where
 
+import Control.Applicative ((<|>))
 import Control.Concurrent.STM
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Composition ((.:), (.:.))
+import Data.Composition ((.:), (.::))
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -31,41 +33,44 @@ import qualified Data.Map.Strict as M
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Store
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
-import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
+import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..))
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo RoundedSystemTime
+  = AddFile SenderId FileInfo RoundedSystemTime ServerEntityStatus
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
-  | AckFile RecipientId
+  | BlockFile SenderId BlockingInfo
+  | AckFile RecipientId -- TODO add senderId as well?
   deriving (Show)
 
 instance StrEncoding FileStoreLogRecord where
   strEncode = \case
-    AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt)
+    AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status)
     PutFile sId path -> strEncode (Str "FPUT", sId, path)
     AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
     DeleteFile sId -> strEncode (Str "FDEL", sId)
+    BlockFile sId info -> strEncode (Str "FBLK", sId, info)
     AckFile rId -> strEncode (Str "FACK", rId)
   strP =
     A.choice
-      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP),
+      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)),
         "FPUT " *> (PutFile <$> strP_ <*> strP),
         "FADD " *> (AddRecipients <$> strP_ <*> strP),
         "FDEL " *> (DeleteFile <$> strP),
+        "FBLK " *> (BlockFile <$> strP_ <*> strP),
         "FACK " *> (AckFile <$> strP)
       ]
 
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
-logAddFile s = logFileStoreRecord s .:. AddFile
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> IO ()
+logAddFile s = logFileStoreRecord s .:: AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
@@ -76,6 +81,9 @@ logAddRecipients s = logFileStoreRecord s .: AddRecipients
 logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO ()
 logDeleteFile s = logFileStoreRecord s . DeleteFile
 
+logBlockFile :: StoreLog 'WriteMode -> SenderId -> BlockingInfo -> IO ()
+logBlockFile s fId = logFileStoreRecord s . BlockFile fId
+
 logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
 logAckFile s = logFileStoreRecord s . AckFile
 
@@ -92,10 +100,11 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
           Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
           _ -> pure ()
     addToStore = \case
-      AddFile sId file createdAt -> addFile st sId file createdAt
+      AddFile sId file createdAt status -> addFile st sId file createdAt status
       PutFile qId path -> setFilePath st qId path
       AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
       DeleteFile sId -> deleteFile st sId
+      BlockFile sId info -> blockFile st sId info True
       AckFile rId -> ackFile st rId
     addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps
 
@@ -105,8 +114,9 @@ writeFileStore s FileStore {files, recipients} = do
   readTVarIO files >>= mapM_ (logFile allRcps)
   where
     logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
-    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do
-      logAddFile s senderId fileInfo createdAt
+    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do
+      status <- readTVarIO fileStatus
+      logAddFile s senderId fileInfo createdAt status
       (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
       mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
       mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs

src/Simplex/FileTransfer/Transport.hs

@@ -11,7 +11,9 @@
 module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
     authCmdsXFTPVersion,
+    blockedFilesXFTPVersion,
     xftpClientHandshakeStub,
+    supportedXFTPhandshakes,
     XFTPClientHandshake (..),
     -- xftpClientHandshake,
     XFTPServerHandshake (..),
@@ -32,7 +34,6 @@ module Simplex.FileTransfer.Transport
   )
 where
 
-import Control.Applicative ((<|>))
 import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
@@ -56,8 +57,8 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
-import Simplex.Messaging.Protocol (CommandError)
-import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
+import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
+import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
 import Simplex.Messaging.Util (bshow, tshow)
 import Simplex.Messaging.Version
@@ -91,15 +92,21 @@ initialXFTPVersion = VersionXFTP 1
 authCmdsXFTPVersion :: VersionXFTP
 authCmdsXFTPVersion = VersionXFTP 2
 
+blockedFilesXFTPVersion :: VersionXFTP
+blockedFilesXFTPVersion = VersionXFTP 3
+
 currentXFTPVersion :: VersionXFTP
-currentXFTPVersion = VersionXFTP 2
+currentXFTPVersion = VersionXFTP 3
 
 supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
 
 -- XFTP protocol does not use this handshake method
-xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
-xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion
+xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
+xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
+
+supportedXFTPhandshakes :: [ALPN]
+supportedXFTPhandshakes = ["xftp/1"]
 
 data XFTPServerHandshake = XFTPServerHandshake
   { xftpVersionRange :: VersionRangeXFTP,
@@ -207,6 +214,8 @@ data XFTPErrorType
     CMD {cmdErr :: CommandError}
   | -- | command authorization error - bad signature or non-existing SMP queue
     AUTH
+  | -- | command with the entity that was blocked
+    BLOCKED {blockInfo :: BlockingInfo}
   | -- | incorrent file size
     SIZE
   | -- | storage quota exceeded
@@ -227,15 +236,46 @@ data XFTPErrorType
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
     DUPLICATE_ -- not part of SMP protocol, used internally
-  deriving (Eq, Read, Show)
+  deriving (Eq, Show)
 
 instance StrEncoding XFTPErrorType where
   strEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
+    HANDSHAKE -> "HANDSHAKE"
     CMD e -> "CMD " <> bshow e
-    e -> bshow e
+    AUTH -> "AUTH"
+    BLOCKED info -> "BLOCKED " <> strEncode info
+    SIZE -> "SIZE"
+    QUOTA -> "QUOTA"
+    DIGEST -> "DIGEST"
+    CRYPTO -> "CRYPTO"
+    NO_FILE -> "NO_FILE"
+    HAS_FILE -> "HAS_FILE"
+    FILE_IO -> "FILE_IO"
+    TIMEOUT -> "TIMEOUT"
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
+
   strP =
-    "CMD " *> (CMD <$> parseRead1)
-      <|> parseRead1
+    A.takeTill (== ' ') >>= \case
+      "BLOCK" -> pure BLOCK
+      "SESSION" -> pure SESSION
+      "HANDSHAKE" -> pure HANDSHAKE
+      "CMD" -> CMD <$> parseRead1
+      "AUTH" -> pure AUTH
+      "BLOCKED" -> BLOCKED <$> _strP
+      "SIZE" -> pure SIZE
+      "QUOTA" -> pure QUOTA
+      "DIGEST" -> pure DIGEST
+      "CRYPTO" -> pure CRYPTO
+      "NO_FILE" -> pure NO_FILE
+      "HAS_FILE" -> pure HAS_FILE
+      "FILE_IO" -> pure FILE_IO
+      "TIMEOUT" -> pure TIMEOUT
+      "INTERNAL" -> pure INTERNAL
+      "DUPLICATE_" -> pure DUPLICATE_
+      _ -> fail "bad error type"
 
 instance Encoding XFTPErrorType where
   smpEncode = \case
@@ -244,6 +284,7 @@ instance Encoding XFTPErrorType where
     HANDSHAKE -> "HANDSHAKE"
     CMD err -> "CMD " <> smpEncode err
     AUTH -> "AUTH"
+    BLOCKED info -> "BLOCKED " <> smpEncode info
     SIZE -> "SIZE"
     QUOTA -> "QUOTA"
     DIGEST -> "DIGEST"
@@ -262,6 +303,7 @@ instance Encoding XFTPErrorType where
       "HANDSHAKE" -> pure HANDSHAKE
       "CMD" -> CMD <$> _smpP
       "AUTH" -> pure AUTH
+      "BLOCKED" -> BLOCKED <$> _smpP
       "SIZE" -> pure SIZE
       "QUOTA" -> pure QUOTA
       "DIGEST" -> pure DIGEST

src/Simplex/FileTransfer/Types.hs

@@ -13,8 +13,6 @@ import Data.Int (Int64)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 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 qualified Simplex.Messaging.Crypto as C
@@ -24,6 +22,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (XFTPServer)
 import System.FilePath ((</>))
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 
 type RcvFileId = ByteString -- Agent entity ID
 
@@ -246,6 +245,16 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica
   }
   deriving (Show)
 
+data SentRecipientReplica = SentRecipientReplica
+  { chunkNo :: Int,
+    server :: XFTPServer,
+    rcvNo :: Int,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateAuthKey,
+    digest :: FileDigest,
+    chunkSize :: FileSize Word32
+  }
+
 data FileErrorType
   = -- | cannot proceed with download from not approved relays without proxy
     NOT_APPROVED

src/Simplex/Messaging/Agent.hs

@@ -35,6 +35,8 @@ module Simplex.Messaging.Agent
     AE,
     SubscriptionsInfo (..),
     MsgReq,
+    ValueOrRef (..),
+    vrValue,
     getSMPAgentClient,
     getSMPAgentClient_,
     disconnectAgentClient,
@@ -120,6 +122,8 @@ module Simplex.Messaging.Agent
     debugAgentLocks,
     getAgentSubscriptions,
     logConnection,
+    -- for tests
+    withAgentEnv,
   )
 where
 
@@ -138,6 +142,9 @@ import Data.Either (isRight, partitionEithers, rights)
 import Data.Foldable (foldl', toList)
 import Data.Functor (($>))
 import Data.Functor.Identity
+import Data.Int (Int64)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IM
 import Data.List (find)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
@@ -165,9 +172,11 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
+import Simplex.Messaging.Agent.Store.AgentStore
+import Simplex.Messaging.Agent.Store.Common (DBStore)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations)
+import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration)
 import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
@@ -198,11 +207,11 @@ import UnliftIO.STM
 type AE a = ExceptT AgentErrorType IO a
 
 -- | Creates an SMP agent client instance
-getSMPAgentClient :: AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient
+getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
 getSMPAgentClient = getSMPAgentClient_ 1
 {-# INLINE getSMPAgentClient #-}
 
-getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient
+getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
 getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp} store backgroundMode =
   newSMPAgentEnv cfg store >>= runReaderT runAgent
   where
@@ -275,7 +284,7 @@ disposeAgentClient c@AgentClient {acThread, agentEnv = Env {store}} = do
   t_ <- atomically (swapTVar acThread Nothing) $>>= (liftIO . deRefWeak)
   disconnectAgentClient c
   mapM_ killThread t_
-  liftIO $ closeSQLiteStore store
+  liftIO $ closeDBStore store
 
 resumeAgentClient :: AgentClient -> IO ()
 resumeAgentClient c = atomically $ writeTVar (active c) True
@@ -405,11 +414,25 @@ sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> A
 sendMessage c = withAgentEnv c .:: sendMessage' c
 {-# INLINE sendMessage #-}
 
+data ValueOrRef a = VRValue (Maybe Int) a | VRRef Int
+
+instance Functor ValueOrRef where
+  fmap f = \case
+    VRValue i_ a -> VRValue i_ (f a)
+    VRRef i -> VRRef i
+
+vrValue :: a -> ValueOrRef a
+vrValue = VRValue Nothing
+
 -- When sending multiple messages to the same connection,
 -- only the first MsgReq for this connection should have non-empty ConnId.
 -- All subsequent MsgReq in traversable for this connection must be empty.
 -- This is done to optimize processing by grouping all messages to one connection together.
-type MsgReq = (ConnId, PQEncryption, MsgFlags, MsgBody)
+-- Also, repeated msg bodies should us MBRef constructor to reference previously used body.
+-- It is an error:
+-- - to use MBBody with the same Int
+-- - to use MBRef with Int that wasn't previously used in MBBody
+type MsgReq = (ConnId, PQEncryption, MsgFlags, ValueOrRef MsgBody)
 
 -- | Send multiple messages to different connections (SEND command)
 sendMessages :: AgentClient -> [MsgReq] -> AE [Either AgentErrorType (AgentMsgId, PQEncryption)]
@@ -685,9 +708,15 @@ allowConnectionAsync' c corrId connId confId ownConnInfo =
       enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo
     _ -> throwE $ CMD PROHIBITED "allowConnectionAsync"
 
+-- TODO
+-- Unlike `acceptContact` (synchronous version), `acceptContactAsync` uses `unacceptInvitation` in case of error,
+-- because we're not taking lock here. In practice it is less likely to fail because it doesn't involve network IO,
+-- and also it can't be triggered by user concurrently several times in a row. It could be improved similarly to
+-- `acceptContact` by creating a new map for invitation locks and taking lock here, and removing `unacceptInvitation`
+-- while marking invitation as accepted inside "lock level transaction" after successful `joinConnAsync`.
 acceptContactAsync' :: AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
 acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do
-  Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
+  Invitation {contactConnId, connReq} <- withStore c $ \db -> getInvitation db "acceptContactAsync'" invId
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
@@ -807,7 +836,7 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
 
 newConnToAccept :: AgentClient -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId
 newConnToAccept c connId enableNtfs invId pqSup = do
-  Invitation {connReq, contactConnId} <- withStore c (`getInvitation` invId)
+  Invitation {connReq, contactConnId} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) ->
       newConnToJoin c userId connId enableNtfs connReq pqSup
@@ -815,35 +844,50 @@ newConnToAccept c connId enableNtfs invId pqSup = do
 
 joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
 joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
-  srv <- case cReq of
-    CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
-      getNextServer c userId [qServer q]
-    _ -> getSMPServer c userId
+  srv <- getNextSMPServer c userId [qServer cReqQueue]
   joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
+  where
+    cReqQueue :: SMPQueueUri
+    cReqQueue = case cReq of
+      CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q
+      CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q
 
 startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448)
 startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
   lift (compatibleInvitationUri cReqUri) >>= \case
-    Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do
-      g <- asks random
+    Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
+      -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
+      -- e2ePubKey is always present, it's Maybe historically
       let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
+      (sq', e2eSndParams) <- case sq_ of
+        Just sq@SndQueue {e2ePubKey = Just _k} -> do
+          e2eSndParams <-
+            withStore' c (\db -> getSndRatchet db connId v) >>= \case
+              Right r -> pure $ snd r
+              Left e -> do
+                atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e))
+                createRatchet_ pqSupport e2eRcvParams
+          pure (sq, e2eSndParams)
+        _ -> do
+          q <- lift $ fst <$> newSndQueue userId "" qInfo
+          e2eSndParams <- createRatchet_ pqSupport e2eRcvParams
+          withStore c $ \db -> runExceptT $ do
+            sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
+            pure (sq', e2eSndParams)
+      let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
+      pure (cData, sq', e2eSndParams)
+    Nothing -> throwE $ AGENT A_VERSION
+  where
+    createRatchet_ pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do
+      g <- asks random
       (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport)
       (_, rcDHRs) <- atomically $ C.generateKeyPair g
       rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams
       maxSupported <- asks $ maxVersion . e2eEncryptVRange . config
       let rcVs = CR.RatchetVersions {current = v, maxSupported}
           rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
-      -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
-      -- e2ePubKey is always present, it's Maybe historically
-      q <- case sq_ of
-        Just sq@SndQueue {e2ePubKey = Just _k} -> pure (sq :: SndQueue) {dbQueueId = DBNewQueue}
-        _ -> lift $ fst <$> newSndQueue userId "" qInfo
-      let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
-      sq' <- withStore c $ \db -> runExceptT $ do
-        liftIO $ createRatchet db connId rc
-        maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
-      pure (cData, sq', e2eSndParams)
-    Nothing -> throwE $ AGENT A_VERSION
+      withStore' c $ \db -> createSndRatchet db connId rc e2eSndParams
+      pure e2eSndParams
 
 connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
 connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of
@@ -882,6 +926,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod
     case conn of
       NewConnection _ -> doJoin Nothing
       SndConnection _ sq -> doJoin $ Just sq
+      DuplexConnection _ (RcvQueue {status = New} :| _) (sq@SndQueue {status = New} :| _) -> doJoin $ Just sq
       _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
   where
     doJoin :: Maybe SndQueue -> AM SndQueueSecured
@@ -937,13 +982,12 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
 -- | Accept contact (ACPT command) in Reader monad
 acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
 acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
-  Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
+  Invitation {contactConnId, connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId
   withStore c (`getConn` contactConnId) >>= \case
     SomeConn _ (ContactConnection ConnData {userId} _) -> do
+      sqSecured <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode
       withStore' c $ \db -> acceptInvitation db invId ownConnInfo
-      joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
-        withStore' c (`unacceptInvitation` invId)
-        throwE err
+      pure sqSecured
     _ -> throwE $ CMD PROHIBITED "acceptContact"
 
 -- | Reject contact (RJCT command) in Reader monad
@@ -1100,7 +1144,7 @@ getNotificationConns' c nonce encNtfInfo =
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
-sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB_ c (Identity (Right (connId, pqEnc, msgFlags, msg))) (S.singleton connId)
+sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB_ c (Identity (Right (connId, pqEnc, msgFlags, vrValue msg))) (S.singleton connId)
 {-# INLINE sendMessage' #-}
 
 -- | Send multiple messages to different connections (SEND command) in Reader monad
@@ -1135,14 +1179,14 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
           else do
             conn <- first storeError <$> getConn db connId
             conn <$ atomically (writeTVar prev $ Just conn)
-    prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
+    prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
     prepareConn s (Left e) = (s, Left e)
-    prepareConn s (Right ((_, pqEnc, msgFlags, msg), SomeConn _ conn)) = case conn of
+    prepareConn s (Right ((_, pqEnc, msgFlags, msgOrRef), SomeConn _ conn)) = case conn of
       DuplexConnection cData _ sqs -> prepareMsg cData sqs
       SndConnection cData sq -> prepareMsg cData [sq]
       _ -> (s, Left $ CONN SIMPLEX)
       where
-        prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
+        prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage))
         prepareMsg cData@ConnData {connId, pqSupport} sqs
           | ratchetSyncSendProhibited cData = (s, Left $ CMD PROHIBITED "sendMessagesB: send prohibited")
           -- connection is only updated if PQ encryption was disabled, and now it has to be enabled.
@@ -1152,7 +1196,7 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
                in (S.insert connId s, mkReq cData')
           | otherwise = (s, mkReq cData)
           where
-            mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg)
+            mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG <$> msgOrRef)
 
 -- / async command processing v v v
 
@@ -1194,14 +1238,13 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
     processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
       AClientCommand cmd -> case cmd of
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
-          usedSrvs <- newTVarIO ([] :: [SMPServer])
-          tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
+          triedHosts <- newTVarIO S.empty
+          tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
             cReq <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
             notify $ INV (ACR cMode cReq)
         JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
-          let initUsed = [qServer q]
-          usedSrvs <- newTVarIO initUsed
-          tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
+          triedHosts <- newTVarIO S.empty
+          tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do
             sqSecured <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
             notify $ JOINED sqSecured
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
@@ -1337,10 +1380,10 @@ enqueueMessages c cData sqs msgFlags aMessage = do
 
 enqueueMessages' :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, CR.PQEncryption)
 enqueueMessages' c cData sqs msgFlags aMessage =
-  ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, aMessage)))
+  ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, vrValue aMessage)))
 {-# INLINE enqueueMessages' #-}
 
-enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
+enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
 enqueueMessagesB c reqs = do
   reqs' <- enqueueMessageB c reqs
   enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs'
@@ -1352,37 +1395,62 @@ isActiveSndQ SndQueue {status} = status == Secured || status == Active
 
 enqueueMessage :: AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption)
 enqueueMessage c cData sq msgFlags aMessage =
-  ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, aMessage)))
+  ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, vrValue aMessage)))
 {-# INLINE enqueueMessage #-}
 
 -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries
-enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId))))
+enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId))))
 enqueueMessageB c reqs = do
   cfg <- asks config
-  reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db cfg) reqs
+  (_, reqMids) <- unsafeWithStore c $ \db -> do
+    mapAccumLM (\ids r -> storeSentMsg db cfg ids r `E.catchAny` \e -> (ids,) <$> handleInternal e) IM.empty reqs
   forME reqMids $ \((cData, sq :| sqs, _, _, _), InternalId msgId, pqSecr) -> do
     submitPendingMsg c cData sq
     let sqs' = filter isActiveSndQ sqs
     pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId))
   where
-    storeSentMsg :: DB.Connection -> AgentConfig -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption))
-    storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
-      let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg
-      internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
-      let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
-          agentMsg = AgentMessage privHeader aMessage
-          agentMsgStr = smpEncode agentMsg
-          internalHash = C.sha256Hash agentMsgStr
-          currentE2EVersion = maxVersion e2eEncryptVRange
-      (encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncAgentMsgLength pqEnc_ currentE2EVersion
-      let agentVersion = maxVersion smpAgentVRange
-          msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage}
-          msgType = agentMessageType agentMsg
-          msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption = pqEnc, internalHash, prevMsgHash}
-      liftIO $ createSndMsg db connId msgData
-      liftIO $ createSndMsgDelivery db connId sq internalId
-      pure (req, internalId, pqEnc)
+    storeSentMsg :: DB.Connection -> AgentConfig -> IntMap (Int64, AMessage) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage) -> IO (IntMap (Int64, AMessage), Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage), InternalId, PQEncryption))
+    storeSentMsg db cfg aMessageIds = \case
+      Left e -> pure (aMessageIds, Left e)
+      Right req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, mbr) -> case mbr of
+        VRValue i_ aMessage -> case  i_ >>= (`IM.lookup` aMessageIds) of
+          Just _ -> pure (aMessageIds, Left $ INTERNAL "enqueueMessageB: storeSentMsg duplicate saved message body")
+          Nothing -> do
+            mbId <- createSndMsgBody db aMessage
+            let aMessageIds' = maybe id (`IM.insert` (mbId, aMessage)) i_ aMessageIds
+            (aMessageIds',) <$> storeSentMsg_ mbId aMessage
+        VRRef i -> (aMessageIds,) <$> case IM.lookup i aMessageIds of
+          Just (mbId, aMessage) -> storeSentMsg_ mbId aMessage
+          Nothing -> pure $ Left $ INTERNAL "enqueueMessageB: storeSentMsg missing saved message body id"
+        where
+          storeSentMsg_ sndMsgBodyId aMessage = fmap (first storeError) $ runExceptT $ do
+            let AgentConfig {e2eEncryptVRange} = cfg
+            internalTs <- liftIO getCurrentTime
+            (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
+            -- We need to do pre-flight encoding that is not stored in database
+            -- to calculate its hash and remember it on connection (createSndMsg -> updateSndMsgHash)
+            -- to enable next enqueue.
+            -- (As encoding is different per connection, we can't store shared body, so it's repeated on delivery)
+            let agentMsgStr = encodeAgentMsgStr aMessage internalSndId prevMsgHash
+                internalHash = C.sha256Hash agentMsgStr
+                currentE2EVersion = maxVersion e2eEncryptVRange
+            (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData e2eEncAgentMsgLength pqEnc_ currentE2EVersion
+            withExceptT (SEAgentError . cryptoError) $ CR.rcCheckCanPad paddedLen agentMsgStr
+            let msgType = aMessageType aMessage
+                -- msgBody is empty, because snd_messages record is linked to snd_message_bodies
+                msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody = "", pqEncryption = pqEnc, internalHash, prevMsgHash, sndMsgPrepData_ = Just SndMsgPrepData {encryptKey = mek, paddedLen, sndMsgBodyId}}
+            liftIO $ createSndMsg db connId msgData
+            liftIO $ createSndMsgDelivery db connId sq internalId
+            pure (req, internalId, pqEnc)
+    handleInternal :: E.SomeException -> IO (Either AgentErrorType b)
+    handleInternal = pure . Left . INTERNAL . show
+
+
+encodeAgentMsgStr :: AMessage -> InternalSndId -> PrevSndMsgHash -> ByteString
+encodeAgentMsgStr aMessage internalSndId prevMsgHash = do
+  let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
+      agentMsg = AgentMessage privHeader aMessage
+   in smpEncode agentMsg
 
 enqueueSavedMessage :: AgentClient -> ConnData -> AgentMsgId -> SndQueue -> AM' ()
 enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId)
@@ -1427,7 +1495,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI
     liftIO $ throwWhenNoDelivery c sq
     atomically $ beginAgentOperation c AOSndNetwork
     withWork c doWork (\db -> getPendingQueueMsg db connId sq) $
-      \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs}) -> do
+      \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs, internalSndId, prevMsgHash, pendingMsgPrepData_}) -> do
         atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg
         let mId = unId msgId
             ri' = maybe id updateRetryInterval2 msgRetryState ri
@@ -1437,7 +1505,15 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI
           resp <- tryError $ case msgType of
             AM_CONN_INFO -> sendConfirmation c sq msgBody
             AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody
-            _ -> sendAgentMessage c sq msgFlags msgBody
+            _ -> case pendingMsgPrepData_ of
+              Nothing -> sendAgentMessage c sq msgFlags msgBody
+              Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do
+                let agentMsgStr = encodeAgentMsgStr sndMsgBody internalSndId prevMsgHash
+                AgentConfig {smpAgentVRange} <- asks config
+                encAgentMessage <- liftError cryptoError $ CR.rcEncryptMsg encryptKey paddedLen agentMsgStr
+                let agentVersion = maxVersion smpAgentVRange
+                    msgBody' = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage}
+                sendAgentMessage c sq msgFlags msgBody'
           case resp of
             Left e -> do
               let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e
@@ -1649,8 +1725,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
   checkRQSwchStatus rq RSSwitchStarted
   clientVRange <- asks $ smpClientVRange . config
   -- try to get the server that is different from all queues, or at least from the primary rcv queue
-  srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
-  srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth
+  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
   (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False
   let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
   rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
@@ -1780,8 +1856,8 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
   -- ! if it was used to notify about the result, it might be necessary to differentiate
   -- ! between completed deletions of connections, and deletions delayed due to wait for delivery (see deleteConn)
   deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
-  rs' <- lift $ catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs))
-  forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN)
+  cIds_ <- lift $ L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs))
+  forM_ cIds_ $ \cIds -> notify ("", "", AEvt SAEConn $ DEL_CONNS cIds)
   pure (errs' <> delRs, rqs, connIds')
   where
     rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue]
@@ -1801,32 +1877,33 @@ deleteConnQueues c waitDelivery ntf rqs = do
   rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs)
   let connIds = M.keys $ M.filter isRight rs
   deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
-  rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds)
-  forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN)
+  cIds_ <- L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds)
+  forM_ cIds_ $ \cIds -> notify ("", "", AEvt SAEConn $ DEL_CONNS cIds)
   pure rs
   where
     deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> AM' [(RcvQueue, Either AgentErrorType ())]
     deleteQueueRecs rs = do
       maxErrs <- asks $ deleteErrorCount . config
-      (rs', notifyActions) <- unzip . rights <$> withStoreBatch' c (\db -> map (deleteQueueRec db maxErrs) rs)
-      mapM_ sequence_ notifyActions
-      pure rs'
+      rs' <- rights <$> withStoreBatch' c (\db -> map (deleteQueueRec db maxErrs) rs)
+      let delQ ((rq, _), err_) = (qConnId rq,qServer rq,queueId rq,) <$> err_
+          delQs_ = L.nonEmpty $ mapMaybe delQ rs'
+      forM_ delQs_ $ \delQs -> notify ("", "", AEvt SAEConn $ DEL_RCVQS delQs)
+      pure $ map fst rs'
       where
         deleteQueueRec ::
           DB.Connection ->
           Int ->
           (RcvQueue, Either AgentErrorType ()) ->
-          IO ((RcvQueue, Either AgentErrorType ()), Maybe (AM' ()))
+          IO ((RcvQueue, Either AgentErrorType ()), Maybe (Maybe AgentErrorType)) -- Nothing - no event, Just Nothing - no error
         deleteQueueRec db maxErrs (rq@RcvQueue {userId, server}, r) = case r of
-          Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just (notifyRQ rq Nothing))
+          Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just Nothing)
           Left e
             | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> incRcvDeleteErrors db rq $> ((rq, r), Nothing)
             | otherwise -> do
                 deleteConnRcvQueue db rq
                 -- attempts and successes are counted in deleteQueues function
                 atomically $ incSMPServerStat c userId server connDeleted
-                pure ((rq, Right ()), Just (notifyRQ rq (Just e)))
-    notifyRQ rq e_ = notify ("", qConnId rq, AEvt SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
+                pure ((rq, Right ()), Just (Just e))
     notify = when ntf . atomically . writeTBQueue (subQ c)
     connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
     connResults = M.map snd . foldl' addResult M.empty
@@ -1920,7 +1997,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
         -- possible improvement: add minimal time before repeat registration
         (Just tknId, Nothing)
           | savedDeviceToken == suppliedDeviceToken ->
-              when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
+              registerToken tkn $> NTRegistered
           | otherwise -> replaceToken tknId
         (Just tknId, Just (NTAVerify code))
           | savedDeviceToken == suppliedDeviceToken ->
@@ -1929,14 +2006,16 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
         (Just tknId, Just NTACheck)
           | savedDeviceToken == suppliedDeviceToken -> do
               ns <- asks ntfSupervisor
-              atomically $ nsUpdateToken ns tkn {ntfMode = suppliedNtfMode}
-              when (ntfTknStatus == NTActive) $ do
-                cron <- asks $ ntfCron . config
-                agentNtfEnableCron c tknId tkn cron
-                when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
-                when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
-              -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
-              pure ntfTknStatus
+              let tkn' = tkn {ntfMode = suppliedNtfMode}
+              atomically $ nsUpdateToken ns tkn'
+              agentNtfCheckToken c tknId tkn' >>= \case
+                NTActive -> do
+                  cron <- asks $ ntfCron . config
+                  agentNtfEnableCron c tknId tkn cron
+                  when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
+                  when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
+                  t tkn' (NTActive, Just NTACheck) $ pure ()
+                status -> t tkn' (status, Nothing) $ pure ()
           | otherwise -> replaceToken tknId
         -- deprecated
         (Just _tknId, Just NTADelete) -> deleteToken c tkn $> NTExpired
@@ -2003,9 +2082,15 @@ verifyNtfToken' c deviceToken nonce code =
 checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus
 checkNtfToken' c deviceToken =
   withStore' c getSavedNtfToken >>= \case
-    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId} -> do
+    Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do
       when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token"
-      agentNtfCheckToken c tknId tkn
+      status <- agentNtfCheckToken c tknId tkn
+      let action = case status of
+            NTInvalid _ -> Nothing
+            NTExpired -> Nothing
+            _ -> ntfTknAction
+      withStore' c $ \db -> updateNtfToken db tkn status action
+      pure status
     _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token"
 
 deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
@@ -2146,7 +2231,7 @@ execAgentStoreSQL :: AgentClient -> Text -> AE [Text]
 execAgentStoreSQL c sql = withAgentEnv c $ withStore' c (`execSQL` sql)
 
 getAgentMigrations :: AgentClient -> AE [UpMigration]
-getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c (Migrations.getCurrent . DB.conn)
+getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c getCurrentMigrations
 
 debugAgentLocks :: AgentClient -> IO AgentLocks
 debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
@@ -2158,9 +2243,13 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
     getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
 
 getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
-getSMPServer c userId = withUserServers c userId pickServer
+getSMPServer c userId = getNextSMPServer c userId []
 {-# INLINE getSMPServer #-}
 
+getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
+getNextSMPServer c userId = getNextServer c userId storageSrvs
+{-# INLINE getNextSMPServer #-}
+
 subscriber :: AgentClient -> AM' ()
 subscriber c@AgentClient {msgQ} = forever $ do
   t <- atomically $ readTBQueue msgQ
@@ -2915,7 +3004,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq
     (encConnInfo, pqEncryption) <- agentRatchetEncrypt db cData agentMsgStr e2eEncConnInfoLength (Just pqEnc) currentE2EVersion
     let msgBody = smpEncode $ AgentConfirmation {agentVersion = v, e2eEncryption_, encConnInfo}
         msgType = agentMessageType agentMsg
-        msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
+        msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, sndMsgPrepData_ = Nothing}
     liftIO $ createSndMsg db connId msgData
     liftIO $ createSndMsgDelivery db connId sq internalId
 
@@ -2941,19 +3030,25 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
       let msgBody = smpEncode $ AgentRatchetKey {agentVersion, e2eEncryption, info = agentMsgStr}
           msgType = agentMessageType agentMsg
           -- this message is e2e encrypted with queue key, not with double ratchet
-          msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
+          msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, sndMsgPrepData_ = Nothing}
       liftIO $ createSndMsg db connId msgData
       liftIO $ createSndMsgDelivery db connId sq internalId
       pure internalId
 
 -- encoded AgentMessage -> encoded EncAgentMessage
 agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (ByteString, PQEncryption)
-agentRatchetEncrypt db ConnData {connId, connAgentVersion = v, pqSupport} msg getPaddedLen pqEnc_ currentE2EVersion = do
+agentRatchetEncrypt db cData msg getPaddedLen pqEnc_ currentE2EVersion = do
+  (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData getPaddedLen pqEnc_ currentE2EVersion
+  encMsg <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptMsg mek paddedLen msg
+  pure (encMsg, pqEnc)
+
+agentRatchetEncryptHeader :: DB.Connection -> ConnData -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (CR.MsgEncryptKeyX448, Int, PQEncryption)
+agentRatchetEncryptHeader db ConnData {connId, connAgentVersion = v, pqSupport} getPaddedLen pqEnc_ currentE2EVersion = do
   rc <- ExceptT $ getRatchet db connId
   let paddedLen = getPaddedLen v pqSupport
-  (encMsg, rc') <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg pqEnc_ currentE2EVersion
+  (mek, rc') <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptHeader rc pqEnc_ currentE2EVersion
   liftIO $ updateRatchet db connId rc' CR.SMDNoChange
-  pure (encMsg, CR.rcSndKEM rc')
+  pure (mek, paddedLen, CR.rcSndKEM rc')
 
 -- encoded EncAgentMessage -> encoded AgentMessage
 agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption)

src/Simplex/Messaging/Agent/Client.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
@@ -30,6 +31,7 @@ module Simplex.Messaging.Agent.Client
     withConnLocks,
     withInvLock,
     withLockMap,
+    getMapLock,
     ipAddressProtected,
     closeAgentClient,
     closeProtocolServerClients,
@@ -144,11 +146,11 @@ module Simplex.Messaging.Agent.Client
     withStore',
     withStoreBatch,
     withStoreBatch',
+    unsafeWithStore,
     storeError,
     userServers,
     pickServer,
     getNextServer,
-    withUserServers,
     withNextSrv,
     incSMPServerStat,
     incSMPServerStat',
@@ -192,12 +194,12 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (deleteFirstsBy, find, foldl', partition, (\\))
+import Data.List (find, foldl', partition)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -205,7 +207,6 @@ import Data.Text.Encoding
 import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Word (Word16)
-import qualified Database.SQLite.Simple as SQL
 import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
@@ -221,8 +222,8 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import Simplex.Messaging.Client
@@ -263,7 +264,6 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
     XFTPServer,
     XFTPServerWithAuth,
-    sameSrvAddr',
     pattern NoEntity,
   )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -283,6 +283,9 @@ import UnliftIO.Concurrent (forkIO, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
+#if !defined(dbPostgres)
+import qualified Database.SQLite.Simple as SQL
+#endif
 
 type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
 
@@ -500,7 +503,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
   getMsgLocks <- TM.emptyIO
   connLocks <- TM.emptyIO
   invLocks <- TM.emptyIO
-  deleteLock <- atomically createLock
+  deleteLock <- createLockIO
   smpSubWorkers <- TM.emptyIO
   smpServersStats <- TM.emptyIO
   xftpServersStats <- TM.emptyIO
@@ -556,7 +559,7 @@ slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPe
     slow :: Integral a => a -> a
     slow t = (t * 3) `div` 2
 
-agentClientStore :: AgentClient -> SQLiteStore
+agentClientStore :: AgentClient -> DBStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 {-# INLINE agentClientStore #-}
 
@@ -618,7 +621,7 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
 getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
 getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
-  proxySrv <- maybe (getNextServer c userId [destSrv]) pure proxySrv_
+  proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
   ts <- liftIO getCurrentTime
   atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
     either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v
@@ -1073,7 +1076,7 @@ sendOrProxySMPCommand ::
   (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
   (SMPClient -> ExceptT SMPClientError IO ()) ->
   AM (Maybe SMPServer)
-sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
+sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
   tSess <- mkTransportSession c userId destSrv connId
   ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
   where
@@ -1092,7 +1095,7 @@ sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy se
         SPFAllow -> True
         SPFAllowProtected -> ipAddressProtected cfg destSrv
         SPFProhibit -> False
-    unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c)
+    unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
     sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
     sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
       r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
@@ -1387,6 +1390,7 @@ temporaryAgentError = \case
   PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> tempBrokerError e
   PROXY _ _ (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> True
   INACTIVE -> True
+  CRITICAL True _ -> True -- critical errors that do not show restart button are likely to be permanent
   _ -> False
   where
     tempBrokerError = \case
@@ -1649,7 +1653,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
 sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
   withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
-    ackSMPMessage smp rcvPrivateKey rcvId msgId      
+    ackSMPMessage smp rcvPrivateKey rcvId msgId
 
 hasGetLock :: AgentClient -> RcvQueue -> IO Bool
 hasGetLock c RcvQueue {server, rcvId} =
@@ -1989,6 +1993,13 @@ withStore c action = do
   withExceptT storeError . ExceptT . liftIO . agentOperationBracket c AODatabase (\_ -> pure ()) $
     withTransaction st action `E.catches` handleDBErrors
   where
+#if defined(dbPostgres)
+    -- TODO [postgres] postgres specific error handling
+    handleDBErrors :: [E.Handler IO (Either StoreError a)]
+    handleDBErrors =
+      [ E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e
+      ]
+#else
     handleDBErrors :: [E.Handler IO (Either StoreError a)]
     handleDBErrors =
       [ E.Handler $ \(e :: SQL.SQLError) ->
@@ -1997,6 +2008,12 @@ withStore c action = do
            in pure . Left . (if busy then SEDatabaseBusy else SEInternal) $ bshow se,
         E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e
       ]
+#endif
+
+unsafeWithStore :: AgentClient -> (DB.Connection -> IO a) -> AM' a
+unsafeWithStore c action = do
+  st <- asks store
+  liftIO $ agentOperationBracket c AODatabase (\_ -> pure ()) $ withTransaction st action
 
 withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a))
 withStoreBatch c actions = do
@@ -2020,7 +2037,7 @@ storeError = \case
   SEConnDuplicate -> CONN DUPLICATE
   SEBadConnType CRcv -> CONN SIMPLEX
   SEBadConnType CSnd -> CONN SIMPLEX
-  SEInvitationNotFound -> CMD PROHIBITED "SEInvitationNotFound"
+  SEInvitationNotFound cxt invId -> CMD PROHIBITED $ "SEInvitationNotFound " <> cxt <> ", invitationId = " <> show invId
   -- this error is never reported as store error,
   -- it is used to wrap agent operations when "transaction-like" store access is needed
   -- NOTE: network IO should NOT be used inside AgentStoreMonad
@@ -2034,33 +2051,82 @@ userServers c = case protocolTypeI @p of
   SPXFTP -> xftpServers c
 {-# INLINE userServers #-}
 
-pickServer :: forall p. NonEmpty (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
+pickServer :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
 pickServer = \case
-  srv :| [] -> pure srv
+  (_, srv) :| [] -> pure srv
   servers -> do
     gen <- asks randomServer
-    atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
+    atomically $ snd . (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
 
-getNextServer :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> [ProtocolServer p] -> AM (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
+getNextServer ::
+  (ProtocolTypeI p, UserProtocol p) =>
+  AgentClient ->
+  UserId ->
+  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
+  [ProtocolServer p] ->
+  AM (ProtoServerWithAuth p)
+getNextServer c userId srvsSel usedSrvs = do
+  srvs <- getUserServers_ c userId srvsSel
+  snd <$> getNextServer_ srvs (usedOperatorsHosts srvs usedSrvs)
 
-withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a
-withUserServers c userId action =
+usedOperatorsHosts :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> [ProtocolServer p] -> (Set (Maybe OperatorId), Set TransportHost)
+usedOperatorsHosts srvs usedSrvs = (usedOperators, usedHosts)
+  where
+    usedHosts = S.unions $ map serverHosts usedSrvs
+    usedOperators = S.fromList $ mapMaybe usedOp $ L.toList srvs
+    usedOp (op, srv) = if hasUsedHost srv then Just op else Nothing
+    hasUsedHost (ProtoServerWithAuth srv _) = any (`S.member` usedHosts) $ serverHosts srv
+
+getNextServer_ ::
+  (ProtocolTypeI p, UserProtocol p) =>
+  NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) ->
+  (Set (Maybe OperatorId), Set TransportHost) ->
+  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p), ProtoServerWithAuth p)
+getNextServer_ servers (usedOperators, usedHosts) = do
+  -- choose from servers of unused operators, when possible
+  let otherOpsSrvs = filterOrAll ((`S.notMember` usedOperators) . fst) servers
+      -- choose from servers with unused hosts when possible
+      unusedSrvs = filterOrAll (isUnusedServer usedHosts) otherOpsSrvs
+  (otherOpsSrvs,) <$> pickServer unusedSrvs
+  where
+    filterOrAll p srvs = fromMaybe srvs $ L.nonEmpty $ L.filter p srvs
+
+isUnusedServer :: Set TransportHost -> (Maybe OperatorId, ProtoServerWithAuth p) -> Bool
+isUnusedServer usedHosts (_, ProtoServerWithAuth ProtocolServer {host} _) = all (`S.notMember` usedHosts) host
+
+getUserServers_ ::
+  (ProtocolTypeI p, UserProtocol p) =>
+  AgentClient ->
+  UserId ->
+  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
+  AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p))
+getUserServers_ c userId srvsSel =
   liftIO (TM.lookupIO userId $ userServers c) >>= \case
-    Just srvs -> action $ enabledSrvs srvs
+    Just srvs -> pure $ srvsSel srvs
     _ -> throwE $ INTERNAL "unknown userId - no user servers"
 
-withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a
-withNextSrv c userId usedSrvs initUsed action = do
-  used <- readTVarIO usedSrvs
-  srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
-  srvs_ <- liftIO $ TM.lookupIO userId $ userServers c
-  let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
-      used' = if null unused then initUsed else srv : used
-  atomically $ writeTVar usedSrvs $! used'
+-- This function checks used servers and operators every time to allow
+-- changing configuration while retry look is executing.
+-- This function is not thread safe.
+withNextSrv ::
+  (ProtocolTypeI p, UserProtocol p) =>
+  AgentClient ->
+  UserId ->
+  (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
+  TVar (Set TransportHost) ->
+  [ProtocolServer p] ->
+  (ProtoServerWithAuth p -> AM a) ->
+  AM a
+withNextSrv c userId srvsSel triedHosts usedSrvs action = do
+  srvs <- getUserServers_ c userId srvsSel
+  let (usedOperators, usedHosts) = usedOperatorsHosts srvs usedSrvs
+  tried <- readTVarIO triedHosts
+  let triedOrUsed = S.union tried usedHosts
+  (otherOpsSrvs, srvAuth@(ProtoServerWithAuth srv _)) <- getNextServer_ srvs (usedOperators, triedOrUsed)
+  let newHosts = serverHosts srv
+      unusedSrvs = L.filter (isUnusedServer $ S.union triedOrUsed newHosts) otherOpsSrvs
+      !tried' = if null unusedSrvs then S.empty else S.union tried newHosts
+  atomically $ writeTVar triedHosts tried'
   action srvAuth
 
 incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()

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

@@ -17,11 +17,14 @@ module Simplex.Messaging.Agent.Env.SQLite
     AgentConfig (..),
     InitialAgentServers (..),
     ServerCfg (..),
+    ServerRoles (..),
+    OperatorId,
     UserServers (..),
     NetworkConfig (..),
     presetServerCfg,
-    enabledServerCfg,
+    allRoles,
     mkUserServers,
+    serverHosts,
     defaultAgentConfig,
     defaultReconnectInterval,
     tryAgentError,
@@ -42,18 +45,20 @@ module Simplex.Messaging.Agent.Env.SQLite
 where
 
 import Control.Concurrent (ThreadId)
+import Control.Exception (BlockedIndefinitelyOnSTM (..), SomeException, fromException)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as JQ
-import Data.ByteArray (ScrubbedBytes)
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Word (Word16)
@@ -62,8 +67,10 @@ import Numeric.Natural
 import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
+import Simplex.Messaging.Agent.Store (createStore)
+import Simplex.Messaging.Agent.Store.Common (DBStore)
+import Simplex.Messaging.Agent.Store.Interface (DBOpts)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -71,14 +78,14 @@ import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Notifications.Transport (NTFVersion)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (defaultJSON)
-import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion)
+import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
-import UnliftIO (SomeException)
 import UnliftIO.STM
 
 type AM' a = ReaderT Env IO a
@@ -94,29 +101,42 @@ data InitialAgentServers = InitialAgentServers
 
 data ServerCfg p = ServerCfg
   { server :: ProtoServerWithAuth p,
-    preset :: Bool,
-    tested :: Maybe Bool,
-    enabled :: Bool
+    operator :: Maybe OperatorId,
+    enabled :: Bool,
+    roles :: ServerRoles
   }
   deriving (Show)
 
-enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p
-enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
+data ServerRoles = ServerRoles
+  { storage :: Bool,
+    proxy :: Bool
+  }
+  deriving (Show)
 
-presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p
-presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled}
+allRoles :: ServerRoles
+allRoles = ServerRoles True True
+
+presetServerCfg :: Bool -> ServerRoles -> Maybe OperatorId -> ProtoServerWithAuth p -> ServerCfg p
+presetServerCfg enabled roles operator server =
+  ServerCfg {server, operator, enabled, roles}
 
 data UserServers p = UserServers
-  { enabledSrvs :: NonEmpty (ProtoServerWithAuth p),
-    knownSrvs :: NonEmpty (ProtocolServer p)
+  { storageSrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
+    proxySrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
+    knownHosts :: Set TransportHost
   }
 
+type OperatorId = Int64
+
 -- This function sets all servers as enabled in case all passed servers are disabled.
 mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
-mkUserServers srvs = UserServers {enabledSrvs, knownSrvs}
+mkUserServers srvs = UserServers {storageSrvs = filterSrvs storage, proxySrvs = filterSrvs proxy, knownHosts}
   where
-    enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs
-    knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs
+    filterSrvs role = L.map (\ServerCfg {operator, server} -> (operator, server)) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled, roles} -> enabled && role roles) srvs
+    knownHosts = S.unions $ L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> serverHosts srv) srvs
+
+serverHosts :: ProtocolServer p -> Set TransportHost
+serverHosts ProtocolServer {host} = S.fromList $ L.toList host
 
 data AgentConfig = AgentConfig
   { tcpPort :: Maybe ServiceName,
@@ -235,7 +255,7 @@ defaultAgentConfig =
 
 data Env = Env
   { config :: AgentConfig,
-    store :: SQLiteStore,
+    store :: DBStore,
     random :: TVar ChaChaDRG,
     randomServer :: TVar StdGen,
     ntfSupervisor :: NtfSupervisor,
@@ -243,7 +263,7 @@ data Env = Env
     multicastSubscribers :: TMVar Int
   }
 
-newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
+newSMPAgentEnv :: AgentConfig -> DBStore -> IO Env
 newSMPAgentEnv config store = do
   random <- C.newRandom
   randomServer <- newTVarIO =<< liftIO newStdGen
@@ -252,8 +272,8 @@ newSMPAgentEnv config store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
-createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey keepKey Migrations.app
+createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore = createStore
 
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
@@ -313,7 +333,9 @@ agentFinally = allFinally mkInternal
 {-# INLINE agentFinally #-}
 
 mkInternal :: SomeException -> AgentErrorType
-mkInternal = INTERNAL . show
+mkInternal e = case fromException e of
+  Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
+  _ -> INTERNAL $ show e
 {-# INLINE mkInternal #-}
 
 data Worker = Worker
@@ -335,6 +357,8 @@ updateRestartCount t (RestartCount minute count) = do
 
 $(pure [])
 
+$(JQ.deriveJSON defaultJSON ''ServerRoles)
+
 instance ProtocolTypeI p => ToJSON (ServerCfg p) where
   toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
   toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,10 +1,12 @@
 module Simplex.Messaging.Agent.Lock
   ( Lock,
     createLock,
+    createLockIO,
     withLock,
     withLock',
     withGetLock,
     withGetLocks,
+    getPutLock,
   )
 where
 
@@ -24,6 +26,10 @@ createLock :: STM Lock
 createLock = newEmptyTMVar
 {-# INLINE createLock #-}
 
+createLockIO :: IO Lock
+createLockIO = newEmptyTMVarIO
+{-# INLINE createLockIO #-}
+
 withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
 withLock lock name = ExceptT . withLock' lock name . runExceptT
 {-# INLINE withLock #-}

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -43,8 +43,8 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import Simplex.Messaging.Agent.Store.AgentStore
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Types

src/Simplex/Messaging/Agent/Protocol.hs

@@ -108,6 +108,7 @@ module Simplex.Messaging.Agent.Protocol
     ConnReqUriData (..),
     CRClientData,
     ServiceScheme,
+    sameConnReqContact,
     simplexChat,
     connReqUriP',
     AgentErrorType (..),
@@ -139,6 +140,7 @@ module Simplex.Messaging.Agent.Protocol
     serializeQueueStatus,
     queueStatusT,
     agentMessageType,
+    aMessageType,
     extraSMPServerHosts,
     updateSMPServerHosts,
   )
@@ -166,8 +168,7 @@ import Data.Time.Clock.System (SystemTime)
 import Data.Type.Equality
 import Data.Typeable ()
 import Data.Word (Word16, Word32)
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.ToField
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Transport (XFTPErrorType)
@@ -358,8 +359,8 @@ data AEvent (e :: AEntity) where
   MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn
   RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn
   QCONT :: AEvent AEConn
-  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn
-  DEL_CONN :: AEvent AEConn
+  DEL_RCVQS :: NonEmpty (ConnId, SMPServer, SMP.RecipientId, Maybe AgentErrorType) -> AEvent AEConn
+  DEL_CONNS :: NonEmpty ConnId -> AEvent AEConn
   DEL_USER :: Int64 -> AEvent AENone
   STAT :: ConnectionStats -> AEvent AEConn
   OK :: AEvent AEConn
@@ -429,8 +430,8 @@ data AEventTag (e :: AEntity) where
   MSGNTF_ :: AEventTag AEConn
   RCVD_ :: AEventTag AEConn
   QCONT_ :: AEventTag AEConn
-  DEL_RCVQ_ :: AEventTag AEConn
-  DEL_CONN_ :: AEventTag AEConn
+  DEL_RCVQS_ :: AEventTag AEConn
+  DEL_CONNS_ :: AEventTag AEConn
   DEL_USER_ :: AEventTag AENone
   STAT_ :: AEventTag AEConn
   OK_ :: AEventTag AEConn
@@ -484,8 +485,8 @@ aEventTag = \case
   MSGNTF {} -> MSGNTF_
   RCVD {} -> RCVD_
   QCONT -> QCONT_
-  DEL_RCVQ {} -> DEL_RCVQ_
-  DEL_CONN -> DEL_CONN_
+  DEL_RCVQS _ -> DEL_RCVQS_
+  DEL_CONNS _ -> DEL_CONNS_
   DEL_USER _ -> DEL_USER_
   STAT _ -> STAT_
   OK -> OK_
@@ -855,20 +856,7 @@ agentMessageType = \case
   AgentConnInfo _ -> AM_CONN_INFO
   AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
   AgentRatchetInfo _ -> AM_RATCHET_INFO
-  AgentMessage _ aMsg -> case aMsg of
-    -- HELLO is used both in v1 and in v2, but differently.
-    -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
-    --   until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
-    -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
-    HELLO -> AM_HELLO_
-    A_MSG _ -> AM_A_MSG_
-    A_RCVD {} -> AM_A_RCVD_
-    A_QCONT _ -> AM_QCONT_
-    QADD _ -> AM_QADD_
-    QKEY _ -> AM_QKEY_
-    QUSE _ -> AM_QUSE_
-    QTEST _ -> AM_QTEST_
-    EREADY _ -> AM_EREADY_
+  AgentMessage _ aMsg -> aMessageType aMsg
 
 data APrivHeader = APrivHeader
   { -- | sequential ID assigned by the sending agent
@@ -946,6 +934,22 @@ data AMessage
     EREADY AgentMsgId
   deriving (Show)
 
+aMessageType :: AMessage -> AgentMessageType
+aMessageType = \case
+  -- HELLO is used both in v1 and in v2, but differently.
+  -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
+  --   until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
+  -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
+  HELLO -> AM_HELLO_
+  A_MSG _ -> AM_A_MSG_
+  A_RCVD {} -> AM_A_RCVD_
+  A_QCONT _ -> AM_QCONT_
+  QADD _ -> AM_QADD_
+  QKEY _ -> AM_QKEY_
+  QUSE _ -> AM_QUSE_
+  QTEST _ -> AM_QTEST_
+  EREADY _ -> AM_EREADY_
+
 -- | this type is used to send as part of the protocol between different clients
 -- TODO possibly, rename fields and types referring to external and internal IDs to make them different
 data AMessageReceipt = AMessageReceipt
@@ -1010,6 +1014,10 @@ instance Encoding AMessage where
         QTEST_ -> QTEST <$> smpP
         EREADY_ -> EREADY <$> smpP
 
+instance ToField AMessage where toField = toField . Binary . smpEncode
+
+instance FromField AMessage where fromField = blobFieldDecoder smpDecode
+
 instance Encoding AMessageReceipt where
   smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} =
     smpEncode (agentMsgId, msgHash, Large rcptInfo)
@@ -1263,6 +1271,12 @@ instance Eq AConnectionRequestUri where
 
 deriving instance Show AConnectionRequestUri
 
+sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
+sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
+  L.length qs == L.length qs' && all same (L.zip qs qs')
+  where
+    same (q, q') = sameQAddress (qAddress q) (qAddress q')
+
 data ConnReqUriData = ConnReqUriData
   { crScheme :: ServiceScheme,
     crAgentVRange :: VersionRangeSMPA,

src/Simplex/Messaging/Agent/Stats.hs

@@ -10,11 +10,10 @@ import qualified Data.Aeson.TH as J
 import Data.Int (Int64)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol (UserId)
-import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
-import Simplex.Messaging.Protocol (SMPServer, XFTPServer, NtfServer)
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
+import Simplex.Messaging.Parsers (defaultJSON)
+import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer)
 import Simplex.Messaging.Util (decodeJSON, encodeJSON)
 import UnliftIO.STM
 

src/Simplex/Messaging/Agent/Store.hs

@@ -29,8 +29,12 @@ import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State)
+import Simplex.Messaging.Agent.Store.Common
+import Simplex.Messaging.Agent.Store.Interface (createDBStore)
+import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448)
+import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( MsgBody,
@@ -42,13 +46,16 @@ import Simplex.Messaging.Protocol
     RcvDhSecret,
     RcvNtfDhSecret,
     RcvPrivateAuthKey,
+    SenderCanSecure,
     SndPrivateAuthKey,
     SndPublicAuthKey,
-    SenderCanSecure,
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 
+createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore dbOpts = createDBStore dbOpts appMigrations
+
 -- * Queue types
 
 data QueueStored = QSStored | QSNew
@@ -536,9 +543,17 @@ data SndMsgData = SndMsgData
     msgBody :: MsgBody,
     pqEncryption :: PQEncryption,
     internalHash :: MsgHash,
-    prevMsgHash :: MsgHash
+    prevMsgHash :: MsgHash,
+    sndMsgPrepData_ :: Maybe SndMsgPrepData
   }
 
+data SndMsgPrepData = SndMsgPrepData
+  { encryptKey :: MsgEncryptKeyX448,
+    paddedLen :: Int,
+    sndMsgBodyId :: Int64
+  }
+  deriving (Show)
+
 data SndMsg = SndMsg
   { internalId :: InternalId,
     internalSndId :: InternalSndId,
@@ -554,7 +569,17 @@ data PendingMsgData = PendingMsgData
     msgBody :: MsgBody,
     pqEncryption :: PQEncryption,
     msgRetryState :: Maybe RI2State,
-    internalTs :: InternalTs
+    internalTs :: InternalTs,
+    internalSndId :: InternalSndId,
+    prevMsgHash :: PrevSndMsgHash,
+    pendingMsgPrepData_ :: Maybe PendingMsgPrepData
+  }
+  deriving (Show)
+
+data PendingMsgPrepData = PendingMsgPrepData
+  { encryptKey :: MsgEncryptKeyX448,
+    paddedLen :: Int,
+    sndMsgBody :: AMessage
   }
   deriving (Show)
 
@@ -623,7 +648,7 @@ data StoreError
   | -- | Confirmation not found.
     SEConfirmationNotFound
   | -- | Invitation not found
-    SEInvitationNotFound
+    SEInvitationNotFound String InvitationId
   | -- | Message not found
     SEMsgNotFound
   | -- | Command not found

src/Simplex/Messaging/Agent/Store/Common.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+
+module Simplex.Messaging.Agent.Store.Common
+#if defined(dbPostgres)
+  ( module Simplex.Messaging.Agent.Store.Postgres.Common,
+  )
+  where
+import Simplex.Messaging.Agent.Store.Postgres.Common
+#else
+  ( module Simplex.Messaging.Agent.Store.SQLite.Common,
+  )
+  where
+import Simplex.Messaging.Agent.Store.SQLite.Common
+#endif

src/Simplex/Messaging/Agent/Store/DB.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE CPP #-}
+
+module Simplex.Messaging.Agent.Store.DB
+#if defined(dbPostgres)
+  ( module Simplex.Messaging.Agent.Store.Postgres.DB,
+    FromField (..),
+    ToField (..),
+  )
+  where
+import Simplex.Messaging.Agent.Store.Postgres.DB
+#else
+  ( module Simplex.Messaging.Agent.Store.SQLite.DB,
+    FromField (..),
+    ToField (..),
+  )
+  where
+import Simplex.Messaging.Agent.Store.SQLite.DB
+#endif

src/Simplex/Messaging/Agent/Store/Interface.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+
+module Simplex.Messaging.Agent.Store.Interface
+#if defined(dbPostgres)
+  ( module Simplex.Messaging.Agent.Store.Postgres,
+  )
+  where
+import Simplex.Messaging.Agent.Store.Postgres
+#else
+  ( module Simplex.Messaging.Agent.Store.SQLite,
+  )
+  where
+import Simplex.Messaging.Agent.Store.SQLite
+#endif

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

@@ -0,0 +1,78 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Simplex.Messaging.Agent.Store.Migrations
+  ( Migration (..),
+    MigrationsToRun (..),
+    DownMigration (..),
+    DBMigrate (..),
+    sharedMigrateSchema,
+    -- for tests
+    migrationsToRun,
+    toDownMigration,
+  )
+where
+
+import Control.Monad
+import Data.Char (toLower)
+import Data.Functor (($>))
+import Data.Maybe (isNothing, mapMaybe)
+import Simplex.Messaging.Agent.Store.Shared
+import System.Exit (exitFailure)
+import System.IO (hFlush, stdout)
+
+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 == name d = migrationsToRun as ds
+  | otherwise = Left $ MTREDifferent (name a) (name d)
+
+data DBMigrate = DBMigrate
+  { initialize :: IO (),
+    getCurrent :: IO [Migration],
+    run :: MigrationsToRun -> IO (),
+    backup :: IO ()
+  }
+
+sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
+sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
+  initialize dbm
+  currentMs <- getCurrent dbm
+  case migrationsToRun migrations currentMs of
+    Left e -> do
+      when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
+      pure . Left $ MigrationError e
+    Right MTRNone -> pure $ Right ()
+    Right ms@(MTRUp ums)
+      | dbNew' -> run dbm ms $> Right ()
+      | otherwise -> case confirmMigrations of
+          MCYesUp -> runWithBackup ms
+          MCYesUpDown -> runWithBackup ms
+          MCConsole -> confirm err >> runWithBackup ms
+          MCError -> pure $ Left err
+      where
+        err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
+    Right ms@(MTRDown dms) -> case confirmMigrations of
+      MCYesUpDown -> runWithBackup ms
+      MCConsole -> confirm err >> runWithBackup ms
+      MCYesUp -> pure $ Left err
+      MCError -> pure $ Left err
+      where
+        err = MEDowngrade $ map downName dms
+  where
+    runWithBackup ms = backup dbm >> run dbm ms $> Right ()
+    confirm err = confirmOrExit $ migrationErrorDescription err
+
+confirmOrExit :: String -> IO ()
+confirmOrExit s = do
+  putStrLn s
+  putStr "Continue (y/N): "
+  hFlush stdout
+  ok <- getLine
+  when (map toLower ok /= "y") exitFailure

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

@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+
+module Simplex.Messaging.Agent.Store.Migrations.App
+#if defined(dbPostgres)
+  ( module Simplex.Messaging.Agent.Store.Postgres.Migrations.App,
+  )
+  where
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.App
+#else
+  ( module Simplex.Messaging.Agent.Store.SQLite.Migrations.App,
+  )
+  where
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.App
+#endif

src/Simplex/Messaging/Agent/Store/Postgres.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Store.Postgres
+  ( DBOpts (..),
+    Migrations.getCurrentMigrations,
+    checkSchemaExists,
+    createDBStore,
+    closeDBStore,
+    reopenDBStore,
+    execSQL,
+  )
+where
+
+import Control.Concurrent.STM
+import Control.Exception (finally, onException, throwIO, uninterruptibleMask_)
+import Control.Logger.Simple (logError)
+import Control.Monad
+import Data.ByteString (ByteString)
+import Data.Functor (($>))
+import Data.Text (Text)
+import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple.Types (Query (..))
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema)
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
+import System.Exit (exitFailure)
+import UnliftIO.MVar
+
+-- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
+-- If passed schema does not exist in connectInfo database, it will be created.
+-- Applies necessary migrations to schema.
+createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createDBStore opts migrations confirmMigrations = do
+  st <- connectPostgresStore opts
+  r <- migrateSchema st `onException` closeDBStore st
+  case r of
+    Right () -> pure $ Right st
+    Left e -> closeDBStore st $> Left e
+  where
+    migrateSchema st =
+      let initialize = Migrations.initialize st
+          getCurrent = withTransaction st Migrations.getCurrentMigrations
+          dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
+       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+
+connectPostgresStore :: DBOpts -> IO DBStore
+connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do
+  dbSem <- newMVar ()
+  dbPool <- newTBQueueIO poolSize
+  dbClosed <- newTVarIO True
+  let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPool, dbSem, dbNew = False, dbClosed}
+  dbNew <- connectPool st createSchema
+  pure st {dbNew}
+
+-- uninterruptibleMask_ here and below is used here so that it is not interrupted half-way,
+-- it relies on the assumption that when dbClosed = True, the queue is empty,
+-- and when it is False, the queue is full (or will have connections returned to it by the threads that use them).
+connectPool :: DBStore -> Bool -> IO Bool
+connectPool DBStore {dbConnstr, dbSchema, dbPoolSize, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do
+  (conn, dbNew) <- connectDB dbConnstr dbSchema createSchema -- TODO [postgres] analogue for dbBusyLoop?
+  conns <- replicateM (dbPoolSize - 1) $ fst <$> connectDB dbConnstr dbSchema False
+  mapM_ (atomically . writeTBQueue dbPool) (conn : conns)
+  atomically $ writeTVar dbClosed False
+  pure dbNew
+
+connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool)
+connectDB connstr schema createSchema = do
+  db <- PSQL.connectPostgreSQL connstr
+  dbNew <- prepare db `onException` PSQL.close db
+  pure (db, dbNew)
+  where
+    prepare db = do
+      void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
+      dbNew <- not <$> doesSchemaExist db schema
+      when dbNew $
+        if createSchema
+          then void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
+          else do
+            logError $ "connectPostgresStore, schema " <> safeDecodeUtf8 schema <> " does not exist, exiting."
+            PSQL.close db
+            exitFailure
+      void $ PSQL.execute_ db $ Query $ "SET search_path TO " <> schema
+      pure dbNew
+
+checkSchemaExists :: ByteString -> ByteString -> IO Bool
+checkSchemaExists connstr schema = do
+  db <- PSQL.connectPostgreSQL connstr
+  doesSchemaExist db schema `finally` DB.close db
+
+doesSchemaExist :: DB.Connection -> ByteString -> IO Bool
+doesSchemaExist db schema = do
+  [Only schemaExists] <-
+    PSQL.query
+      db
+      [sql|
+        SELECT EXISTS (
+          SELECT 1 FROM pg_catalog.pg_namespace
+          WHERE nspname = ?
+        )
+      |]
+      (Only schema)
+  pure schemaExists
+
+closeDBStore :: DBStore -> IO ()
+closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} =
+  ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do
+    replicateM_ dbPoolSize $ atomically (readTBQueue dbPool) >>= DB.close
+    atomically $ writeTVar dbClosed True
+
+reopenDBStore :: DBStore -> IO ()
+reopenDBStore st =
+  ifM
+    (readTVarIO $ dbClosed st)
+    (void $ connectPool st False)
+    (putStrLn "reopenDBStore: already opened")
+
+-- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL)
+execSQL :: PSQL.Connection -> Text -> IO [Text]
+execSQL _db _query = throwIO (userError "not implemented")

src/Simplex/Messaging/Agent/Store/Postgres/Common.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Common
+  ( DBStore (..),
+    DBOpts (..),
+    withConnection,
+    withConnection',
+    withTransaction,
+    withTransaction',
+    withTransactionPriority,
+  )
+where
+
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Data.ByteString (ByteString)
+import qualified Database.PostgreSQL.Simple as PSQL
+import Simplex.Messaging.Agent.Store.Postgres.Options
+
+-- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type)
+data DBStore = DBStore
+  { dbConnstr :: ByteString,
+    dbSchema :: ByteString,
+    dbPoolSize :: Int,
+    dbPool :: TBQueue PSQL.Connection,
+    -- MVar is needed for fair pool distribution, without STM retry contention.
+    -- Only one thread can be blocked on STM read.
+    dbSem :: MVar (),
+    dbClosed :: TVar Bool,
+    dbNew :: Bool
+  }
+
+withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
+withConnectionPriority DBStore {dbPool, dbSem} _priority =
+  bracket
+    (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPool)
+    (atomically . writeTBQueue dbPool)
+
+withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withConnection st = withConnectionPriority st False
+{-# INLINE withConnection #-}
+
+withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withConnection' = withConnection
+{-# INLINE withConnection' #-}
+
+withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withTransaction' = withTransaction
+{-# INLINE withTransaction' #-}
+
+withTransaction :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withTransaction st = withTransactionPriority st False
+{-# INLINE withTransaction #-}
+
+-- TODO [postgres] analogue for dbBusyLoop?
+withTransactionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
+withTransactionPriority st priority action = withConnectionPriority st priority transaction
+  where
+    transaction conn = PSQL.withTransaction conn $ action conn

src/Simplex/Messaging/Agent/Store/Postgres/DB.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.DB
+  ( BoolInt (..),
+    PSQL.Binary (..),
+    PSQL.Connection,
+    FromField (..),
+    ToField (..),
+    PSQL.connect,
+    PSQL.close,
+    execute,
+    execute_,
+    executeMany,
+    PSQL.query,
+    PSQL.query_,
+    blobFieldDecoder,
+    fromTextField_,
+  )
+where
+
+import Control.Monad (void)
+import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Typeable (Typeable)
+import Data.Word (Word16, Word32)
+import Database.PostgreSQL.Simple (ResultError (..))
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.FromField (Field (..), FieldParser, FromField (..), returnError)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid)
+
+newtype BoolInt = BI {unBI :: Bool}
+
+instance FromField BoolInt where
+  fromField field dat = BI . (/= (0 :: Int)) <$> fromField field dat
+  {-# INLINE fromField #-}
+
+instance ToField BoolInt where
+  toField (BI b) = toField ((if b then 1 else 0) :: Int)
+  {-# INLINE toField #-}
+
+execute :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> q -> IO ()
+execute db q qs = void $ PSQL.execute db q qs
+{-# INLINE execute #-}
+
+execute_ :: PSQL.Connection -> PSQL.Query -> IO ()
+execute_ db q = void $ PSQL.execute_ db q
+{-# INLINE execute_ #-}
+
+executeMany :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> [q] -> IO ()
+executeMany db q qs = void $ PSQL.executeMany db q qs
+{-# INLINE executeMany #-}
+
+-- orphan instances
+
+-- used in FileSize
+instance FromField Word32 where
+  fromField field dat = do
+    i :: Int64 <- fromField field dat
+    if i >= 0 && i <= fromIntegral (maxBound :: Word32)
+      then pure (fromIntegral i :: Word32)
+      else returnError ConversionFailed field "Negative value can't be converted to Word32"
+
+-- used in Version
+instance FromField Word16 where
+  fromField field dat = do
+    i :: Int64 <- fromField field dat
+    if i >= 0 && i <= fromIntegral (maxBound :: Word16)
+      then pure (fromIntegral i :: Word16)
+      else returnError ConversionFailed field "Negative value can't be converted to Word16"
+
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder dec f val = do
+  x <- fromField f val
+  case dec x of
+    Right k -> pure k
+    Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
+
+fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a
+fromTextField_ fromText f val =
+  if typeOid f `elem` [textOid, varcharOid]
+    then case val of
+      Just t -> case fromText $ decodeUtf8 t of
+        Just x -> pure x
+        _ -> returnError ConversionFailed f "invalid text value"
+      Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field"
+    else returnError Incompatible f "expecting TEXT or VARCHAR column type"

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

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations
+  ( initialize,
+    run,
+    getCurrentMigrations,
+  )
+where
+
+import Control.Exception (throwIO)
+import Control.Monad (void)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time.Clock (getCurrentTime)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import Database.PostgreSQL.Simple (Only (..))
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.Internal (Connection (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import Simplex.Messaging.Agent.Store.Shared
+import Simplex.Messaging.Util (($>>=))
+import UnliftIO.MVar
+
+initialize :: DBStore -> IO ()
+initialize st = withTransaction' st $ \db ->
+  void $
+    PSQL.execute_
+      db
+      [sql|
+      CREATE TABLE IF NOT EXISTS migrations (
+        name TEXT NOT NULL,
+        ts TIMESTAMP NOT NULL,
+        down TEXT,
+        PRIMARY KEY (name)
+      )
+    |]
+
+run :: DBStore -> MigrationsToRun -> IO ()
+run st = \case
+  MTRUp [] -> pure ()
+  MTRUp ms -> mapM_ runUp ms
+  MTRDown ms -> mapM_ runDown $ reverse ms
+  MTRNone -> pure ()
+  where
+    runUp Migration {name, up, down} = withTransaction' st $ \db -> do
+      insert db
+      execSQL db up
+      where
+        insert db = void $ PSQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
+    runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do
+      execSQL db downQuery
+      void $ PSQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
+    execSQL db query =
+      withMVar (connectionHandle db) $ \pqConn ->
+        LibPQ.exec pqConn (TE.encodeUtf8 query) $>>= LibPQ.resultErrorMessage >>= \case
+          Just e | not (B.null e) -> throwIO $ userError $ B.unpack e
+          _ -> pure ()
+
+getCurrentMigrations :: PSQL.Connection -> IO [Migration]
+getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
+  where
+    toMigration (name, down) = Migration {name, up = T.pack "", down}

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.App (appMigrations) where
+
+import Data.List (sortOn)
+import Data.Text (Text)
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
+import Simplex.Messaging.Agent.Store.Shared (Migration (..))
+
+schemaMigrations :: [(String, Text, Maybe Text)]
+schemaMigrations =
+  [ ("20241210_initial", m20241210_initial, Nothing),
+    ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
+  ]
+
+-- | The list of migrations in ascending order by date
+appMigrations :: [Migration]
+appMigrations = sortOn name $ map migration schemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up, down = down}

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs

@@ -0,0 +1,545 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.RawString.QQ (r)
+
+m20241210_initial :: Text
+m20241210_initial =
+  T.pack
+    [r|
+CREATE TABLE users(
+  user_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  deleted SMALLINT NOT NULL DEFAULT 0
+);
+CREATE TABLE servers(
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  key_hash BYTEA NOT NULL,
+  PRIMARY KEY(host, port)
+);
+CREATE TABLE connections(
+  conn_id BYTEA NOT NULL PRIMARY KEY,
+  conn_mode TEXT NOT NULL,
+  last_internal_msg_id BIGINT NOT NULL DEFAULT 0,
+  last_internal_rcv_msg_id BIGINT NOT NULL DEFAULT 0,
+  last_internal_snd_msg_id BIGINT NOT NULL DEFAULT 0,
+  last_external_snd_msg_id BIGINT NOT NULL DEFAULT 0,
+  last_rcv_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA,
+  last_snd_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA,
+  smp_agent_version INTEGER NOT NULL DEFAULT 1,
+  duplex_handshake SMALLINT NULL DEFAULT 0,
+  enable_ntfs SMALLINT,
+  deleted SMALLINT NOT NULL DEFAULT 0,
+  user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
+  ratchet_sync_state TEXT NOT NULL DEFAULT 'ok',
+  deleted_at_wait_delivery TIMESTAMPTZ,
+  pq_support SMALLINT NOT NULL DEFAULT 0
+);
+CREATE TABLE rcv_queues(
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  rcv_id BYTEA NOT NULL,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  rcv_private_key BYTEA NOT NULL,
+  rcv_dh_secret BYTEA NOT NULL,
+  e2e_priv_key BYTEA NOT NULL,
+  e2e_dh_secret BYTEA,
+  snd_id BYTEA NOT NULL,
+  snd_key BYTEA,
+  status TEXT NOT NULL,
+  smp_server_version INTEGER NOT NULL DEFAULT 1,
+  smp_client_version INTEGER,
+  ntf_public_key BYTEA,
+  ntf_private_key BYTEA,
+  ntf_id BYTEA,
+  rcv_ntf_dh_secret BYTEA,
+  rcv_queue_id BIGINT NOT NULL,
+  rcv_primary SMALLINT NOT NULL,
+  replace_rcv_queue_id BIGINT NULL,
+  delete_errors BIGINT NOT NULL DEFAULT 0,
+  server_key_hash BYTEA,
+  switch_status TEXT,
+  deleted SMALLINT NOT NULL DEFAULT 0,
+  snd_secure SMALLINT NOT NULL DEFAULT 0,
+  last_broker_ts TIMESTAMPTZ,
+  PRIMARY KEY(host, port, rcv_id),
+  FOREIGN KEY(host, port) REFERENCES servers
+  ON DELETE RESTRICT ON UPDATE CASCADE,
+  UNIQUE(host, port, snd_id)
+);
+CREATE TABLE snd_queues(
+  host TEXT NOT NULL,
+  port TEXT NOT NULL,
+  snd_id BYTEA NOT NULL,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  snd_private_key BYTEA NOT NULL,
+  e2e_dh_secret BYTEA NOT NULL,
+  status TEXT NOT NULL,
+  smp_server_version INTEGER NOT NULL DEFAULT 1,
+  smp_client_version INTEGER NOT NULL DEFAULT 1,
+  snd_public_key BYTEA,
+  e2e_pub_key BYTEA,
+  snd_queue_id BIGINT NOT NULL,
+  snd_primary SMALLINT NOT NULL,
+  replace_snd_queue_id BIGINT NULL,
+  server_key_hash BYTEA,
+  switch_status TEXT,
+  snd_secure SMALLINT NOT NULL DEFAULT 0,
+  PRIMARY KEY(host, port, snd_id),
+  FOREIGN KEY(host, port) REFERENCES servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+);
+CREATE TABLE messages(
+  conn_id BYTEA NOT NULL REFERENCES connections(conn_id)
+  ON DELETE CASCADE,
+  internal_id BIGINT NOT NULL,
+  internal_ts TIMESTAMPTZ NOT NULL,
+  internal_rcv_id BIGINT,
+  internal_snd_id BIGINT,
+  msg_type BYTEA NOT NULL,
+  msg_body BYTEA NOT NULL DEFAULT ''::BYTEA,
+  msg_flags TEXT NULL,
+  pq_encryption SMALLINT NOT NULL DEFAULT 0,
+  PRIMARY KEY(conn_id, internal_id)
+);
+CREATE TABLE rcv_messages(
+  conn_id BYTEA NOT NULL,
+  internal_rcv_id BIGINT NOT NULL,
+  internal_id BIGINT NOT NULL,
+  external_snd_id BIGINT NOT NULL,
+  broker_id BYTEA NOT NULL,
+  broker_ts TIMESTAMPTZ NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  external_prev_snd_hash BYTEA NOT NULL,
+  integrity BYTEA NOT NULL,
+  user_ack SMALLINT NULL DEFAULT 0,
+  rcv_queue_id BIGINT NOT NULL,
+  PRIMARY KEY(conn_id, internal_rcv_id),
+  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
+  ON DELETE CASCADE
+);
+ALTER TABLE messages
+ADD CONSTRAINT fk_messages_rcv_messages
+  FOREIGN KEY (conn_id, internal_rcv_id) REFERENCES rcv_messages
+  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED;
+CREATE TABLE snd_messages(
+  conn_id BYTEA NOT NULL,
+  internal_snd_id BIGINT NOT NULL,
+  internal_id BIGINT NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  previous_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA,
+  retry_int_slow BIGINT,
+  retry_int_fast BIGINT,
+  rcpt_internal_id BIGINT,
+  rcpt_status TEXT,
+  PRIMARY KEY(conn_id, internal_snd_id),
+  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
+  ON DELETE CASCADE
+);
+ALTER TABLE messages
+ADD CONSTRAINT fk_messages_snd_messages
+  FOREIGN KEY (conn_id, internal_snd_id) REFERENCES snd_messages
+  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED;
+CREATE TABLE conn_confirmations(
+  confirmation_id BYTEA NOT NULL PRIMARY KEY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  e2e_snd_pub_key BYTEA NOT NULL,
+  sender_key BYTEA,
+  ratchet_state BYTEA NOT NULL,
+  sender_conn_info BYTEA NOT NULL,
+  accepted SMALLINT NOT NULL,
+  own_conn_info BYTEA,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  smp_reply_queues BYTEA NULL,
+  smp_client_version INTEGER
+);
+CREATE TABLE conn_invitations(
+  invitation_id BYTEA NOT NULL PRIMARY KEY,
+  contact_conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  cr_invitation BYTEA NOT NULL,
+  recipient_conn_info BYTEA NOT NULL,
+  accepted SMALLINT NOT NULL DEFAULT 0,
+  own_conn_info BYTEA,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE ratchets(
+  conn_id BYTEA NOT NULL PRIMARY KEY REFERENCES connections
+  ON DELETE CASCADE,
+  x3dh_priv_key_1 BYTEA,
+  x3dh_priv_key_2 BYTEA,
+  ratchet_state BYTEA,
+  e2e_version INTEGER NOT NULL DEFAULT 1,
+  x3dh_pub_key_1 BYTEA,
+  x3dh_pub_key_2 BYTEA,
+  pq_priv_kem BYTEA,
+  pq_pub_kem BYTEA
+);
+CREATE TABLE skipped_messages(
+  skipped_message_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES ratchets
+  ON DELETE CASCADE,
+  header_key BYTEA NOT NULL,
+  msg_n BIGINT NOT NULL,
+  msg_key BYTEA NOT NULL
+);
+CREATE TABLE ntf_servers(
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_key_hash BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  PRIMARY KEY(ntf_host, ntf_port)
+);
+CREATE TABLE ntf_tokens(
+  provider TEXT NOT NULL,
+  device_token TEXT NOT NULL,
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  tkn_id BYTEA,
+  tkn_pub_key BYTEA NOT NULL,
+  tkn_priv_key BYTEA NOT NULL,
+  tkn_pub_dh_key BYTEA NOT NULL,
+  tkn_priv_dh_key BYTEA NOT NULL,
+  tkn_dh_secret BYTEA,
+  tkn_status TEXT NOT NULL,
+  tkn_action BYTEA,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  ntf_mode BYTEA NULL,
+  PRIMARY KEY(provider, device_token, ntf_host, ntf_port),
+  FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+);
+CREATE TABLE ntf_subscriptions(
+  conn_id BYTEA NOT NULL,
+  smp_host TEXT NULL,
+  smp_port TEXT NULL,
+  smp_ntf_id BYTEA,
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_sub_id BYTEA,
+  ntf_sub_status TEXT NOT NULL,
+  ntf_sub_action BYTEA,
+  ntf_sub_smp_action BYTEA,
+  ntf_sub_action_ts TIMESTAMPTZ,
+  updated_by_supervisor SMALLINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  smp_server_key_hash BYTEA,
+  ntf_failed SMALLINT DEFAULT 0,
+  smp_failed SMALLINT DEFAULT 0,
+  PRIMARY KEY(conn_id),
+  FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
+  ON DELETE SET NULL ON UPDATE CASCADE,
+  FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+);
+CREATE TABLE commands(
+  command_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  host TEXT,
+  port TEXT,
+  corr_id BYTEA NOT NULL,
+  command_tag BYTEA NOT NULL,
+  command BYTEA NOT NULL,
+  agent_version INTEGER NOT NULL DEFAULT 1,
+  server_key_hash BYTEA,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00',
+  failed SMALLINT DEFAULT 0,
+  FOREIGN KEY(host, port) REFERENCES servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+);
+CREATE TABLE snd_message_deliveries(
+  snd_message_delivery_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  snd_queue_id BIGINT NOT NULL,
+  internal_id BIGINT NOT NULL,
+  failed SMALLINT DEFAULT 0,
+  FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
+);
+CREATE TABLE xftp_servers(
+  xftp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  xftp_host TEXT NOT NULL,
+  xftp_port TEXT NOT NULL,
+  xftp_key_hash BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  UNIQUE(xftp_host, xftp_port, xftp_key_hash)
+);
+CREATE TABLE rcv_files(
+  rcv_file_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  rcv_file_entity_id BYTEA NOT NULL,
+  user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
+  size BIGINT NOT NULL,
+  digest BYTEA NOT NULL,
+  key BYTEA NOT NULL,
+  nonce BYTEA NOT NULL,
+  chunk_size BIGINT NOT NULL,
+  prefix_path TEXT NOT NULL,
+  tmp_path TEXT,
+  save_path TEXT NOT NULL,
+  status TEXT NOT NULL,
+  deleted SMALLINT NOT NULL DEFAULT 0,
+  error TEXT,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  save_file_key BYTEA,
+  save_file_nonce BYTEA,
+  failed SMALLINT DEFAULT 0,
+  redirect_id BIGINT REFERENCES rcv_files ON DELETE SET NULL,
+  redirect_entity_id BYTEA,
+  redirect_size BIGINT,
+  redirect_digest BYTEA,
+  approved_relays SMALLINT NOT NULL DEFAULT 0,
+  UNIQUE(rcv_file_entity_id)
+);
+CREATE TABLE rcv_file_chunks(
+  rcv_file_chunk_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  rcv_file_id BIGINT NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
+  chunk_no BIGINT NOT NULL,
+  chunk_size BIGINT NOT NULL,
+  digest BYTEA NOT NULL,
+  tmp_path TEXT,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE rcv_file_chunk_replicas(
+  rcv_file_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  rcv_file_chunk_id BIGINT NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE,
+  replica_number BIGINT NOT NULL,
+  xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BYTEA NOT NULL,
+  replica_key BYTEA NOT NULL,
+  received SMALLINT NOT NULL DEFAULT 0,
+  delay BIGINT,
+  retries BIGINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE snd_files(
+  snd_file_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  snd_file_entity_id BYTEA NOT NULL,
+  user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
+  num_recipients BIGINT NOT NULL,
+  digest BYTEA,
+  key BYTEA NOT NUll,
+  nonce BYTEA NOT NUll,
+  path TEXT NOT NULL,
+  prefix_path TEXT,
+  status TEXT NOT NULL,
+  deleted SMALLINT NOT NULL DEFAULT 0,
+  error TEXT,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  src_file_key BYTEA,
+  src_file_nonce BYTEA,
+  failed SMALLINT DEFAULT 0,
+  redirect_size BIGINT,
+  redirect_digest BYTEA
+);
+CREATE TABLE snd_file_chunks(
+  snd_file_chunk_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  snd_file_id BIGINT NOT NULL REFERENCES snd_files ON DELETE CASCADE,
+  chunk_no BIGINT NOT NULL,
+  chunk_offset BIGINT NOT NULL,
+  chunk_size BIGINT NOT NULL,
+  digest BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE snd_file_chunk_replicas(
+  snd_file_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  snd_file_chunk_id BIGINT NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE,
+  replica_number BIGINT NOT NULL,
+  xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BYTEA NOT NULL,
+  replica_key BYTEA NOT NULL,
+  replica_status TEXT NOT NULL,
+  delay BIGINT,
+  retries BIGINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE snd_file_chunk_replica_recipients(
+  snd_file_chunk_replica_recipient_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  snd_file_chunk_replica_id BIGINT NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE,
+  rcv_replica_id BYTEA NOT NULL,
+  rcv_replica_key BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE deleted_snd_chunk_replicas(
+  deleted_snd_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
+  xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BYTEA NOT NULL,
+  replica_key BYTEA NOT NULL,
+  chunk_digest BYTEA NOT NULL,
+  delay BIGINT,
+  retries BIGINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  failed SMALLINT DEFAULT 0
+);
+CREATE TABLE encrypted_rcv_message_hashes(
+  encrypted_rcv_message_hash_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  hash BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE processed_ratchet_key_hashes(
+  processed_ratchet_key_hash_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE,
+  hash BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+CREATE TABLE servers_stats(
+  servers_stats_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  servers_stats TEXT,
+  started_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now()),
+  updated_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+INSERT INTO servers_stats DEFAULT VALUES;
+CREATE TABLE ntf_tokens_to_delete(
+  ntf_token_to_delete_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_key_hash BYTEA NOT NULL,
+  tkn_id BYTEA NOT NULL,
+  tkn_priv_key BYTEA NOT NULL,
+  del_failed SMALLINT DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (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);
+CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id);
+CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations(
+  contact_conn_id
+);
+CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages(
+  conn_id,
+  internal_snd_id
+);
+CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages(
+  conn_id,
+  internal_rcv_id
+);
+CREATE INDEX idx_messages_conn_id ON messages(conn_id);
+CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions(
+  smp_host,
+  smp_port
+);
+CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id);
+CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
+CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(
+  conn_id,
+  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
+);
+CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes(
+  conn_id,
+  hash
+);
+CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages(
+  conn_id,
+  rcpt_internal_id
+);
+CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON processed_ratchet_key_hashes(
+  created_at
+);
+CREATE INDEX idx_encrypted_rcv_message_hashes_created_at ON encrypted_rcv_message_hashes(
+  created_at
+);
+CREATE INDEX idx_messages_internal_ts ON messages(internal_ts);
+CREATE INDEX idx_commands_server_commands ON commands(
+  host,
+  port,
+  created_at,
+  command_id
+);
+CREATE INDEX idx_rcv_files_status_created_at ON rcv_files(status, created_at);
+CREATE INDEX idx_snd_files_status_created_at ON snd_files(status, created_at);
+CREATE INDEX idx_snd_files_snd_file_entity_id ON snd_files(snd_file_entity_id);
+CREATE INDEX idx_messages_snd_expired ON messages(
+  conn_id,
+  internal_snd_id,
+  internal_ts
+);
+CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(
+  conn_id,
+  snd_queue_id,
+  failed,
+  internal_id
+);
+CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
+|]

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250203_msg_bodies.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.RawString.QQ (r)
+
+m20250203_msg_bodies :: Text
+m20250203_msg_bodies =
+  T.pack
+    [r|
+ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BYTEA;
+ALTER TABLE snd_messages ADD COLUMN padded_msg_len BIGINT;
+
+
+CREATE TABLE snd_message_bodies (
+  snd_message_body_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  agent_msg BYTEA NOT NULL DEFAULT ''::BYTEA
+);
+ALTER TABLE snd_messages ADD COLUMN snd_message_body_id BIGINT REFERENCES snd_message_bodies ON DELETE SET NULL;
+CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id);
+|]
+
+
+down_m20250203_msg_bodies :: Text
+down_m20250203_msg_bodies =
+  T.pack
+    [r|
+DROP INDEX idx_snd_messages_snd_message_body_id;
+ALTER TABLE snd_messages DROP COLUMN snd_message_body_id;
+DROP TABLE snd_message_bodies;
+
+
+ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key;
+ALTER TABLE snd_messages DROP COLUMN padded_msg_len;
+|]

src/Simplex/Messaging/Agent/Store/Postgres/Options.hs

@@ -0,0 +1,12 @@
+module Simplex.Messaging.Agent.Store.Postgres.Options where
+
+import Data.ByteString (ByteString)
+import Numeric.Natural
+
+data DBOpts = DBOpts
+  { connstr :: ByteString,
+    schema :: ByteString,
+    poolSize :: Natural,
+    createSchema :: Bool
+  }
+  deriving (Show)

src/Simplex/Messaging/Agent/Store/Postgres/Util.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Util
+  ( createDBAndUserIfNotExists,
+    dropSchema,
+    dropAllSchemasExceptSystem,
+    dropDatabaseAndUser,
+  )
+where
+
+import Control.Exception (bracket)
+import Control.Monad (forM_, unless, void, when)
+import Data.String (fromString)
+import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..), defaultConnectInfo)
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+
+createDBAndUserIfNotExists :: ConnectInfo -> IO ()
+createDBAndUserIfNotExists ConnectInfo {connectUser = user, connectDatabase = dbName} = do
+  -- connect to the default "postgres" maintenance database
+  bracket (PSQL.connect defaultConnectInfo {connectUser = "postgres", connectDatabase = "postgres"}) PSQL.close $
+    \postgresDB -> do
+      void $ PSQL.execute_ postgresDB "SET client_min_messages TO WARNING"
+      -- check if the user exists, create if not
+      [Only userExists] <-
+        PSQL.query
+          postgresDB
+          [sql|
+            SELECT EXISTS (
+              SELECT 1 FROM pg_catalog.pg_roles
+              WHERE rolname = ?
+            )
+          |]
+          (Only user)
+      unless userExists $ void $ PSQL.execute_ postgresDB (fromString $ "CREATE USER " <> user)
+      -- check if the database exists, create if not
+      dbExists <- checkDBExists postgresDB dbName
+      unless dbExists $ void $ PSQL.execute_ postgresDB (fromString $ "CREATE DATABASE " <> dbName <> " OWNER " <> user)
+
+checkDBExists :: PSQL.Connection -> String -> IO Bool
+checkDBExists postgresDB dbName = do
+  [Only dbExists] <-
+    PSQL.query
+      postgresDB
+      [sql|
+        SELECT EXISTS (
+          SELECT 1 FROM pg_catalog.pg_database
+          WHERE datname = ?
+        )
+      |]
+      (Only dbName)
+  pure dbExists
+
+dropSchema :: ConnectInfo -> String -> IO ()
+dropSchema connectInfo schema =
+  bracket (PSQL.connect connectInfo) PSQL.close $
+    \db -> do
+      void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
+      void $ PSQL.execute_ db (fromString $ "DROP SCHEMA IF EXISTS " <> schema <> " CASCADE")
+
+dropAllSchemasExceptSystem :: ConnectInfo -> IO ()
+dropAllSchemasExceptSystem connectInfo =
+  bracket (PSQL.connect connectInfo) PSQL.close $
+    \db -> do
+      void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
+      schemaNames :: [Only String] <-
+        PSQL.query_
+          db
+          [sql|
+            SELECT schema_name
+            FROM information_schema.schemata
+            WHERE schema_name NOT IN ('public', 'pg_catalog', 'information_schema')
+          |]
+      forM_ schemaNames $ \(Only schema) ->
+        PSQL.execute_ db (fromString $ "DROP SCHEMA " <> schema <> " CASCADE")
+
+dropDatabaseAndUser :: ConnectInfo -> IO ()
+dropDatabaseAndUser ConnectInfo {connectUser = user, connectDatabase = dbName} =
+  bracket (PSQL.connect defaultConnectInfo {connectUser = "postgres", connectDatabase = "postgres"}) PSQL.close $
+    \postgresDB -> do
+      void $ PSQL.execute_ postgresDB "SET client_min_messages TO WARNING"
+      dbExists <- checkDBExists postgresDB dbName
+      when dbExists $ do
+        void $ PSQL.execute_ postgresDB (fromString $ "ALTER DATABASE " <> dbName <> " WITH ALLOW_CONNECTIONS false")
+        -- terminate all connections to the database
+        _r :: [Only Bool] <-
+          PSQL.query
+            postgresDB
+            [sql|
+              SELECT pg_terminate_backend(pg_stat_activity.pid)
+              FROM pg_stat_activity
+              WHERE datname = ?
+                AND pid <> pg_backend_pid()
+            |]
+            (Only dbName)
+        void $ PSQL.execute_ postgresDB (fromString $ "DROP DATABASE " <> dbName)
+      void $ PSQL.execute_ postgresDB (fromString $ "DROP USER IF EXISTS " <> user)

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

@@ -4,7 +4,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Common
-  ( SQLiteStore (..),
+  ( DBStore (..),
+    DBOpts (..),
     withConnection,
     withConnection',
     withTransaction,
@@ -30,7 +31,7 @@ import UnliftIO.STM
 storeKey :: ScrubbedBytes -> Bool -> Maybe ScrubbedBytes
 storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing
 
-data SQLiteStore = SQLiteStore
+data DBStore = DBStore
   { dbFilePath :: FilePath,
     dbKey :: TVar (Maybe ScrubbedBytes),
     dbSem :: TVar Int,
@@ -39,8 +40,16 @@ data SQLiteStore = SQLiteStore
     dbNew :: Bool
   }
 
-withConnectionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a
-withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action
+data DBOpts = DBOpts
+  { dbFilePath :: FilePath,
+    dbKey :: ScrubbedBytes,
+    keepKey :: Bool,
+    vacuum :: Bool,
+    track :: DB.TrackQueries
+  }
+
+withConnectionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a
+withConnectionPriority DBStore {dbSem, dbConnection} priority action
   | priority = E.bracket_ signal release $ withMVar dbConnection action
   | otherwise = lowPriority
   where
@@ -50,20 +59,20 @@ withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action
     wait = unlessM free $ atomically $ unlessM ((0 ==) <$> readTVar dbSem) retry
     free = (0 ==) <$> readTVarIO dbSem
 
-withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withConnection :: DBStore -> (DB.Connection -> IO a) -> IO a
 withConnection st = withConnectionPriority st False
 
-withConnection' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a
+withConnection' :: DBStore -> (SQL.Connection -> IO a) -> IO a
 withConnection' st action = withConnection st $ action . DB.conn
 
-withTransaction' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a
+withTransaction' :: DBStore -> (SQL.Connection -> IO a) -> IO a
 withTransaction' st action = withTransaction st $ action . DB.conn
 
-withTransaction :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransaction :: DBStore -> (DB.Connection -> IO a) -> IO a
 withTransaction st = withTransactionPriority st False
 {-# INLINE withTransaction #-}
 
-withTransactionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a
+withTransactionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a
 withTransactionPriority st priority action = withConnectionPriority st priority $ dbBusyLoop . transaction
   where
     transaction db@DB.Connection {conn} = SQL.withImmediateTransaction conn $ action db

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

@@ -1,45 +1,69 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.DB
-  ( Connection (..),
+  ( BoolInt (..),
+    Binary (..),
+    Connection (..),
     SlowQueryStats (..),
+    TrackQueries (..),
+    FromField (..),
+    ToField (..),
     open,
     close,
     execute,
     execute_,
-    executeNamed,
     executeMany,
     query,
     query_,
-    queryNamed,
+    blobFieldDecoder,
+    fromTextField_,
   )
 where
 
 import Control.Concurrent.STM
-import Control.Monad (when)
 import Control.Exception
+import Control.Monad (when)
 import qualified Data.Aeson.TH as J
+import Data.ByteString (ByteString)
 import Data.Int (Int64)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time (diffUTCTime, getCurrentTime)
-import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow)
+import Data.Typeable (Typeable)
+import Database.SQLite.Simple (FromRow, ResultError (..), Query, SQLData (..), ToRow)
 import qualified Database.SQLite.Simple as SQL
+import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
+import Database.SQLite.Simple.Internal (Field (..))
+import Database.SQLite.Simple.Ok (Ok (Ok))
+import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (diffToMilliseconds, tshow)
+import Simplex.Messaging.Util (diffToMicroseconds, tshow)
+
+newtype BoolInt = BI {unBI :: Bool}
+  deriving newtype (FromField, ToField)
+
+newtype Binary = Binary {fromBinary :: ByteString}
+  deriving newtype (FromField, ToField)
 
 data Connection = Connection
   { conn :: SQL.Connection,
+    track :: TrackQueries,
     slow :: TMap Query SlowQueryStats
   }
 
+data TrackQueries = TQAll | TQSlow Int64 | TQOff
+  deriving (Eq)
+
 data SlowQueryStats = SlowQueryStats
   { count :: Int64,
     timeMax :: Int64,
@@ -48,21 +72,29 @@ data SlowQueryStats = SlowQueryStats
   }
   deriving (Show)
 
-timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a
-timeIt slow sql a = do
-  t <- getCurrentTime
-  r <- a `catch` \e -> do
-    atomically $ TM.alter (Just . updateQueryErrors e) sql slow
-    throwIO e
-  t' <- getCurrentTime
-  let diff = diffToMilliseconds $ diffUTCTime t' t
-  when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow
-  pure r
+timeIt :: Connection -> Query -> IO a -> IO a
+timeIt Connection {slow, track} sql a
+  | track == TQOff = makeQuery
+  | otherwise = do
+      t <- getCurrentTime
+      r <- makeQuery
+      t' <- getCurrentTime
+      let diff = diffToMicroseconds $ diffUTCTime t' t
+      when (trackQuery diff) $ atomically $ TM.alter (updateQueryStats diff) sql slow
+      pure r
   where
+    makeQuery =
+      a `catch` \e -> do
+        atomically $ TM.alter (Just . updateQueryErrors e) sql slow
+        throwIO e
+    trackQuery diff = case track of
+      TQOff -> False
+      TQSlow t -> diff > t
+      TQAll -> True
     updateQueryErrors :: SomeException -> Maybe SlowQueryStats -> SlowQueryStats
     updateQueryErrors e Nothing = SlowQueryStats 0 0 0 $ M.singleton (tshow e) 1
-    updateQueryErrors e (Just stats@SlowQueryStats {errs}) =
-      stats {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs}
+    updateQueryErrors e (Just st@SlowQueryStats {errs}) =
+      st {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs}
     updateQueryStats :: Int64 -> Maybe SlowQueryStats -> Maybe SlowQueryStats
     updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff M.empty
     updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg, errs}) =
@@ -74,41 +106,49 @@ timeIt slow sql a = do
             errs
           }
 
-open :: String -> IO Connection
-open f = do
+open :: String -> TrackQueries -> IO Connection
+open f track = do
   conn <- SQL.open f
   slow <- TM.emptyIO
-  pure Connection {conn, slow}
+  pure Connection {conn, slow, track}
 
 close :: Connection -> IO ()
 close = SQL.close . conn
 
 execute :: ToRow q => Connection -> Query -> q -> IO ()
-execute Connection {conn, slow} sql = timeIt slow sql . SQL.execute conn sql
+execute c sql = timeIt c sql . SQL.execute (conn c) sql
 {-# INLINE execute #-}
 
 execute_ :: Connection -> Query -> IO ()
-execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql
+execute_ c sql = timeIt c sql $ SQL.execute_ (conn c) sql
 {-# INLINE execute_ #-}
 
-executeNamed :: Connection -> Query -> [NamedParam] -> IO ()
-executeNamed Connection {conn, slow} sql = timeIt slow sql . SQL.executeNamed conn sql
-{-# INLINE executeNamed #-}
-
 executeMany :: ToRow q => Connection -> Query -> [q] -> IO ()
-executeMany Connection {conn, slow} sql = timeIt slow sql . SQL.executeMany conn sql
+executeMany c sql = timeIt c sql . SQL.executeMany (conn c) sql
 {-# INLINE executeMany #-}
 
 query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
-query Connection {conn, slow} sql = timeIt slow sql . SQL.query conn sql
+query c sql = timeIt c sql . SQL.query (conn c) sql
 {-# INLINE query #-}
 
 query_ :: FromRow r => Connection -> Query -> IO [r]
-query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql
+query_ c sql = timeIt c sql $ SQL.query_ (conn c) sql
 {-# INLINE query_ #-}
 
-queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r]
-queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql
-{-# INLINE queryNamed #-}
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder dec = \case
+  f@(Field (SQLBlob b) _) ->
+    case dec b of
+      Right k -> Ok k
+      Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
+  f -> returnError ConversionFailed f "expecting SQLBlob column type"
+
+fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
+fromTextField_ fromText = \case
+  f@(Field (SQLText t) _) ->
+    case fromText t of
+      Just x -> Ok x
+      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
+  f -> returnError ConversionFailed f "expecting SQLText column type"
 
 $(J.deriveJSON defaultJSON ''SlowQueryStats)

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

@@ -5,142 +5,44 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Migrations
-  ( Migration (..),
-    MigrationsToRun (..),
-    MTRError (..),
-    DownMigration (..),
-    app,
-    initialize,
-    get,
+  ( initialize,
     run,
-    getCurrent,
-    mtrErrorDescription,
-    -- for unit tests
-    migrationsToRun,
-    toDownMigration,
+    getCurrentMigrations,
   )
 where
 
 import Control.Monad (forM_, when)
-import qualified Data.Aeson.TH as J
-import Data.List (intercalate, sortOn)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (Connection, Only (..), Query (..))
-import qualified Database.SQLite.Simple as DB
+import Database.SQLite.Simple (Only (..), Query (..))
+import qualified Database.SQLite.Simple as SQL
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.SQLite.Common
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
+import Simplex.Messaging.Agent.Store.Shared
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
 
-data Migration = Migration {name :: String, up :: Text, down :: Maybe Text}
-  deriving (Eq, Show)
-
-schemaMigrations :: [(String, Query, Maybe Query)]
-schemaMigrations =
-  [ ("20220101_initial", m20220101_initial, Nothing),
-    ("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing),
-    ("20220322_notifications", m20220322_notifications, Nothing),
-    ("20220607_v2", m20220608_v2, Nothing),
-    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing),
-    ("m20220811_onion_hosts", m20220811_onion_hosts, Nothing),
-    ("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing),
-    ("m20220905_commands", m20220905_commands, Nothing),
-    ("m20220915_connection_queues", m20220915_connection_queues, Nothing),
-    ("m20230110_users", m20230110_users, Nothing),
-    ("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
-    ("m20230120_delete_errors", m20230120_delete_errors, Nothing),
-    ("m20230217_server_key_hash", m20230217_server_key_hash, Nothing),
-    ("m20230223_files", m20230223_files, Just down_m20230223_files),
-    ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
-    ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
-    ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
-    ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
-    ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
-    ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
-    ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
-    ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
-    ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
-    ("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
-    ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
-    ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
-    ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
-    ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
-    ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
-    ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
-    ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
-    ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
-    ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
-    ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
-    ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
-    ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts)
-  ]
-
--- | The list of migrations in ascending order by date
-app :: [Migration]
-app = sortOn name $ map migration schemaMigrations
-  where
-    migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
-
-get :: SQLiteStore -> [Migration] -> IO (Either MTRError MigrationsToRun)
-get st migrations = migrationsToRun migrations <$> withTransaction' st getCurrent
-
-getCurrent :: Connection -> IO [Migration]
-getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
+getCurrentMigrations :: DB.Connection -> IO [Migration]
+getCurrentMigrations DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;"
   where
     toMigration (name, down) = Migration {name, up = "", down}
 
-run :: SQLiteStore -> MigrationsToRun -> IO ()
-run st = \case
+run :: DBStore -> Bool -> MigrationsToRun -> IO ()
+run st vacuum = \case
   MTRUp [] -> pure ()
-  MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM;")
+  MTRUp ms -> do
+    mapM_ runUp ms
+    when vacuum $ withConnection' st (`execSQL` "VACUUM;")
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where
@@ -148,27 +50,27 @@ run st = \case
       when (name == "m20220811_onion_hosts") $ updateServers db
       insert db >> execSQL db up'
       where
-        insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
+        insert db = SQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
         up'
           | dbNew st && name == "m20230110_users" = fromQuery new_m20230110_users
           | otherwise = up
         updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
           let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
-           in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
+           in SQL.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
     runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do
       execSQL db downQuery
-      DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
-    execSQL db = SQLite3.exec $ DB.connectionHandle db
+      SQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
+    execSQL db = SQLite3.exec $ SQL.connectionHandle db
 
-initialize :: SQLiteStore -> IO ()
+initialize :: DBStore -> IO ()
 initialize st = withTransaction' st $ \db -> do
-  cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')"
+  cs :: [Text] <- map fromOnly <$> SQL.query_ db "SELECT name FROM pragma_table_info('migrations')"
   case cs of
     [] -> createMigrations db
-    _ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
+    _ -> when ("down" `notElem` cs) $ SQL.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
   where
     createMigrations db =
-      DB.execute_
+      SQL.execute_
         db
         [sql|
           CREATE TABLE IF NOT EXISTS migrations (
@@ -178,37 +80,3 @@ initialize st = withTransaction' st $ \db -> do
             PRIMARY KEY (name)
           );
         |]
-
-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)
-
-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 == name d = migrationsToRun as ds
-  | otherwise = Left $ MTREDifferent (name a) (name d)
-
-$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError)

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

@@ -0,0 +1,93 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.App (appMigrations) where
+
+import Data.List (sortOn)
+import Database.SQLite.Simple (Query (..))
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
+import Simplex.Messaging.Agent.Store.Shared (Migration (..))
+
+schemaMigrations :: [(String, Query, Maybe Query)]
+schemaMigrations =
+  [ ("20220101_initial", m20220101_initial, Nothing),
+    ("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing),
+    ("20220322_notifications", m20220322_notifications, Nothing),
+    ("20220607_v2", m20220608_v2, Nothing),
+    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing),
+    ("m20220811_onion_hosts", m20220811_onion_hosts, Nothing),
+    ("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing),
+    ("m20220905_commands", m20220905_commands, Nothing),
+    ("m20220915_connection_queues", m20220915_connection_queues, Nothing),
+    ("m20230110_users", m20230110_users, Nothing),
+    ("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
+    ("m20230120_delete_errors", m20230120_delete_errors, Nothing),
+    ("m20230217_server_key_hash", m20230217_server_key_hash, Nothing),
+    ("m20230223_files", m20230223_files, Just down_m20230223_files),
+    ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state),
+    ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files),
+    ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes),
+    ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes),
+    ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status),
+    ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync),
+    ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
+    ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
+    ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
+    ("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
+    ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
+    ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
+    ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
+    ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
+    ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
+    ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
+    ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
+    ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
+    ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
+    ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
+    ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
+    ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
+    ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
+    ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
+  ]
+
+-- | The list of migrations in ascending order by date
+appMigrations :: [Migration]
+appMigrations = sortOn name $ map migration schemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}

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

@@ -0,0 +1,18 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20241224_ratchet_e2e_snd_params :: Query
+m20241224_ratchet_e2e_snd_params =
+    [sql|
+ALTER TABLE ratchets ADD COLUMN pq_pub_kem BLOB;
+|]
+
+down_m20241224_ratchet_e2e_snd_params :: Query
+down_m20241224_ratchet_e2e_snd_params =
+    [sql|
+ALTER TABLE ratchets DROP COLUMN pq_pub_kem;
+|]

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

@@ -0,0 +1,33 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20250203_msg_bodies :: Query
+m20250203_msg_bodies =
+    [sql|
+ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BLOB;
+ALTER TABLE snd_messages ADD COLUMN padded_msg_len INTEGER;
+
+
+CREATE TABLE snd_message_bodies (
+  snd_message_body_id INTEGER PRIMARY KEY,
+  agent_msg BLOB NOT NULL DEFAULT x''
+);
+ALTER TABLE snd_messages ADD COLUMN snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL;
+CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id);
+|]
+
+down_m20250203_msg_bodies :: Query
+down_m20250203_msg_bodies =
+    [sql|
+DROP INDEX idx_snd_messages_snd_message_body_id;
+ALTER TABLE snd_messages DROP COLUMN snd_message_body_id;
+DROP TABLE snd_message_bodies;
+
+
+ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key;
+ALTER TABLE snd_messages DROP COLUMN padded_msg_len;
+|]

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

@@ -127,6 +127,9 @@ CREATE TABLE snd_messages(
   retry_int_fast INTEGER,
   rcpt_internal_id INTEGER,
   rcpt_status TEXT,
+  msg_encrypt_key BLOB,
+  padded_msg_len INTEGER,
+  snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL,
   PRIMARY KEY(conn_id, internal_snd_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -166,7 +169,8 @@ CREATE TABLE ratchets(
   ,
   x3dh_pub_key_1 BLOB,
   x3dh_pub_key_2 BLOB,
-  pq_priv_kem BLOB
+  pq_priv_kem BLOB,
+  pq_pub_kem BLOB
 ) WITHOUT ROWID;
 CREATE TABLE skipped_messages(
   skipped_message_id INTEGER PRIMARY KEY,
@@ -414,6 +418,10 @@ CREATE TABLE ntf_tokens_to_delete(
 del_failed INTEGER DEFAULT 0,
 created_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
+CREATE TABLE snd_message_bodies(
+  snd_message_body_id INTEGER PRIMARY KEY,
+  agent_msg BLOB NOT NULL DEFAULT x''
+);
 CREATE 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);
@@ -540,3 +548,6 @@ CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(
   internal_id
 );
 CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
+CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(
+  snd_message_body_id
+);

src/Simplex/Messaging/Agent/Store/Shared.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Messaging.Agent.Store.Shared
+  ( Migration (..),
+    MigrationsToRun (..),
+    DownMigration (..),
+    MTRError (..),
+    mtrErrorDescription,
+    MigrationConfirmation (..),
+    MigrationError (..),
+    UpMigration (..),
+    migrationErrorDescription,
+    -- for tests
+    toDownMigration,
+    upMigration,
+  )
+where
+
+import qualified Data.Aeson.TH as J
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.List (intercalate)
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
+
+data Migration = Migration {name :: String, up :: Text, down :: Maybe Text}
+  deriving (Eq, Show)
+
+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)
+
+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
+
+data MigrationError
+  = MEUpgrade {upMigrations :: [UpMigration]}
+  | MEDowngrade {downMigrations :: [String]}
+  | MigrationError {mtrError :: MTRError}
+  deriving (Eq, Show)
+
+migrationErrorDescription :: MigrationError -> String
+migrationErrorDescription = \case
+  MEUpgrade ums ->
+    "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
+  MEDowngrade dms ->
+    "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms
+  MigrationError err -> mtrErrorDescription err
+
+data UpMigration = UpMigration {upName :: String, withDown :: Bool}
+  deriving (Eq, Show)
+
+upMigration :: Migration -> UpMigration
+upMigration Migration {name, down} = UpMigration name $ isJust down
+
+data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError
+  deriving (Eq, Show)
+
+instance StrEncoding MigrationConfirmation where
+  strEncode = \case
+    MCYesUp -> "yesUp"
+    MCYesUpDown -> "yesUpDown"
+    MCConsole -> "console"
+    MCError -> "error"
+  strP =
+    A.takeByteString >>= \case
+      "yesUp" -> pure MCYesUp
+      "yesUpDown" -> pure MCYesUpDown
+      "console" -> pure MCConsole
+      "error" -> pure MCError
+      _ -> fail "invalid MigrationConfirmation"
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError)
+
+$(J.deriveJSON defaultJSON ''UpMigration)
+
+$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError)

src/Simplex/Messaging/Client.hs

@@ -105,7 +105,7 @@ module Simplex.Messaging.Client
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent (ThreadId, forkFinally, killThread, mkWeakThreadId)
+import Control.Concurrent (ThreadId, forkFinally, forkIO, killThread, mkWeakThreadId)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
@@ -145,8 +145,7 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
+import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tryWriteTBQueue, tshow, whenM)
 import Simplex.Messaging.Version
 import System.Mem.Weak (Weak, deRefWeak)
 import System.Timeout (timeout)
@@ -172,7 +171,7 @@ data PClient v err msg = PClient
     timeoutErrorCount :: TVar Int,
     clientCorrId :: TVar ChaChaDRG,
     sentCommands :: TMap CorrId (Request err msg),
-    sndQ :: TBQueue (Maybe (TVar Bool), ByteString),
+    sndQ :: TBQueue (Maybe (Request err msg), ByteString),
     rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
     msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
   }
@@ -407,6 +406,8 @@ data ProtocolClientConfig v = ProtocolClientConfig
     serverVRange :: VersionRange v,
     -- | agree shared session secret (used in SMP proxy for additional encryption layer)
     agreeSecret :: Bool,
+    -- | Whether connecting client is a proxy server. See comment in ClientHandshake
+    proxyServer :: Bool,
     -- | send SNI to server, False for SMP
     useSNI :: Bool
   }
@@ -421,6 +422,7 @@ defaultClientConfig clientALPN useSNI serverVRange =
       clientALPN,
       serverVRange,
       agreeSecret = False,
+      proxyServer = False,
       useSNI
     }
 {-# INLINE defaultClientConfig #-}
@@ -490,7 +492,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs disconnected = do
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -544,13 +546,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
       "" -> case protocolTypeI @(ProtoType msg) of
         SPSMP | smpWebPort -> ("443", transport @TLS)
         _ -> defaultTransport cfg
-      "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
     client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
     client _ c cVar h = do
       ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
-      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {params} -> do
           sessionTs <- getCurrentTime
@@ -565,9 +566,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
     send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= sendPending
       where
-        sendPending (Nothing, s) = send_ s
-        sendPending (Just pending, s) = whenM (readTVarIO pending) $ send_ s
-        send_ = void . tPutLog h
+        sendPending (r, s) = case r of
+          Nothing -> void $ tPutLog h s
+          Just Request {pending, responseVar} ->
+            whenM (readTVarIO pending) $ tPutLog h s >>= either responseErr pure
+            where
+              responseErr = atomically . putTMVar responseVar . Left . PCETransportError
 
     receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
@@ -1082,11 +1086,11 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
       pure [Response entityId $ Left $ PCETransportError e]
     TBTransmissions s n rs
       | n > 0 -> do
-          atomically $ writeTBQueue sndQ (Nothing, s) -- do not expire batched responses
+          nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
           mapConcurrently (getResponse c Nothing) rs
       | otherwise -> pure []
     TBTransmission s r -> do
-      atomically $ writeTBQueue sndQ (Nothing, s)
+      nonBlockingWriteTBQueue sndQ (Nothing, s)
       (: []) <$> getResponse c Nothing r
 
 -- | Send Protocol command
@@ -1103,18 +1107,23 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
   where
     -- two separate "atomically" needed to avoid blocking
     sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
-    sendRecv t_ r@Request {pending} = case t_ of
+    sendRecv t_ r = case t_ of
       Left e -> pure . Left $ PCETransportError e
       Right t
         | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
         | otherwise -> do
-            atomically $ writeTBQueue sndQ (Just pending, s)
+            nonBlockingWriteTBQueue sndQ (Just r, s)
             response <$> getResponse c tOut r
         where
           s
             | batch = tEncodeBatch1 t
             | otherwise = tEncode t
 
+nonBlockingWriteTBQueue :: TBQueue a -> a -> IO ()
+nonBlockingWriteTBQueue q x = do
+  sent <- atomically $ tryWriteTBQueue q x
+  unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
+
 getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg)
 getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do
   r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar)

src/Simplex/Messaging/Crypto.hs

@@ -1,11 +1,14 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -166,6 +169,7 @@ module Simplex.Messaging.Crypto
     sha512Hash,
 
     -- * Message padding / un-padding
+    canPad,
     pad,
     unPad,
 
@@ -233,13 +237,12 @@ import Data.Typeable (Proxy (Proxy), Typeable)
 import Data.Word (Word32)
 import Data.X509
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
+import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
 
 -- | Cryptographic algorithms.
@@ -721,23 +724,23 @@ generateKeyPair_ = case sAlgorithm @a of
       let k = X448.toPublic pk
        in pure (PublicKeyX448 k, PrivateKeyX448 pk k)
 
-instance ToField APrivateSignKey where toField = toField . encodePrivKey
+instance ToField APrivateSignKey where toField = toField . Binary . encodePrivKey
 
-instance ToField APublicVerifyKey where toField = toField . encodePubKey
+instance ToField APublicVerifyKey where toField = toField . Binary . encodePubKey
 
-instance ToField APrivateAuthKey where toField = toField . encodePrivKey
+instance ToField APrivateAuthKey where toField = toField . Binary . encodePrivKey
 
-instance ToField APublicAuthKey where toField = toField . encodePubKey
+instance ToField APublicAuthKey where toField = toField . Binary . encodePubKey
 
-instance ToField APrivateDhKey where toField = toField . encodePrivKey
+instance ToField APrivateDhKey where toField = toField . Binary . encodePrivKey
 
-instance ToField APublicDhKey where toField = toField . encodePubKey
+instance ToField APublicDhKey where toField = toField . Binary . encodePubKey
 
-instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . encodePrivKey
+instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . Binary . encodePrivKey
 
-instance AlgorithmI a => ToField (PublicKey a) where toField = toField . encodePubKey
+instance AlgorithmI a => ToField (PublicKey a) where toField = toField . Binary . encodePubKey
 
-instance ToField (DhSecret a) where toField = toField . dhBytes'
+instance ToField (DhSecret a) where toField = toField . Binary . dhBytes'
 
 instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey
 
@@ -888,10 +891,9 @@ validSignatureSize n =
 -- | AES key newtype.
 newtype Key = Key {unKey :: ByteString}
   deriving (Eq, Ord, Show)
+  deriving newtype (FromField)
 
-instance ToField Key where toField = toField . unKey
-
-instance FromField Key where fromField f = Key <$> fromField f
+instance ToField Key where toField (Key s) = toField $ Binary s
 
 instance ToJSON Key where
   toJSON = strToJSON . unKey
@@ -952,7 +954,7 @@ instance FromJSON KeyHash where
 instance IsString KeyHash where
   fromString = parseString $ parseAll strP
 
-instance ToField KeyHash where toField = toField . strEncode
+instance ToField KeyHash where toField = toField . Binary . strEncode
 
 instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
 
@@ -1009,6 +1011,11 @@ decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
 maxMsgLen :: Int
 maxMsgLen = 2 ^ (16 :: Int) - 3
 
+canPad :: Int -> Int -> Bool
+canPad msgLen paddedLen = msgLen <= maxMsgLen && padLen >= 0
+  where
+    padLen = paddedLen - msgLen - 2
+
 pad :: ByteString -> Int -> Either CryptoError ByteString
 pad msg paddedLen
   | len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
@@ -1162,10 +1169,14 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
 newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
 
 instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
+#if defined(dbPostgres)
+  fromField f dat = SignedObject <$> blobFieldDecoder decodeSignedObject f dat
+#else
   fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
+#endif
 
 instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
-  toField (SignedObject s) = toField $ encodeSignedObject s
+  toField (SignedObject s) = toField . Binary $ encodeSignedObject s
 
 instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
   smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
@@ -1265,6 +1276,9 @@ cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) n
 
 newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
+  deriving newtype (FromField)
+
+instance ToField CbNonce where toField (CryptoBoxNonce s) = toField $ Binary s
 
 pattern CbNonce :: ByteString -> CbNonce
 pattern CbNonce s <- CryptoBoxNonce s
@@ -1282,10 +1296,6 @@ 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
@@ -1309,6 +1319,9 @@ instance Encoding CbNonce where
 
 newtype SbKey = SecretBoxKey {unSbKey :: ByteString}
   deriving (Eq, Show)
+  deriving newtype (FromField)
+
+instance ToField SbKey where toField (SecretBoxKey s) = toField $ Binary s
 
 pattern SbKey :: ByteString -> SbKey
 pattern SbKey s <- SecretBoxKey s
@@ -1326,10 +1339,6 @@ 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/Ratchet.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -20,6 +21,8 @@
 module Simplex.Messaging.Crypto.Ratchet
   ( Ratchet (..),
     RatchetX448,
+    MsgEncryptKey (..),
+    MsgEncryptKeyX448,
     SkippedMsgDiff (..),
     SkippedMsgKeys,
     InitialKeys (..),
@@ -63,7 +66,9 @@ module Simplex.Messaging.Crypto.Ratchet
     pqX3dhRcv,
     initSndRatchet,
     initRcvRatchet,
-    rcEncrypt,
+    rcCheckCanPad,
+    rcEncryptHeader,
+    rcEncryptMsg,
     rcDecrypt,
     -- used in tests
     MsgHeader (..),
@@ -84,6 +89,7 @@ module Simplex.Messaging.Crypto.Ratchet
 where
 
 import Control.Applicative ((<|>))
+import Control.Monad (unless)
 import Control.Monad.Except
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
@@ -109,14 +115,13 @@ import Data.Maybe (fromMaybe, isJust)
 import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word32)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.QueryString
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder)
 import Simplex.Messaging.Crypto
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE')
+import Simplex.Messaging.Parsers (defaultJSON, parseE, parseE')
 import Simplex.Messaging.Util (($>>=), (<$?>))
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
@@ -206,6 +211,10 @@ instance Encoding ARKEMParams where
       'A' -> ARKP SRKSAccepted .: RKParamsAccepted <$> smpP <*> smpP
       _ -> fail "bad ratchet KEM params"
 
+instance ToField ARKEMParams where toField = toField . Binary . smpEncode
+
+instance FromField ARKEMParams where fromField = blobFieldDecoder smpDecode
+
 data E2ERatchetParams (s :: RatchetKEMState) (a :: Algorithm)
   = E2ERatchetParams VersionE2E (PublicKey a) (PublicKey a) (Maybe (RKEMParams s))
   deriving (Show)
@@ -359,7 +368,7 @@ instance Encoding APrivRKEMParams where
       'A' -> APRKP SRKSAccepted .:. PrivateRKParamsAccepted <$> smpP <*> smpP <*> smpP
       _ -> fail "bad APrivRKEMParams"
 
-instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toField . smpEncode
+instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toField . Binary . smpEncode
 
 instance (Typeable s, RatchetKEMStateI s) => FromField (PrivRKEMParams s) where fromField = blobFieldDecoder smpDecode
 
@@ -560,6 +569,7 @@ applySMDiff smks = \case
 type HeaderKey = Key
 
 data MessageKey = MessageKey Key IV
+  deriving (Show)
 
 instance Encoding MessageKey where
   smpEncode (MessageKey (Key key) (IV iv)) = smpEncode (key, iv)
@@ -576,7 +586,7 @@ instance ToJSON RatchetKey where
 instance FromJSON RatchetKey where
   parseJSON = fmap RatchetKey . strParseJSON "Key"
 
-instance ToField MessageKey where toField = toField . smpEncode
+instance ToField MessageKey where toField = toField . Binary . smpEncode
 
 instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
 
@@ -841,9 +851,13 @@ connPQEncryption = \case
   IKUsePQ -> PQSupportOn
   IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn
 
-rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (ByteString, Ratchet a)
-rcEncrypt Ratchet {rcSnd = Nothing} _ _ _ _ = throwE CERatchetState
-rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} paddedMsgLen msg pqEnc_ supportedE2EVersion = do
+rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
+rcCheckCanPad paddedMsgLen msg =
+  unless (canPad (B.length msg) paddedMsgLen) $ throwE CryptoLargeMsgError
+
+rcEncryptHeader :: AlgorithmI a => Ratchet a -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a)
+rcEncryptHeader Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState
+rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} pqEnc_ supportedE2EVersion = do
   -- state.CKs, mk = KDF_CK(state.CKs)
   let (ck', mk, iv, ehIV) = chainKdf rcCKs
       v = current rcVersion
@@ -858,11 +872,15 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM,
       rcVersion' = rcVersion {maxSupported = maxSupported'}
   -- enc_header = HENCRYPT(state.HKs, header)
   (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen v rcSupportKEM') rcAD (msgHeader v maxSupported')
-  -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
+  -- return enc_header
   let emHeader = smpEncode EncMessageHeader {ehVersion = v, ehBody, ehAuthTag, ehIV}
-  (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg
-  let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag}
-      -- state.Ns += 1
+      msgEncryptKey =
+        MsgEncryptKey
+          { msgRcVersion = v,
+            msgKey = MessageKey mk iv,
+            msgRcAD = rcAD,
+            msgEncHeader = emHeader
+          }
       rc' =
         rc
           { rcSnd = Just sr {rcCKs = ck'},
@@ -872,7 +890,7 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM,
             rcVersion = rcVersion',
             rcKEM = if pqEnc_ == Just PQEncOff then (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM else rcKEM
           }
-  pure (msg', rc')
+  pure (msgEncryptKey, rc')
   where
     -- header = HEADER_PQ2(
     --   dh = state.DHRs.public,
@@ -895,6 +913,23 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM,
       Nothing -> ARKP SRKSProposed $ RKParamsProposed k
       Just RatchetKEMAccepted {rcPQRct} -> ARKP SRKSAccepted $ RKParamsAccepted rcPQRct k
 
+type MsgEncryptKeyX448 = MsgEncryptKey 'X448
+
+data MsgEncryptKey a = MsgEncryptKey
+  { msgRcVersion :: VersionE2E,
+    msgKey :: MessageKey,
+    msgRcAD :: ByteString,
+    msgEncHeader :: ByteString
+  }
+  deriving (Show)
+
+rcEncryptMsg :: AlgorithmI a => MsgEncryptKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString
+rcEncryptMsg MsgEncryptKey {msgKey = MessageKey mk iv, msgRcAD, msgEncHeader, msgRcVersion = v} paddedMsgLen msg = do
+  -- return ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
+  (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (msgRcAD <> msgEncHeader) msg
+  let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader = msgEncHeader, emBody, emAuthTag}
+  pure msg'
+
 data SkippedMessage a
   = SMMessage (DecryptResult a)
   | SMHeader (Maybe RatchetStep) (MsgHeader a)
@@ -1120,14 +1155,35 @@ instance AlgorithmI a => ToJSON (Ratchet a) where
 instance AlgorithmI a => FromJSON (Ratchet a) where
   parseJSON = $(JQ.mkParseJSON defaultJSON ''Ratchet)
 
-instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode
+instance AlgorithmI a => ToField (Ratchet a) where toField = toField . Binary . LB.toStrict . J.encode
 
 instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
 
-instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField pqEnc
+instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField (BI pqEnc)
 
-instance FromField PQEncryption where fromField f = PQEncryption <$> fromField f
+instance FromField PQEncryption where 
+#if defined(dbPostgres)
+  fromField f dat = PQEncryption . unBI <$> fromField f dat
+#else
+  fromField f = PQEncryption . unBI <$> fromField f
+#endif
 
-instance ToField PQSupport where toField (PQSupport pqEnc) = toField pqEnc
+instance ToField PQSupport where toField (PQSupport pqEnc) = toField (BI pqEnc)
 
-instance FromField PQSupport where fromField f = PQSupport <$> fromField f
+instance FromField PQSupport where
+#if defined(dbPostgres)
+  fromField f dat = PQSupport . unBI <$> fromField f dat
+#else
+  fromField f = PQSupport . unBI <$> fromField f
+#endif
+
+instance Encoding (MsgEncryptKey a) where
+  smpEncode MsgEncryptKey {msgRcVersion = v, msgKey, msgRcAD, msgEncHeader} =
+    smpEncode (v, msgRcAD, msgKey, Large msgEncHeader)
+  smpP = do
+    (v, msgRcAD, msgKey, Large msgEncHeader) <- smpP
+    pure MsgEncryptKey {msgRcVersion = v, msgRcAD, msgKey, msgEncHeader}
+
+instance AlgorithmI a => ToField (MsgEncryptKey a) where toField = toField . Binary . smpEncode
+
+instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField = blobFieldDecoder smpDecode

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Crypto.SNTRUP761.Bindings where
@@ -9,9 +10,8 @@ import Data.Bifunctor (bimap)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.ToField
 import Foreign (nullPtr)
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..))
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG)
@@ -121,7 +121,11 @@ instance ToField KEMSharedKey where
   toField (KEMSharedKey k) = toField (BA.convert k :: ByteString)
 
 instance FromField KEMSharedKey where
+#if defined(dbPostgres)
+  fromField f dat = KEMSharedKey . BA.convert @ByteString <$> fromField f dat
+#else
   fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f
+#endif
 
 instance ToJSON KEMSharedKey where
   toJSON = strToJSON

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -11,7 +11,7 @@
 
 module Simplex.Messaging.Notifications.Protocol where
 
-import Control.Applicative ((<|>))
+import Control.Applicative (optional, (<|>))
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -27,14 +27,12 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System
 import Data.Type.Equality
 import Data.Word (Word16)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
+import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake)
-import Simplex.Messaging.Parsers (fromTextField_)
+import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake)
 import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
 import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
 
@@ -297,12 +295,18 @@ data NtfResponse
 
 instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
   type Tag NtfResponse = NtfResponseTag
-  encodeProtocol _v = \case
+  encodeProtocol v = \case
     NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
     NRSubId entId -> e (NRSubId_, ' ', entId)
     NROk -> e NROk_
     NRErr err -> e (NRErr_, ' ', err)
-    NRTkn stat -> e (NRTkn_, ' ', stat)
+    NRTkn stat -> e (NRTkn_, ' ', stat')
+      where
+        stat'
+          | v >= invalidReasonNTFVersion = stat
+          | otherwise = case stat of
+              NTInvalid _ -> NTInvalid Nothing
+              _ -> stat
     NRSub stat -> e (NRSub_, ' ', stat)
     NRPong -> e NRPong_
     where
@@ -521,7 +525,7 @@ data NtfTknStatus
   | -- | state after registration (TNEW)
     NTRegistered
   | -- | if initial notification failed (push provider error) or verification failed
-    NTInvalid
+    NTInvalid (Maybe NTInvalidReason)
   | -- | Token confirmed via notification (accepted by push provider or verification code received by client)
     NTConfirmed
   | -- | after successful verification (TVFY)
@@ -534,7 +538,7 @@ instance Encoding NtfTknStatus where
   smpEncode = \case
     NTNew -> "NEW"
     NTRegistered -> "REGISTERED"
-    NTInvalid -> "INVALID"
+    NTInvalid r_ -> "INVALID" <> maybe "" (\r -> ',' `B.cons` strEncode r) r_
     NTConfirmed -> "CONFIRMED"
     NTActive -> "ACTIVE"
     NTExpired -> "EXPIRED"
@@ -542,12 +546,33 @@ instance Encoding NtfTknStatus where
     A.takeTill (== ' ') >>= \case
       "NEW" -> pure NTNew
       "REGISTERED" -> pure NTRegistered
-      "INVALID" -> pure NTInvalid
+      "INVALID" -> NTInvalid <$> optional (A.char ',' *> strP)
       "CONFIRMED" -> pure NTConfirmed
       "ACTIVE" -> pure NTActive
       "EXPIRED" -> pure NTExpired
       _ -> fail "bad NtfTknStatus"
 
+instance StrEncoding NTInvalidReason where
+  strEncode = smpEncode
+  strP = smpP
+
+data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRExpiredToken | NTIRUnregistered
+  deriving (Eq, Show)
+
+instance Encoding NTInvalidReason where
+  smpEncode = \case
+    NTIRBadToken -> "BAD"
+    NTIRTokenNotForTopic -> "TOPIC"
+    NTIRExpiredToken -> "EXPIRED"
+    NTIRUnregistered -> "UNREGISTERED"
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "BAD" -> pure NTIRBadToken
+      "TOPIC" -> pure NTIRTokenNotForTopic
+      "EXPIRED" -> pure NTIRExpiredToken
+      "UNREGISTERED" -> pure NTIRUnregistered
+      _ -> fail "bad NTInvalidReason"
+
 instance StrEncoding NtfTknStatus where
   strEncode = smpEncode
   strP = smpP

src/Simplex/Messaging/Notifications/Server.hs

@@ -58,6 +58,7 @@ import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Control (CPClientRole (..))
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate)
 import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -115,10 +116,12 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
 
     stopServer :: M ()
     stopServer = do
+      logInfo "Saving server state..."
       saveServer
       NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber
       liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread))
       liftIO $ closeSMPClientAgent smpAgent
+      logInfo "Server stopped"
 
     saveServer :: M ()
     saveServer = withNtfLog closeStoreLog >> saveServerLastNtfs >> saveServerStats
@@ -133,7 +136,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       logInfo $ "server stats log enabled: " <> T.pack statsFilePath
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
+      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, tknReplaced, subCreated, subDeleted, ntfReceived, ntfDelivered, ntfFailed, ntfCronDelivered, ntfCronFailed, ntfVrfQueued, ntfVrfDelivered, ntfVrfFailed, ntfVrfInvalidTkn, activeTokens, activeSubs} <-
+        asks serverStats
       let interval = 1000000 * logInterval
       forever $ do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -143,10 +147,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
           tknCreated' <- atomicSwapIORef tknCreated 0
           tknVerified' <- atomicSwapIORef tknVerified 0
           tknDeleted' <- atomicSwapIORef tknDeleted 0
+          tknReplaced' <- atomicSwapIORef tknReplaced 0
           subCreated' <- atomicSwapIORef subCreated 0
           subDeleted' <- atomicSwapIORef subDeleted 0
           ntfReceived' <- atomicSwapIORef ntfReceived 0
           ntfDelivered' <- atomicSwapIORef ntfDelivered 0
+          ntfFailed' <- atomicSwapIORef ntfFailed 0
+          ntfCronDelivered' <- atomicSwapIORef ntfCronDelivered 0
+          ntfCronFailed' <- atomicSwapIORef ntfCronFailed 0
+          ntfVrfQueued' <- atomicSwapIORef ntfVrfQueued 0
+          ntfVrfDelivered' <- atomicSwapIORef ntfVrfDelivered 0
+          ntfVrfFailed' <- atomicSwapIORef ntfVrfFailed 0
+          ntfVrfInvalidTkn' <- atomicSwapIORef ntfVrfInvalidTkn 0
           tkn <- liftIO $ periodStatCounts activeTokens ts
           sub <- liftIO $ periodStatCounts activeSubs ts
           hPutStrLn h $
@@ -165,7 +177,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
                 monthCount tkn,
                 dayCount sub,
                 weekCount sub,
-                monthCount sub
+                monthCount sub,
+                show tknReplaced',
+                show ntfFailed',
+                show ntfCronDelivered',
+                show ntfCronFailed',
+                show ntfVrfQueued',
+                show ntfVrfDelivered',
+                show ntfVrfFailed',
+                show ntfVrfInvalidTkn'
               ]
         liftIO $ threadDelay' interval
 
@@ -222,9 +242,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
                 putStat "tknCreated" tknCreated
                 putStat "tknVerified" tknVerified
                 putStat "tknDeleted" tknDeleted
+                putStat "tknReplaced" tknReplaced
                 putStat "subCreated" subCreated
                 putStat "subDeleted" subDeleted
                 putStat "ntfReceived" ntfReceived
+                putStat "ntfDelivered" ntfDelivered
+                putStat "ntfFailed" ntfFailed
+                putStat "ntfCronDelivered" ntfCronDelivered
+                putStat "ntfCronFailed" ntfCronFailed
+                putStat "ntfVrfQueued" ntfVrfQueued
+                putStat "ntfVrfDelivered" ntfVrfDelivered
+                putStat "ntfVrfFailed" ntfVrfFailed
+                putStat "ntfVrfInvalidTkn" ntfVrfInvalidTkn
                 getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v)
                 getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v)
               CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h)
@@ -239,15 +268,19 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
 #else
                   hPutStrLn h "Threads: not available on GHC 8.10"
 #endif
-                  NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber
+                  NtfEnv {subscriber, pushServer} <-  unliftIO u ask
+                  let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber
+                      NtfPushServer {pushQ} = pushServer
+                      SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
                   putSMPWorkers a "SMP subcscribers" smpSubscribers
-                  let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
                   putSMPWorkers a "SMP clients" smpClients
                   putSMPWorkers a "SMP subscription workers" smpSubWorkers
                   sessions <- readTVarIO smpSessions
                   hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions)
                   putSMPSubs a "SMP subscriptions" srvSubs
                   putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs
+                  sz <- atomically $ lengthTBQueue pushQ
+                  hPutStrLn h $ "Push notifications queue length: " <> show sz
                   where
                     putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO ()
                     putSMPSubs a name v = do
@@ -429,35 +462,35 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  (tkn@NtfTknData {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
   liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   status <- readTVarIO tknStatus
   case ntf of
-    PNVerification _
-      | status /= NTInvalid && status /= NTExpired ->
-          deliverNotification pp tkn ntf >>= \case
-            Right _ -> do
-              status_ <- atomically $ stateTVar tknStatus $ \case
-                NTActive -> (Nothing, NTActive)
-                NTConfirmed -> (Nothing, NTConfirmed)
-                _ -> (Just NTConfirmed, NTConfirmed)
-              forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
-            _ -> pure ()
-      | otherwise -> logError "bad notification token status"
+    PNVerification _ ->
+      deliverNotification pp tkn ntf >>= \case
+        Right _ -> do
+          status_ <- atomically $ stateTVar tknStatus $ \case
+            NTActive -> (Nothing, NTActive)
+            NTConfirmed -> (Nothing, NTConfirmed)
+            _ -> (Just NTConfirmed, NTConfirmed)
+          forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
+          incNtfStatT t ntfVrfDelivered
+        Left _ -> incNtfStatT t ntfVrfFailed
     PNCheckMessages -> checkActiveTkn status $ do
-      void $ deliverNotification pp tkn ntf
+      deliverNotification pp tkn ntf
+        >>= incNtfStatT t . (\case Left _ -> ntfCronFailed; Right () -> ntfCronDelivered)
     PNMessage {} -> checkActiveTkn status $ do
       stats <- asks serverStats
       liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
-      void $ deliverNotification pp tkn ntf
-      incNtfStat ntfDelivered
+      deliverNotification pp tkn ntf
+        >>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered)
   where
     checkActiveTkn :: NtfTknStatus -> M () -> M ()
     checkActiveTkn status action
       | status == NTActive = action
       | otherwise = liftIO $ logError "bad notification token status"
     deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ())
-    deliverNotification pp tkn ntf = do
+    deliverNotification pp tkn@NtfTknData {ntfTknId} ntf = do
       deliver <- liftIO $ getPushClient s pp
       liftIO (runExceptT $ deliver tkn ntf) >>= \case
         Right _ -> pure $ Right ()
@@ -465,15 +498,19 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
           PPConnection _ -> retryDeliver
           PPRetryLater -> retryDeliver
           PPCryptoError _ -> err e
-          PPResponseError _ _ -> err e
-          PPTokenInvalid -> updateTknStatus tkn NTInvalid >> err e
+          PPResponseError {} -> err e
+          PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e
           PPPermanentError -> err e
       where
         retryDeliver :: M (Either PushProviderError ())
         retryDeliver = do
           deliver <- liftIO $ newPushClient s pp
-          liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
-        err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
+          liftIO (runExceptT $ deliver tkn ntf) >>= \case
+            Right _ -> pure $ Right ()
+            Left e -> case e of
+              PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e
+              _ -> err e
+        err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e
 
 updateTknStatus :: NtfTknData -> NtfTknStatus -> M ()
 updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
@@ -507,13 +544,17 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ
   where
     cmdAction t@(_, _, (corrId, entId, cmdOrError)) =
       case cmdOrError of
-        Left e -> pure $ Left (corrId, entId, NRErr e)
+        Left e -> do
+          logError $ "invalid client request: " <> tshow e
+          pure $ Left (corrId, entId, NRErr e)
         Right cmd ->
-          verified <$> verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd
+          verified =<< verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd
           where
             verified = \case
-              VRVerified req -> Right req
-              VRFailed -> Left (corrId, entId, NRErr AUTH)
+              VRVerified req -> pure $ Right req
+              VRFailed -> do
+                logError "unauthorized client request"
+                pure $ Left (corrId, entId, NRErr AUTH)
     write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
 send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
@@ -522,7 +563,7 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
   void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
   atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
 
-data VerificationResult = VRVerified NtfRequest | VRFailed
+data VerificationResult = VRVerified (Maybe NtfTknData, NtfRequest) | VRFailed
 
 verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
 verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
@@ -536,34 +577,34 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
             Just t@NtfTknData {tknVerifyKey}
               | k == tknVerifyKey -> verifiedTknCmd t c
               | otherwise -> VRFailed
-            _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn))
+            Nothing -> VRVerified (Nothing, NtfReqNew corrId (ANE SToken tkn))
           else VRFailed
     NtfCmd SToken c -> do
-      t_ <- atomically $ getNtfToken st entId
+      t_ <- liftIO $ getNtfTokenIO st entId
       verifyToken t_ (`verifiedTknCmd` c)
     NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> do
       s_ <- atomically $ findNtfSubscription st smpQueue
       case s_ of
         Nothing -> do
           t_ <- atomically $ getActiveNtfToken st tknId
-          verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
+          verifyToken' t_ $ VRVerified (t_, NtfReqNew corrId (ANE SSubscription sub))
         Just s@NtfSubData {tokenId = subTknId} ->
           if subTknId == tknId
             then do
               t_ <- atomically $ getActiveNtfToken st subTknId
-              verifyToken' t_ $ verifiedSubCmd s c
+              verifyToken' t_ $ verifiedSubCmd t_ s c
             else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
-    NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId
+    NtfCmd SSubscription PING -> pure $ VRVerified (Nothing, NtfReqPing corrId entId)
     NtfCmd SSubscription c -> do
-      s_ <- atomically $ getNtfSubscription st entId
+      s_ <- liftIO $ getNtfSubscriptionIO st entId
       case s_ of
         Just s@NtfSubData {tokenId = subTknId} -> do
           t_ <- atomically $ getActiveNtfToken st subTknId
-          verifyToken' t_ $ verifiedSubCmd s c
+          verifyToken' t_ $ verifiedSubCmd t_ s c
         _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
   where
-    verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
-    verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
+    verifiedTknCmd t c = VRVerified (Just t, NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
+    verifiedSubCmd t_ s c = VRVerified (t_, NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
     verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult
     verifyToken t_ positiveVerificationResult =
       pure $ case t_ of
@@ -577,11 +618,17 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
 
 client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
 client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
-  forever $
+  forever $ do
+    ts <- liftIO getSystemDate
     atomically (readTBQueue rcvQ)
-      >>= mapM processCommand
+      >>= mapM (\(tkn_, req) -> updateTokenDate ts tkn_ >> processCommand req)
       >>= atomically . writeTBQueue sndQ
   where
+    updateTokenDate :: RoundedSystemTime -> Maybe NtfTknData -> M ()
+    updateTokenDate ts' = mapM_ $ \NtfTknData {ntfTknId, tknUpdatedAt} -> do
+      let t' = Just ts'
+      t <- atomically $ swapTVar tknUpdatedAt t'
+      unless (t' == t) $ withNtfLog $ \s -> logUpdateTokenTime s ntfTknId ts'
     processCommand :: NtfRequest -> M (Transmission NtfResponse)
     processCommand = \case
       NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do
@@ -591,9 +638,11 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         let dhSecret = C.dh' dhPubKey srvDhPrivKey
         tknId <- getId
         regCode <- getRegCode
-        tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode
+        ts <- liftIO $ getSystemDate
+        tkn <- liftIO $ mkNtfTknData tknId newTkn ks dhSecret regCode ts
         atomically $ addNtfToken st tknId tkn
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
+        incNtfStatT token ntfVrfQueued
         withNtfLog (`logCreateToken` tkn)
         incNtfStatT token tknCreated
         pure (corrId, NoEntity, NRTknId tknId srvDhPubKey)
@@ -607,6 +656,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             if tknDhSecret == dhSecret
               then do
                 atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
+                incNtfStatT token ntfVrfQueued
                 pure $ NRTknId ntfTknId srvDhPubKey
               else pure $ NRErr AUTH
           TVFY code -- this allows repeated verification for cases when client connection dropped before server response
@@ -634,9 +684,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               let tkn' = tkn {token = token', tknRegCode = regCode}
               addNtfToken st tknId tkn'
               writeTBQueue pushQ (tkn', PNVerification regCode)
+            incNtfStatT token ntfVrfQueued
             withNtfLog $ \s -> logUpdateToken s tknId token' regCode
-            incNtfStatT token tknDeleted
-            incNtfStatT token tknCreated
+            incNtfStatT token tknReplaced
             pure NROk
           TDEL -> do
             logDebug "TDEL"

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

@@ -159,7 +159,7 @@ data NtfRequest
   | NtfReqPing CorrId NtfEntityId
 
 data NtfServerClient = NtfServerClient
-  { rcvQ :: TBQueue (NonEmpty NtfRequest),
+  { rcvQ :: TBQueue (NonEmpty (Maybe NtfTknData, NtfRequest)),
     sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)),
     ntfThParams :: THandleParams NTFVersion 'TServer,
     connected :: TVar Bool,

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

@@ -53,7 +53,9 @@ ntfServerCLI cfgPath logPath =
         True -> readIniFile iniFile >>= either exitError runServer
         _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      confirmOrExit
+        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+        "Server NOT deleted"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
@@ -152,7 +154,7 @@ ntfServerCLI cfgPath logPath =
               regCodeBytes = 32,
               clientQSize = 64,
               subQSize = 512,
-              pushQSize = 1048,
+              pushQSize = 16384,
               smpAgentCfg =
                 defaultSMPClientAgentConfig
                   { smpCfg =

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -308,7 +308,7 @@ data PushProviderError
   = PPConnection HTTP2ClientError
   | PPCryptoError C.CryptoError
   | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid
+  | PPTokenInvalid NTInvalidReason
   | PPRetryLater
   | PPPermanentError
   deriving (Show, Exception)
@@ -337,19 +337,20 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
     result status reason'
       | status == Just N.ok200 = pure ()
       | status == Just N.badRequest400 =
-          case reason' of
-            "BadDeviceToken" -> throwE PPTokenInvalid
-            "DeviceTokenNotForTopic" -> throwE PPTokenInvalid
-            "TopicDisallowed" -> throwE PPPermanentError
-            _ -> err status reason'
-      | status == Just N.forbidden403 = case reason' of
-          "ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed
-          "InvalidProviderToken" -> throwE PPPermanentError
-          _ -> err status reason'
-      | status == Just N.gone410 = throwE PPTokenInvalid
+          throwE $ case reason' of
+            "BadDeviceToken" -> PPTokenInvalid NTIRBadToken
+            "DeviceTokenNotForTopic" -> PPTokenInvalid NTIRTokenNotForTopic
+            "TopicDisallowed" -> PPPermanentError
+            _ -> PPResponseError status reason'
+      | status == Just N.forbidden403 = throwE $ case reason' of
+          "ExpiredProviderToken" -> PPPermanentError -- there should be no point retrying it as the token was refreshed
+          "InvalidProviderToken" -> PPPermanentError
+          _ -> PPResponseError status reason'
+      | status == Just N.gone410 = throwE $ case reason' of
+          "ExpiredToken" -> PPTokenInvalid NTIRExpiredToken
+          "Unregistered" -> PPTokenInvalid NTIRUnregistered
+          _ -> PPRetryLater
       | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater
       -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
-      | otherwise = err status reason'
-    err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
-    err s r = throwE $ PPResponseError s r
+      | otherwise = throwE $ PPResponseError status reason'
     liftHTTPS2 a = ExceptT $ first PPConnection <$> a

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

@@ -4,7 +4,7 @@
 
 module Simplex.Messaging.Notifications.Server.Stats where
 
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.IORef
@@ -17,10 +17,18 @@ data NtfServerStats = NtfServerStats
     tknCreated :: IORef Int,
     tknVerified :: IORef Int,
     tknDeleted :: IORef Int,
+    tknReplaced :: IORef Int,
     subCreated :: IORef Int,
     subDeleted :: IORef Int,
     ntfReceived :: IORef Int,
     ntfDelivered :: IORef Int,
+    ntfFailed :: IORef Int,
+    ntfCronDelivered :: IORef Int,
+    ntfCronFailed :: IORef Int,
+    ntfVrfQueued :: IORef Int,
+    ntfVrfDelivered :: IORef Int,
+    ntfVrfFailed :: IORef Int,
+    ntfVrfInvalidTkn :: IORef Int,
     activeTokens :: PeriodStats,
     activeSubs :: PeriodStats
   }
@@ -30,10 +38,18 @@ data NtfServerStatsData = NtfServerStatsData
     _tknCreated :: Int,
     _tknVerified :: Int,
     _tknDeleted :: Int,
+    _tknReplaced :: Int,
     _subCreated :: Int,
     _subDeleted :: Int,
     _ntfReceived :: Int,
     _ntfDelivered :: Int,
+    _ntfFailed :: Int,
+    _ntfCronDelivered :: Int,
+    _ntfCronFailed :: Int,
+    _ntfVrfQueued :: Int,
+    _ntfVrfDelivered :: Int,
+    _ntfVrfFailed :: Int,
+    _ntfVrfInvalidTkn :: Int,
     _activeTokens :: PeriodStatsData,
     _activeSubs :: PeriodStatsData
   }
@@ -44,13 +60,41 @@ newNtfServerStats ts = do
   tknCreated <- newIORef 0
   tknVerified <- newIORef 0
   tknDeleted <- newIORef 0
+  tknReplaced <- newIORef 0
   subCreated <- newIORef 0
   subDeleted <- newIORef 0
   ntfReceived <- newIORef 0
   ntfDelivered <- newIORef 0
+  ntfFailed <- newIORef 0
+  ntfCronDelivered <- newIORef 0
+  ntfCronFailed <- newIORef 0
+  ntfVrfQueued <- newIORef 0
+  ntfVrfDelivered <- newIORef 0
+  ntfVrfFailed <- newIORef 0
+  ntfVrfInvalidTkn <- newIORef 0
   activeTokens <- newPeriodStats
   activeSubs <- newPeriodStats
-  pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
+  pure
+    NtfServerStats
+      { fromTime,
+        tknCreated,
+        tknVerified,
+        tknDeleted,
+        tknReplaced,
+        subCreated,
+        subDeleted,
+        ntfReceived,
+        ntfDelivered,
+        ntfFailed,
+        ntfCronDelivered,
+        ntfCronFailed,
+        ntfVrfQueued,
+        ntfVrfDelivered,
+        ntfVrfFailed,
+        ntfVrfInvalidTkn,
+        activeTokens,
+        activeSubs
+      }
 
 getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData
 getNtfServerStatsData s@NtfServerStats {fromTime} = do
@@ -58,13 +102,41 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
   _tknCreated <- readIORef $ tknCreated s
   _tknVerified <- readIORef $ tknVerified s
   _tknDeleted <- readIORef $ tknDeleted s
+  _tknReplaced <- readIORef $ tknReplaced s
   _subCreated <- readIORef $ subCreated s
   _subDeleted <- readIORef $ subDeleted s
   _ntfReceived <- readIORef $ ntfReceived s
   _ntfDelivered <- readIORef $ ntfDelivered s
+  _ntfFailed <- readIORef $ ntfFailed s
+  _ntfCronDelivered <- readIORef $ ntfCronDelivered s
+  _ntfCronFailed <- readIORef $ ntfCronFailed s
+  _ntfVrfQueued <- readIORef $ ntfVrfQueued s
+  _ntfVrfDelivered <- readIORef $ ntfVrfDelivered s
+  _ntfVrfFailed <- readIORef $ ntfVrfFailed s
+  _ntfVrfInvalidTkn <- readIORef $ ntfVrfInvalidTkn s
   _activeTokens <- getPeriodStatsData $ activeTokens s
   _activeSubs <- getPeriodStatsData $ activeSubs s
-  pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
+  pure
+    NtfServerStatsData
+      { _fromTime,
+        _tknCreated,
+        _tknVerified,
+        _tknDeleted,
+        _tknReplaced,
+        _subCreated,
+        _subDeleted,
+        _ntfReceived,
+        _ntfDelivered,
+        _ntfFailed,
+        _ntfCronDelivered,
+        _ntfCronFailed,
+        _ntfVrfQueued,
+        _ntfVrfDelivered,
+        _ntfVrfFailed,
+        _ntfVrfInvalidTkn,
+        _activeTokens,
+        _activeSubs
+      }
 
 -- this function is not thread safe, it is used on server start only
 setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO ()
@@ -73,24 +145,60 @@ setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} =
   writeIORef (tknCreated s) $! _tknCreated d
   writeIORef (tknVerified s) $! _tknVerified d
   writeIORef (tknDeleted s) $! _tknDeleted d
+  writeIORef (tknReplaced s) $! _tknReplaced d
   writeIORef (subCreated s) $! _subCreated d
   writeIORef (subDeleted s) $! _subDeleted d
   writeIORef (ntfReceived s) $! _ntfReceived d
   writeIORef (ntfDelivered s) $! _ntfDelivered d
+  writeIORef (ntfFailed s) $! _ntfFailed d
+  writeIORef (ntfCronDelivered s) $! _ntfCronDelivered d
+  writeIORef (ntfCronFailed s) $! _ntfCronFailed d
+  writeIORef (ntfVrfQueued s) $! _ntfVrfQueued d
+  writeIORef (ntfVrfDelivered s) $! _ntfVrfDelivered d
+  writeIORef (ntfVrfFailed s) $! _ntfVrfFailed d
+  writeIORef (ntfVrfInvalidTkn s) $! _ntfVrfInvalidTkn d
   setPeriodStats (activeTokens s) (_activeTokens d)
   setPeriodStats (activeSubs s) (_activeSubs d)
 
 instance StrEncoding NtfServerStatsData where
-  strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
+  strEncode
+    NtfServerStatsData
+      { _fromTime,
+        _tknCreated,
+        _tknVerified,
+        _tknDeleted,
+        _tknReplaced,
+        _subCreated,
+        _subDeleted,
+        _ntfReceived,
+        _ntfDelivered,
+        _ntfFailed,
+        _ntfCronDelivered,
+        _ntfCronFailed,
+        _ntfVrfQueued,
+        _ntfVrfDelivered,
+        _ntfVrfFailed,
+        _ntfVrfInvalidTkn,
+        _activeTokens,
+        _activeSubs
+      } =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "tknCreated=" <> strEncode _tknCreated,
         "tknVerified=" <> strEncode _tknVerified,
         "tknDeleted=" <> strEncode _tknDeleted,
+        "tknReplaced=" <> strEncode _tknReplaced,
         "subCreated=" <> strEncode _subCreated,
         "subDeleted=" <> strEncode _subDeleted,
         "ntfReceived=" <> strEncode _ntfReceived,
         "ntfDelivered=" <> strEncode _ntfDelivered,
+        "ntfFailed=" <> strEncode _ntfFailed,
+        "ntfCronDelivered=" <> strEncode _ntfCronDelivered,
+        "ntfCronFailed=" <> strEncode _ntfCronFailed,
+        "ntfVrfQueued=" <> strEncode _ntfVrfQueued,
+        "ntfVrfDelivered=" <> strEncode _ntfVrfDelivered,
+        "ntfVrfFailed=" <> strEncode _ntfVrfFailed,
+        "ntfVrfInvalidTkn=" <> strEncode _ntfVrfInvalidTkn,
         "activeTokens:",
         strEncode _activeTokens,
         "activeSubs:",
@@ -101,12 +209,42 @@ instance StrEncoding NtfServerStatsData where
     _tknCreated <- "tknCreated=" *> strP <* A.endOfLine
     _tknVerified <- "tknVerified=" *> strP <* A.endOfLine
     _tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
+    _tknReplaced <- opt "tknReplaced="
     _subCreated <- "subCreated=" *> strP <* A.endOfLine
     _subDeleted <- "subDeleted=" *> strP <* A.endOfLine
     _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
     _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
+    _ntfFailed <- opt "ntfFailed="
+    _ntfCronDelivered <- opt "ntfCronDelivered="
+    _ntfCronFailed <- opt "ntfCronFailed="
+    _ntfVrfQueued <- opt "ntfVrfQueued="
+    _ntfVrfDelivered <- opt "ntfVrfDelivered="
+    _ntfVrfFailed <- opt "ntfVrfFailed="
+    _ntfVrfInvalidTkn <- opt "ntfVrfInvalidTkn="
     _ <- "activeTokens:" <* A.endOfLine
     _activeTokens <- strP <* A.endOfLine
     _ <- "activeSubs:" <* A.endOfLine
     _activeSubs <- strP <* optional A.endOfLine
-    pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
+    pure
+      NtfServerStatsData
+        { _fromTime,
+          _tknCreated,
+          _tknVerified,
+          _tknDeleted,
+          _tknReplaced,
+          _subCreated,
+          _subDeleted,
+          _ntfReceived,
+          _ntfDelivered,
+          _ntfFailed,
+          _ntfCronDelivered,
+          _ntfCronFailed,
+          _ntfVrfQueued,
+          _ntfVrfDelivered,
+          _ntfVrfFailed,
+          _ntfVrfInvalidTkn,
+          _activeTokens,
+          _activeSubs
+        }
+    where
+      opt s = A.string s *> strP <* A.endOfLine <|> pure 0

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

@@ -25,6 +25,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
@@ -57,14 +58,16 @@ data NtfTknData = NtfTknData
     tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
-    tknCronInterval :: TVar Word16
+    tknCronInterval :: TVar Word16,
+    tknUpdatedAt :: TVar (Maybe RoundedSystemTime)
   }
 
-mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
-mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
-  tknStatus <- newTVar NTRegistered
-  tknCronInterval <- newTVar 0
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
+mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData
+mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do
+  tknStatus <- newTVarIO NTRegistered
+  tknCronInterval <- newTVarIO 0
+  tknUpdatedAt <- newTVarIO $ Just ts
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
 data NtfSubData = NtfSubData
   { ntfSubId :: NtfSubscriptionId,
@@ -156,9 +159,8 @@ deleteTokenSubs st tknId = do
         $>>= \NtfSubData {smpQueue} ->
           TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
 
-getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
-getNtfSubscription st subId =
-  TM.lookup subId (subscriptions st)
+getNtfSubscriptionIO :: NtfStore -> NtfSubscriptionId -> IO (Maybe NtfSubData)
+getNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st)
 
 findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
 findNtfSubscription st smpQueue = do

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

@@ -16,6 +16,7 @@ module Simplex.Messaging.Notifications.Server.StoreLog
     logUpdateToken,
     logTokenCron,
     logDeleteToken,
+    logUpdateTokenTime,
     logCreateSubscription,
     logSubscriptionStatus,
     logDeleteSubscription,
@@ -23,6 +24,7 @@ module Simplex.Messaging.Notifications.Server.StoreLog
   )
 where
 
+import Control.Applicative (optional)
 import Control.Concurrent.STM
 import Control.Logger.Simple
 import Control.Monad
@@ -36,6 +38,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.IO
@@ -46,6 +49,7 @@ data NtfStoreLogRecord
   | UpdateToken NtfTokenId DeviceToken NtfRegCode
   | TokenCron NtfTokenId Word16
   | DeleteToken NtfTokenId
+  | UpdateTokenTime NtfTokenId RoundedSystemTime
   | CreateSubscription NtfSubRec
   | SubscriptionStatus NtfSubscriptionId NtfSubStatus
   | DeleteSubscription NtfSubscriptionId
@@ -59,21 +63,24 @@ data NtfTknRec = NtfTknRec
     tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
-    tknCronInterval :: Word16
+    tknCronInterval :: Word16,
+    tknUpdatedAt :: Maybe RoundedSystemTime
   }
   deriving (Show)
 
-mkTknData :: NtfTknRec -> STM NtfTknData
-mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- newTVar status
-  tknCronInterval <- newTVar cronInt
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
+mkTknData :: NtfTknRec -> IO NtfTknData
+mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- newTVarIO status
+  tknCronInterval <- newTVarIO cronInt
+  tknUpdatedAt <- newTVarIO updatedAt
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
-mkTknRec :: NtfTknData -> STM NtfTknRec
-mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- readTVar status
-  tknCronInterval <- readTVar cronInt
-  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
+mkTknRec :: NtfTknData -> IO NtfTknRec
+mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do
+  tknStatus <- readTVarIO status
+  tknCronInterval <- readTVarIO cronInt
+  tknUpdatedAt <- readTVarIO updatedAt
+  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
 data NtfSubRec = NtfSubRec
   { ntfSubId :: NtfSubscriptionId,
@@ -84,9 +91,9 @@ data NtfSubRec = NtfSubRec
   }
   deriving (Show)
 
-mkSubData :: NtfSubRec -> STM NtfSubData
+mkSubData :: NtfSubRec -> IO NtfSubData
 mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- newTVar status
+  subStatus <- newTVarIO status
   pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
 
 mkSubRec :: NtfSubData -> STM NtfSubRec
@@ -101,6 +108,7 @@ instance StrEncoding NtfStoreLogRecord where
     UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
     TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
     DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
+    UpdateTokenTime tknId ts -> strEncode (Str "TTIME", tknId, ts)
     CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
     SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
     DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
@@ -111,13 +119,14 @@ instance StrEncoding NtfStoreLogRecord where
         "TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
         "TCRON " *> (TokenCron <$> strP_ <*> strP),
         "TDELETE " *> (DeleteToken <$> strP),
+        "TTIME " *> (UpdateTokenTime <$> strP_ <*> strP),
         "SCREATE " *> (CreateSubscription <$> strP),
         "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
         "SDELETE " *> (DeleteSubscription <$> strP)
       ]
 
 instance StrEncoding NtfTknRec where
-  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} =
+  strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
     B.unwords
       [ "tknId=" <> strEncode ntfTknId,
         "token=" <> strEncode token,
@@ -128,6 +137,9 @@ instance StrEncoding NtfTknRec where
         "regCode=" <> strEncode tknRegCode,
         "cron=" <> strEncode tknCronInterval
       ]
+      <> maybe "" updatedAtStr tknUpdatedAt
+    where
+      updatedAtStr t = " updatedAt=" <> strEncode t
   strP = do
     ntfTknId <- "tknId=" *> strP_
     token <- "token=" *> strP_
@@ -137,7 +149,8 @@ instance StrEncoding NtfTknRec where
     tknDhSecret <- "dhSecret=" *> strP_
     tknRegCode <- "regCode=" *> strP_
     tknCronInterval <- "cron=" *> strP
-    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
+    tknUpdatedAt <- optional $ " updatedAt=" *> strP
+    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
 instance StrEncoding NtfSubRec where
   strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
@@ -161,7 +174,7 @@ logNtfStoreRecord = writeStoreLogRecord
 {-# INLINE logNtfStoreRecord #-}
 
 logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
-logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
+logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< mkTknRec tkn
 
 logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
 logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
@@ -175,6 +188,9 @@ logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
 logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
 logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
 
+logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO ()
+logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t
+
 logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
 logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
 
@@ -192,36 +208,39 @@ readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.read
   where
     addNtfLogRecord s = case strDecode s of
       Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
-      Right lr -> atomically $ case lr of
+      Right lr -> case lr of
         CreateToken r@NtfTknRec {ntfTknId} -> do
           tkn <- mkTknData r
-          addNtfToken st ntfTknId tkn
+          atomically $ addNtfToken st ntfTknId tkn
         TokenStatus tknId status -> do
-          tkn_ <- getNtfToken st tknId
+          tkn_ <- getNtfTokenIO st tknId
           forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
-            writeTVar tknStatus status
-            when (status == NTActive) $ void $ removeInactiveTokenRegistrations st tkn
-        UpdateToken tknId token' tknRegCode ->
-          getNtfToken st tknId
+            atomically $ writeTVar tknStatus status
+            when (status == NTActive) $ void $ atomically $ removeInactiveTokenRegistrations st tkn
+        UpdateToken tknId token' tknRegCode -> do
+          getNtfTokenIO st tknId
             >>= mapM_
               ( \tkn@NtfTknData {tknStatus} -> do
-                  removeTokenRegistration st tkn
-                  writeTVar tknStatus NTRegistered
-                  addNtfToken st tknId tkn {token = token', tknRegCode}
+                  atomically $ removeTokenRegistration st tkn
+                  atomically $ writeTVar tknStatus NTRegistered
+                  atomically $ addNtfToken st tknId tkn {token = token', tknRegCode}
               )
         TokenCron tknId cronInt ->
-          getNtfToken st tknId
-            >>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
+          getNtfTokenIO st tknId
+            >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
         DeleteToken tknId ->
-          void $ deleteNtfToken st tknId
+          atomically $ void $ deleteNtfToken st tknId
+        UpdateTokenTime tknId t ->
+          getNtfTokenIO st tknId
+            >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
         CreateSubscription r@NtfSubRec {ntfSubId} -> do
           sub <- mkSubData r
-          void $ addNtfSubscription st ntfSubId sub
-        SubscriptionStatus subId status ->
-          getNtfSubscription st subId
-            >>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
+          void $ atomically $ addNtfSubscription st ntfSubId sub
+        SubscriptionStatus subId status -> do
+          getNtfSubscriptionIO st subId
+            >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status)
         DeleteSubscription subId ->
-          deleteNtfSubscription st subId
+          atomically $ deleteNtfSubscription st subId
 
 writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
 writeNtfStore s NtfStore {tokens, subscriptions} = do

src/Simplex/Messaging/Notifications/Transport.hs

@@ -44,11 +44,14 @@ initialNTFVersion = VersionNTF 1
 authBatchCmdsNTFVersion :: VersionNTF
 authBatchCmdsNTFVersion = VersionNTF 2
 
+invalidReasonNTFVersion :: VersionNTF
+invalidReasonNTFVersion = VersionNTF 3
+
 currentClientNTFVersion :: VersionNTF
-currentClientNTFVersion = VersionNTF 2
+currentClientNTFVersion = VersionNTF 3
 
 currentServerNTFVersion :: VersionNTF
-currentServerNTFVersion = VersionNTF 2
+currentServerNTFVersion = VersionNTF 3
 
 supportedClientNTFVRange :: VersionRangeNTF
 supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
@@ -123,8 +126,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
             Nothing -> throwE TEVersion
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
-ntfClientHandshake c keyHash ntfVRange = do
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
+ntfClientHandshake c keyHash ntfVRange _proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
   if sessionId /= sessId

src/Simplex/Messaging/Notifications/Types.hs

@@ -9,13 +9,11 @@ module Simplex.Messaging.Notifications.Types where
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (UTCTime)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId)
+import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
 import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
 
 data NtfTknAction
@@ -41,7 +39,7 @@ instance Encoding NtfTknAction where
 
 instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
 
-instance ToField NtfTknAction where toField = toField . smpEncode
+instance ToField NtfTknAction where toField = toField . Binary . smpEncode
 
 data NtfToken = NtfToken
   { deviceToken :: DeviceToken,
@@ -119,7 +117,7 @@ instance Encoding NtfSubNTFAction where
 
 instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode
 
-instance ToField NtfSubNTFAction where toField = toField . smpEncode
+instance ToField NtfSubNTFAction where toField = toField . Binary . smpEncode
 
 data NtfSubSMPAction
   = NSASmpKey
@@ -138,7 +136,7 @@ instance Encoding NtfSubSMPAction where
 
 instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
 
-instance ToField NtfSubSMPAction where toField = toField . smpEncode
+instance ToField NtfSubSMPAction where toField = toField . Binary . smpEncode
 
 data NtfAgentSubStatus
   = -- | subscription started

src/Simplex/Messaging/Parsers.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 
@@ -15,15 +16,9 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum, toLower)
 import Data.String
-import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601 (parseISO8601)
-import Data.Typeable (Typeable)
-import Database.SQLite.Simple (ResultError (..), SQLData (..))
-import Database.SQLite.Simple.FromField (FieldParser, returnError)
-import Database.SQLite.Simple.Internal (Field (..))
-import Database.SQLite.Simple.Ok (Ok (Ok))
 import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
 import Text.Read (readMaybe)
 
@@ -70,29 +65,11 @@ parseRead2 = parseRead $ do
 
 wordEnd :: Char -> Bool
 wordEnd c = c == ' ' || c == '\n'
+{-# INLINE wordEnd #-}
 
 parseString :: (ByteString -> Either String a) -> (String -> a)
 parseString p = either error id . p . B.pack
 
-blobFieldParser :: Typeable k => Parser k -> FieldParser k
-blobFieldParser = blobFieldDecoder . parseAll
-
-blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
-blobFieldDecoder dec = \case
-  f@(Field (SQLBlob b) _) ->
-    case dec b of
-      Right k -> Ok k
-      Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
-  f -> returnError ConversionFailed f "expecting SQLBlob column type"
-
-fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
-fromTextField_ fromText = \case
-  f@(Field (SQLText t) _) ->
-    case fromText t of
-      Just x -> Ok x
-      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
-  f -> returnError ConversionFailed f "expecting SQLText column type"
-
 fstToLower :: String -> String
 fstToLower "" = ""
 fstToLower (h : t) = toLower h : t

src/Simplex/Messaging/Protocol.hs

@@ -70,6 +70,8 @@ module Simplex.Messaging.Protocol
     CommandError (..),
     ProxyError (..),
     BrokerErrorType (..),
+    BlockingInfo (..),
+    BlockingReason (..),
     Transmission,
     TransmissionAuth (..),
     SignedTransmission,
@@ -258,7 +260,7 @@ supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClie
 -- TODO v6.0 remove dependency on version
 maxMessageLength :: VersionSMP -> Int
 maxMessageLength v
-  | v >= encryptedBlockSMPVersion = 16048 -- max 16051
+  | v >= encryptedBlockSMPVersion = 16048 -- max 16048
   | v >= sendingProxySMPVersion = 16064 -- max 16067
   | otherwise = 16088 -- 16048 - always use this size to determine allowed ranges
 
@@ -399,8 +401,6 @@ data Command (p :: Party) where
   NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
   NDEL :: Command Recipient
   GET :: Command Recipient
-  -- ACK v1 has to be supported for encoding/decoding
-  -- ACK :: Command Recipient
   ACK :: MsgId -> Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
@@ -540,11 +540,13 @@ messageId :: Message -> MsgId
 messageId = \case
   Message {msgId} -> msgId
   MessageQuota {msgId} -> msgId
+{-# INLINE messageId #-}
 
 messageTs :: Message -> SystemTime
 messageTs = \case
   Message {msgTs} -> msgTs
   MessageQuota {msgTs} -> msgTs
+{-# INLINE messageTs #-}
 
 newtype EncRcvMsgBody = EncRcvMsgBody ByteString
   deriving (Eq, Show)
@@ -1194,6 +1196,8 @@ data ErrorType
     PROXY {proxyErr :: ProxyError}
   | -- | command authorization error - bad signature or non-existing SMP queue
     AUTH
+  | -- | command with the entity that was blocked
+    BLOCKED {blockInfo :: BlockingInfo}
   | -- | encryption/decryption error in proxy protocol
     CRYPTO
   | -- | SMP queue capacity is exceeded on the server
@@ -1210,17 +1214,41 @@ data ErrorType
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
     DUPLICATE_ -- not part of SMP protocol, used internally
-  deriving (Eq, Read, Show)
+  deriving (Eq, Show)
 
 instance StrEncoding ErrorType where
   strEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
     CMD e -> "CMD " <> bshow e
     PROXY e -> "PROXY " <> strEncode e
-    e -> bshow e
+    AUTH -> "AUTH"
+    BLOCKED info -> "BLOCKED " <> strEncode info
+    CRYPTO -> "CRYPTO"
+    QUOTA -> "QUOTA"
+    STORE e -> "STORE " <> encodeUtf8 (T.pack e)
+    NO_MSG -> "NO_MSG"
+    LARGE_MSG -> "LARGE_MSG"
+    EXPIRED -> "EXPIRED"
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
   strP =
-    "CMD " *> (CMD <$> parseRead1)
-      <|> "PROXY " *> (PROXY <$> strP)
-      <|> parseRead1
+    A.choice
+      [ "BLOCK" $> BLOCK,
+        "SESSION" $> SESSION,
+        "CMD " *> (CMD <$> parseRead1),
+        "PROXY " *> (PROXY <$> strP),
+        "AUTH" $> AUTH,
+        "BLOCKED " *> strP,
+        "CRYPTO" $> CRYPTO,
+        "QUOTA" $> QUOTA,
+        "STORE " *> (STORE . T.unpack . safeDecodeUtf8 <$> A.takeByteString),
+        "NO_MSG" $> NO_MSG,
+        "LARGE_MSG" $> LARGE_MSG,
+        "EXPIRED" $> EXPIRED,
+        "INTERNAL" $> INTERNAL,
+        "DUPLICATE_" $> DUPLICATE_
+      ]
 
 -- | SMP command error type.
 data CommandError
@@ -1248,7 +1276,7 @@ data ProxyError
     BASIC_AUTH
   | -- no destination server error
     NO_SESSION
-  deriving (Eq, Read, Show)
+  deriving (Eq, Show)
 
 -- | SMP server errors.
 data BrokerErrorType
@@ -1266,6 +1294,37 @@ data BrokerErrorType
     TIMEOUT
   deriving (Eq, Read, Show, Exception)
 
+data BlockingInfo = BlockingInfo
+  { reason :: BlockingReason
+  }
+  deriving (Eq, Show)
+
+data BlockingReason = BRSpam | BRContent
+  deriving (Eq, Show)
+
+instance StrEncoding BlockingInfo where
+  strEncode BlockingInfo {reason} = "reason=" <> strEncode reason
+  strP = do
+    reason <- "reason=" *> strP
+    pure BlockingInfo {reason}
+
+instance Encoding BlockingInfo where
+  smpEncode = strEncode
+  smpP = strP
+
+instance StrEncoding BlockingReason where
+  strEncode = \case
+    BRSpam -> "spam"
+    BRContent -> "content"
+  strP = "spam" $> BRSpam <|> "content" $> BRContent
+
+instance ToJSON BlockingReason where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON BlockingReason where
+  parseJSON = strParseJSON "BlockingReason"
+
 -- | SMP transmission parser.
 transmissionP :: THandleParams v p -> Parser RawTransmission
 transmissionP THandleParams {sessionId, implySessId} = do
@@ -1284,7 +1343,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
 class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
+  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
@@ -1311,9 +1370,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   encodeProtocol v = \case
     NEW rKey dhKey auth_ subMode sndSecure
       | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure)
-      | v >= subModeSMPVersion -> new <> auth <> e subMode
-      | v == basicAuthSMPVersion -> new <> auth
-      | otherwise -> new
+      | otherwise -> new <> auth <> e subMode
       where
         new = e (NEW_, ' ', rKey, dhKey)
         auth = maybe "" (e . ('A',)) auth_
@@ -1382,9 +1439,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
       Cmd SRecipient <$> case tag of
         NEW_
           | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP
-          | v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False
-          | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False
-          | otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False
+          | otherwise -> new <*> auth <*> smpP <*> pure False
           where
             new = NEW <$> _smpP <*> smpP
             auth = optional (A.char 'A' *> smpP)
@@ -1435,7 +1490,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       | otherwise -> e END_
     INFO info -> e (INFO_, ' ', info)
     OK -> e OK_
-    ERR err -> e (ERR_, ' ', err)
+    ERR err -> case err of
+      BLOCKED _ | v < blockedEntitySMPVersion -> e (ERR_, ' ', AUTH)
+      _ -> e (ERR_, ' ', err)
     PONG -> e PONG_
     where
       e :: Encoding a => a -> ByteString
@@ -1513,6 +1570,7 @@ instance Encoding ErrorType where
     CMD err -> "CMD " <> smpEncode err
     PROXY err -> "PROXY " <> smpEncode err
     AUTH -> "AUTH"
+    BLOCKED info -> "BLOCKED " <> smpEncode info
     CRYPTO -> "CRYPTO"
     QUOTA -> "QUOTA"
     STORE err -> "STORE " <> smpEncode err
@@ -1529,6 +1587,7 @@ instance Encoding ErrorType where
       "CMD" -> CMD <$> _smpP
       "PROXY" -> PROXY <$> _smpP
       "AUTH" -> pure AUTH
+      "BLOCKED" -> BLOCKED <$> _smpP
       "CRYPTO" -> pure CRYPTO
       "QUOTA" -> pure QUOTA
       "STORE" -> STORE <$> _smpP
@@ -1763,5 +1822,7 @@ $(J.deriveJSON (sumTypeJSON id) ''CommandError)
 
 $(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
 
+$(J.deriveJSON defaultJSON ''BlockingInfo)
+
 -- run deriveJSON in one TH splice to allow mutual instance
 $(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType])

src/Simplex/Messaging/Server/CLI.hs

@@ -27,8 +27,11 @@ import qualified Data.X509.File as XF
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
+import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
+import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..))
+import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
@@ -44,11 +47,11 @@ import Text.Read (readMaybe)
 exitError :: String -> IO a
 exitError msg = putStrLn msg >> exitFailure
 
-confirmOrExit :: String -> IO ()
-confirmOrExit s =
+confirmOrExit :: String -> String -> IO ()
+confirmOrExit s no =
   withPrompt (s <> "\nContinue (Y/n): ") $ do
     ok <- getLine
-    when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
+    when (ok /= "Y") $ putStrLn no >> exitFailure
 
 data SignAlgorithm = ED448 | ED25519
   deriving (Read, Show)
@@ -296,10 +299,21 @@ printServerConfig transports logFile = do
   putStrLn $ case logFile of
     Just f -> "Store log: " <> f
     _ -> "Store log disabled."
-  forM_ transports $ \(p, ATransport t, addHTTP) -> do
-    let descr = p <> " (" <> transportName t <> ")..."
-    putStrLn $ "Serving SMP protocol on port " <> descr
-    when addHTTP $ putStrLn $ "Serving static site on port " <> descr
+  printServerTransports transports
+
+printServerTransports :: [(ServiceName, ATransport, AddHTTP)] -> IO ()
+printServerTransports = mapM_ $ \(p, ATransport t, addHTTP) -> do
+  let descr = p <> " (" <> transportName t <> ")..."
+  putStrLn $ "Serving SMP protocol on port " <> descr
+  when addHTTP $ putStrLn $ "Serving static site on port " <> descr
+
+printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
+printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
+  SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile
+  SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do
+    B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
+    printServerTransports transports
 
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

src/Simplex/Messaging/Server/Control.hs

@@ -5,7 +5,7 @@ module Simplex.Messaging.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth, SenderId)
+import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
 
 data CPClientRole = CPRNone | CPRUser | CPRAdmin
   deriving (Eq)
@@ -22,6 +22,9 @@ data ControlProtocol
   | CPSocketThreads
   | CPServerInfo
   | CPDelete SenderId
+  | CPStatus SenderId
+  | CPBlock SenderId BlockingInfo
+  | CPUnblock SenderId
   | CPSave
   | CPHelp
   | CPQuit
@@ -39,14 +42,17 @@ instance StrEncoding ControlProtocol where
     CPSockets -> "sockets"
     CPSocketThreads -> "socket-threads"
     CPServerInfo -> "server-info"
-    CPDelete bs -> "delete " <> strEncode bs
+    CPDelete sId -> "delete " <> strEncode sId
+    CPStatus sId -> "status " <> strEncode sId
+    CPBlock sId info -> "block " <> strEncode sId <> " " <> strEncode info
+    CPUnblock sId -> "unblock " <> strEncode sId
     CPSave -> "save"
     CPHelp -> "help"
     CPQuit -> "quit"
     CPSkip -> ""
   strP =
     A.takeTill (== ' ') >>= \case
-      "auth" -> CPAuth <$> (A.space *> strP)
+      "auth" -> CPAuth <$> _strP
       "suspend" -> pure CPSuspend
       "resume" -> pure CPResume
       "clients" -> pure CPClients
@@ -56,7 +62,10 @@ instance StrEncoding ControlProtocol where
       "sockets" -> pure CPSockets
       "socket-threads" -> pure CPSocketThreads
       "server-info" -> pure CPServerInfo
-      "delete" -> CPDelete <$> (A.space *> strP)
+      "delete" -> CPDelete <$> _strP
+      "status" -> CPStatus <$> _strP
+      "block" -> CPBlock <$> _strP <*> _strP
+      "unblock" -> CPUnblock <$> _strP
       "save" -> pure CPSave
       "help" -> pure CPHelp
       "quit" -> pure CPQuit

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

@@ -1,10 +1,22 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+#if __GLASGOW_HASKELL__ == 810
+{-# LANGUAGE UndecidableInstances #-}
+#endif
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -17,30 +29,39 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
+import Data.Kind (Constraint)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
-import Data.Maybe (isJust, isNothing)
+import Data.Maybe (isJust)
 import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (getCurrentTime, nominalDay)
 import Data.Time.Clock.System (SystemTime)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
+import GHC.TypeLits (TypeError)
+import qualified GHC.TypeLits as TE
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural
 import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent)
 import Simplex.Messaging.Crypto (KeyHash (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
+import Simplex.Messaging.Server.MsgStore.Journal
 import Simplex.Messaging.Server.MsgStore.STM
+import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
-import Simplex.Messaging.Server.QueueStore (QueueRec (..))
-import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Postgres.Config
+import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore, setStoreLog)
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.Server.StoreLog.ReadWrite
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
@@ -56,10 +77,11 @@ data ServerConfig = ServerConfig
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
     msgQueueQuota :: Int,
+    maxJournalMsgCount :: Int,
+    maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    storeLogFile :: Maybe FilePath,
-    storeMsgsFile :: Maybe FilePath,
+    serverStoreCfg :: AServerStoreCfg,
     storeNtfsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
@@ -70,6 +92,9 @@ data ServerConfig = ServerConfig
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
+    expireMessagesOnStart :: Bool,
+    -- | interval of inactivity after which journal queue is closed
+    idleQueueInterval :: Int64,
     -- | notification expiration interval (seconds)
     notificationExpiration :: ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -84,6 +109,9 @@ data ServerConfig = ServerConfig
     serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
     serverStatsBackupFile :: Maybe FilePath,
+    -- | interval and file to save prometheus metrics
+    prometheusInterval :: Maybe Int,
+    prometheusMetricsFile :: FilePath,
     -- | notification delivery interval
     ntfDeliveryInterval :: Int,
     -- | interval between sending pending END events to unsubscribed clients, seconds
@@ -101,7 +129,15 @@ data ServerConfig = ServerConfig
     allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth`
     serverClientConcurrency :: Int,
     -- | server public information
-    information :: Maybe ServerPublicInfo
+    information :: Maybe ServerPublicInfo,
+    startOptions :: StartOptions
+  }
+
+data StartOptions = StartOptions
+  { maintenance :: Bool,
+    compactLog :: Bool,
+    skipWarnings :: Bool,
+    confirmMigrations :: MigrationConfirmation
   }
 
 defMsgExpirationDays :: Int64
@@ -111,9 +147,12 @@ defaultMessageExpiration :: ExpirationConfig
 defaultMessageExpiration =
   ExpirationConfig
     { ttl = defMsgExpirationDays * 86400, -- seconds
-      checkInterval = 43200 -- seconds, 12 hours
+      checkInterval = 7200 -- seconds, 2 hours
     }
 
+defaultIdleQueueInterval :: Int64
+defaultIdleQueueInterval = 14400 -- seconds, 4 hours
+
 defNtfExpirationHours :: Int64
 defNtfExpirationHours = 24
 
@@ -134,35 +173,74 @@ defaultInactiveClientExpiration =
 defaultProxyClientConcurrency :: Int
 defaultProxyClientConcurrency = 32
 
+journalMsgStoreDepth :: Int
+journalMsgStoreDepth = 5
+
+defaultMaxJournalStateLines :: Int
+defaultMaxJournalStateLines = 16
+
+defaultMaxJournalMsgCount :: Int
+defaultMaxJournalMsgCount = 256
+
+defaultMsgQueueQuota :: Int
+defaultMsgQueueQuota = 128
+
+defaultStateTailSize :: Int
+defaultStateTailSize = 512
+
 data Env = Env
   { config :: ServerConfig,
     serverActive :: TVar Bool,
     serverInfo :: ServerInformation,
     server :: Server,
     serverIdentity :: KeyHash,
-    queueStore :: QueueStore,
-    msgStore :: STMMsgStore,
+    msgStore :: AMsgStore,
     ntfStore :: NtfStore,
     random :: TVar ChaChaDRG,
-    storeLog :: Maybe (StoreLog 'WriteMode),
     tlsServerCreds :: T.Credential,
     httpServerCreds :: Maybe T.Credential,
     serverStats :: ServerStats,
     sockets :: TVar [(ServiceName, SocketState)],
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe Client)),
+    clients :: TVar (IntMap (Maybe AClient)),
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
+type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
+  SupportedStore 'QSMemory 'MSMemory = ()
+  SupportedStore 'QSMemory 'MSJournal = ()
+  SupportedStore 'QSPostgres 'MSJournal = ()
+  SupportedStore 'QSPostgres 'MSMemory =
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported"))
+
+data AStoreType = forall qs ms. SupportedStore qs ms => ASType (SQSType qs) (SMSType ms)
+
+data ServerStoreCfg qs ms where
+  SSCMemory :: Maybe StorePaths -> ServerStoreCfg 'QSMemory 'MSMemory
+  SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg 'QSMemory 'MSJournal
+  SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal
+
+data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath}
+
+data AServerStoreCfg = forall qs ms. SupportedStore qs ms => ASSCfg (SQSType qs) (SMSType ms) (ServerStoreCfg qs ms)
+
+type family MsgStore (qs :: QSType) (ms :: MSType) where
+  MsgStore 'QSMemory 'MSMemory = STMMsgStore
+  MsgStore qs 'MSJournal = JournalMsgStore qs
+
+data AMsgStore =
+  forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStore qs ms)) =>
+  AMS (SQSType qs) (SMSType ms) (MsgStore qs ms)
+
 type Subscribed = Bool
 
 data Server = Server
   { subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
-    subscribers :: TMap RecipientId (TVar Client),
+    subscribers :: TMap RecipientId (TVar AClient),
     ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
-    notifiers :: TMap NotifierId (TVar Client),
-    subClients :: TVar (IntMap Client), -- clients with SMP subscriptions
-    ntfSubClients :: TVar (IntMap Client), -- clients with Ntf subscriptions
+    notifiers :: TMap NotifierId (TVar AClient),
+    subClients :: TVar (IntMap AClient), -- clients with SMP subscriptions
+    ntfSubClients :: TVar (IntMap AClient), -- clients with Ntf subscriptions
     pendingSubEvents :: TVar (IntMap (NonEmpty (RecipientId, Subscribed))),
     pendingNtfSubEvents :: TVar (IntMap (NonEmpty (NotifierId, Subscribed))),
     savingLock :: Lock
@@ -174,11 +252,17 @@ newtype ProxyAgent = ProxyAgent
 
 type ClientId = Int
 
-data Client = Client
+data AClient = forall qs ms. MsgStoreClass (MsgStore qs ms) => AClient (SQSType qs) (SMSType ms) (Client (MsgStore qs ms))
+
+clientId' :: AClient -> ClientId
+clientId' (AClient _ _ Client {clientId}) = clientId
+{-# INLINE clientId' #-}
+
+data Client s = Client
   { clientId :: ClientId,
     subscriptions :: TMap RecipientId Sub,
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
+    rcvQ :: TBQueue (NonEmpty (Maybe (StoreQueue s, QueueRec), Transmission Cmd)),
     sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
@@ -211,11 +295,11 @@ newServer = do
   ntfSubClients <- newTVarIO IM.empty
   pendingSubEvents <- newTVarIO IM.empty
   pendingNtfSubEvents <- newTVarIO IM.empty
-  savingLock <- atomically createLock
+  savingLock <- createLockIO
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
 
-newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
-newClient clientId qSize thVersion sessionId createdAt = do
+newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms))
+newClient _ _ clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   rcvQ <- newTBQueueIO qSize
@@ -241,17 +325,34 @@ newProhibitedSub = do
   return Sub {subThread = ProhibitSub, delivered}
 
 newEnv :: ServerConfig -> IO Env
-newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
+newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
   serverActive <- newTVarIO True
   server <- newServer
-  queueStore <- newQueueStore
-  msgStore <- newMsgStore
+  msgStore <- case serverStoreCfg of
+    ASSCfg qt mt (SSCMemory storePaths_) -> do
+      let storePath = storeMsgsFile =<< storePaths_
+      ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota}
+      forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms
+      pure $ AMS qt mt ms
+    ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
+      let qsCfg = MQStoreCfg
+          cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
+      ms <- newMsgStore cfg
+      loadStoreLog (mkQueue ms) storeLogFile $ stmQueueStore ms
+      pure $ AMS qt mt ms
+#if defined(dbServerPostgres)
+    ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
+      let StartOptions {compactLog, confirmMigrations} = startOptions config
+          qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
+          cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
+      when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
+      ms <- newMsgStore cfg
+      pure $ AMS qt mt ms
+#else
+    ASSCfg _ _ SSCDatabaseJournal {} -> noPostgresExit
+#endif
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
-  storeLog <-
-    forM storeLogFile $ \f -> do
-      logInfo $ "restoring queues from file " <> T.pack f
-      readWriteQueueStore f queueStore
   tlsServerCreds <- getCredentials "SMP" smpCredentials
   httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
   mapM_ checkHTTPSCredentials httpServerCreds
@@ -262,8 +363,23 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg
   clientSeq <- newTVarIO 0
   clients <- newTVarIO mempty
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {serverActive, config, serverInfo, server, serverIdentity, queueStore, msgStore, ntfStore, random, storeLog, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
+  pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
   where
+    loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
+    loadStoreLog mkQ f st = do
+      logInfo $ "restoring queues from file " <> T.pack f
+      sl <- readWriteQueueStore False mkQ f st
+      setStoreLog st sl
+    compactDbStoreLog = \case
+      Just f -> do
+        logInfo $ "compacting queues in file " <> T.pack f
+        st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota}
+        sl <- readWriteQueueStore False (mkQueue st) f (queueStore st)
+        setStoreLog (queueStore st) sl
+        closeMsgStore st
+      Nothing -> do
+        logError "Error: `--compact-log` used without `db_store_log` INI option"
+        exitFailure
     getCredentials protocol creds = do
       files <- missingCreds
       unless (null files) $ do
@@ -297,12 +413,38 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg
               }
         }
       where
-        persistence
-          | isNothing storeLogFile = SPMMemoryOnly
-          | isJust (storeMsgsFile config) = SPMMessages
-          | otherwise = SPMQueues
+        persistence = case serverStoreCfg of
+          ASSCfg _ _ (SSCMemory sp_) -> case sp_ of
+            Nothing -> SPMMemoryOnly
+            Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
+            _ -> SPMQueues
+          _ -> SPMMessages
+
+noPostgresExit :: IO a
+noPostgresExit = do
+  putStrLn "Error: server binary is compiled without support for PostgreSQL database."
+  putStrLn "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
+  exitFailure
+
+mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
+mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
+  JournalStoreConfig
+    { storePath,
+      quota = msgQueueQuota,
+      pathParts = journalMsgStoreDepth,
+      queueStoreCfg,
+      maxMsgCount = maxJournalMsgCount,
+      maxStateLines = maxJournalStateLines,
+      stateTailSize = defaultStateTailSize,
+      idleInterval = idleQueueInterval,
+      expireBackupsAfter = 14 * nominalDay,
+      keepMinBackups = 2
+    }
 
 newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}
+
+readWriteQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO (StoreLog 'WriteMode)
+readWriteQueueStore tty mkQ = readWriteStoreLog (readQueueStore tty mkQ) (writeQueueStore @q)

src/Simplex/Messaging/Server/Main.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -20,6 +23,7 @@ import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlpha, isAscii, toUpper)
+import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.List (find, isPrefixOf)
@@ -27,33 +31,50 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8, decodeLatin1)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import qualified Data.Text.IO as T
-import Network.Socket (HostName)
 import Options.Applicative
 import Simplex.Messaging.Agent.Protocol (connReqUriP')
+import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
-import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
+import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange)
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
+import Simplex.Messaging.Server.Main.Init
+import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
+import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
+import Simplex.Messaging.Server.QueueStore.Postgres.Config
+import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
+import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
-import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
-import Simplex.Messaging.Version (mkVersionRange)
-import System.Directory (createDirectoryIfMissing, doesFileExist)
+import Simplex.Messaging.Util (eitherToMaybe, ifM)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
+#if defined(dbServerPostgres)
+import Data.Semigroup (Sum (..))
+import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
+import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
+import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
+import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs)
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue, openWriteStoreLog)
+import System.Directory (renameFile)
+#endif
+
 smpServerCLI :: FilePath -> FilePath -> IO ()
 smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")
 
@@ -70,31 +91,190 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
-    OnlineCert certOpts ->
-      doesFileExist iniFile >>= \case
-        True -> genOnline cfgPath certOpts
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts
+    Start opts -> withIniFile $ runServer opts
     Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      confirmOrExit
+        "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+        "Server NOT deleted"
       deleteDirIfExists cfgPath
       deleteDirIfExists logPath
       putStrLn "Deleted configuration and log files"
+    Journal cmd -> withIniFile $ \ini -> do
+      msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
+      msgsFileExists <- doesFileExist storeMsgsFilePath
+      storeLogFile <- getRequiredStoreLogFile ini
+      case cmd of
+        SCImport
+          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+          | msgsDirExists -> do
+              putStrLn $ storeMsgsJournalDir <> " directory already exists."
+              exitFailure
+          | not msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
+                "Messages not imported"
+              ms <- newJournalMsgStore MQStoreCfg
+              readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
+              msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
+              putStrLn "Import completed"
+              printMessageStats "Messages" msgStats
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
+                Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
+                Left e -> e <> ", configure storage correctly"
+        SCExport
+          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+          | msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
+                "Journal not exported"
+              ms <- newJournalMsgStore MQStoreCfg
+              -- TODO [postgres] in case postgres configured, queues must be read from database
+              readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
+              exportMessages True ms storeMsgsFilePath False
+              putStrLn "Export completed"
+              case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> putStrLn "store_messages set to `memory`, start the server."
+                Right (ASType SQSMemory SMSJournal) -> putStrLn "store_messages set to `journal`, update it to `memory` in INI file"
+                Right (ASType SQSPostgres SMSJournal) -> 
+#if defined(dbServerPostgres)
+                  putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
+#else
+                  noPostgresExit
+#endif
+                Left e -> putStrLn $ e <> ", configure storage correctly"
+        SCDelete
+          | not msgsDirExists -> do
+              putStrLn $ storeMsgsJournalDir <> " directory does not exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
+                "Messages NOT deleted"
+              deleteDirIfExists storeMsgsJournalDir
+              putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
+#if defined(dbServerPostgres)              
+    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+      schemaExists <- checkSchemaExists connstr schema
+      storeLogExists <- doesFileExist storeLogFilePath
+      case cmd of
+        SCImport
+          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
+          | schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | not storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              storeLogFile <- getRequiredStoreLogFile ini
+              confirmOrExit
+                ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Queue records not imported"
+              ms <- newJournalMsgStore MQStoreCfg
+              sl <- readWriteQueueStore True (mkQueue ms) storeLogFile (queueStore ms)
+              closeStoreLog sl
+              queues <- readTVarIO $ loadedQueues $ stmQueueStore ms
+              let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
+              ps <- newJournalMsgStore $ PQStoreCfg storeCfg
+              qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
+              renameFile storeLogFile $ storeLogFile <> ".bak"
+              putStrLn $ "Import completed: " <> show qCnt <> " queues"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
+                Right (ASType SQSMemory SMSJournal) -> setToDbStr
+                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server."
+                Left e -> e <> ", configure storage correctly"
+          where
+            setToDbStr :: String
+            setToDbStr = "store_queues set to `memory`, update it to `database` in INI file"
+        SCExport
+          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                "Queue records not exported"
+              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
+              ps <- newJournalMsgStore $ PQStoreCfg storeCfg
+              sl <- openWriteStoreLog False storeLogFilePath
+              Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
+              putStrLn $ "Export completed: " <> show qCnt <> " queues"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
+                Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
+                Left e -> e <> ", configure storage correctly"
+        SCDelete
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | otherwise -> do
+              putStrLn $ "Open database: psql " <> B.unpack connstr
+              putStrLn $ "Delete schema: DROP SCHEMA " <> B.unpack schema <> " CASCADE;"
+#else
+    Database {} -> noPostgresExit
+#endif
   where
+    withIniFile a =
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError a
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    getRequiredStoreLogFile ini = do
+      case enableStoreLog' ini $> storeLogFilePath of
+        Just storeLogFile -> do
+          ifM
+            (doesFileExist storeLogFile)
+            (pure storeLogFile)
+            (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
+        Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
+    newJournalMsgStore :: QStoreCfg s -> IO (JournalMsgStore s)
+    newJournalMsgStore qsCfg =
+      let cfg = mkJournalStoreConfig qsCfg storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
+       in newMsgStore cfg
     iniFile = combine cfgPath "smp-server.ini"
     serverVersion = "SMP server v" <> simplexMQVersion
-    defaultServerPorts = "5223,443"
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
-    httpsCertFile = combine cfgPath "web.crt"
-    httpsKeyFile = combine cfgPath "web.key"
+    storeMsgsFilePath = combine logPath "smp-server-messages.log"
+    storeMsgsJournalDir = combine logPath "messages"
+    storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
+    readStoreType :: Ini -> Either String AStoreType
+    readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
+      ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
+      ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
+      ("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
+      ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
+      (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
+      where
+        iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
+        iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
+    iniDBOptions ini =
+      DBOpts
+        { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
+          schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
+          poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini,
+          createSchema = False
+        }
+    iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
     defaultStaticPath = combine logPath "www"
-    initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted}
-      | scripted = initialize opts
+    enableStoreLog' = settingIsOn "STORE_LOG" "enable"
+    enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
+    initializeServer opts
+      | scripted opts = initialize opts
       | otherwise = do
+          let InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb'} = opts
           putStrLn "Use `smp-server init -h` for available options."
           checkInitOptions opts
           void $ withPrompt "SMP server will be initialized (press Enter)" getLine
@@ -128,7 +308,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
         checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do
           let err_
-                | isNothing sourceCode && hasServerInfo serverInfo = 
+                | isNothing sourceCode && hasServerInfo serverInfo =
                     Just "Error: passing any server information requires passing --source-code"
                 | isNothing (operator serverInfo) && isJust operatorCountry =
                     Just "Error: passing --operator-country requires passing --operator"
@@ -136,7 +316,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     Just "Error: passing --hosting-country requires passing --hosting"
                 | otherwise = Nothing
           forM_ err_ $ \err -> putStrLn err >> exitFailure
-        initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
+        initialize opts'@InitOptions {ip, fqdn, signAlgorithm, password, controlPort, sourceCode} = do
           checkInitOptions opts'
           clearDirIfExists cfgPath
           clearDirIfExists logPath
@@ -148,7 +328,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd
           let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
               srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
-          T.writeFile iniFile $ iniFileContent host basicAuth controlPortPwds
+          T.writeFile iniFile $ iniFileContent cfgPath logPath opts' host basicAuth controlPortPwds
           putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "."
           putStrLn $ "Run `" <> executableName <> " start` to start server."
           warnCAPrivateKeyFile cfgPath x509cfg
@@ -159,101 +339,19 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               ServerPassword s -> pure s
               SPRandom -> BasicAuth <$> randomBase64 32
             randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
-            iniFileContent host basicAuth controlPortPwds =
-              informationIniContent opts'
-                <> "[STORE_LOG]\n\
-                   \# The server uses STM memory for persistence,\n\
-                   \# that will be lost on restart (e.g., as with redis).\n\
-                   \# This option enables saving memory to append only log,\n\
-                   \# and restoring it when the server is started.\n\
-                   \# Log is compacted on start (deleted objects are removed).\n"
-                <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
-                   \# they are preserved in the .bak file until the next restart.\n"
-                <> ("restore_messages: " <> onOff enableStoreLog <> "\n")
-                <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
-                <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
-                <> "# Log daily server statistics to CSV file\n"
-                <> ("log_stats: " <> onOff logStats <> "\n\n")
-                <> "[AUTH]\n\
-                   \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
-                   \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
-                   \new_queues: on\n\n\
-                   \# Use create_password option to enable basic auth to create new messaging queues.\n\
-                   \# The password should be used as part of server address in client configuration:\n\
-                   \# smp://fingerprint:password@host1,host2\n\
-                   \# The password will not be shared with the connecting contacts, you must share it only\n\
-                   \# with the users who you want to allow creating messaging queues on your server.\n"
-                <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')"
-                      in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth
-                   )
-                <> "\n\n"
-                <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
-                <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
-                <> "\n\
-                   \[TRANSPORT]\n\
-                   \# Host is only used to print server address on start.\n\
-                   \# You can specify multiple server ports.\n"
-                <> ("host: " <> T.pack host <> "\n")
-                <> ("port: " <> T.pack defaultServerPorts <> "\n")
-                <> "log_tls_errors: off\n\n\
-                   \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
-                   \# This option is deprecated and should be used for testing only.\n\
-                   \# , port 443 should be specified in port above\n\
-                   \websockets: off\n"
-                <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort))
-                <> "\n\n\
-                   \[PROXY]\n\
-                   \# Network configuration for SMP proxy client.\n\
-                   \# `host_mode` can be 'public' (default) or 'onion'.\n\
-                   \# It defines prefferred hostname for destination servers with multiple hostnames.\n\
-                   \# host_mode: public\n\
-                   \# required_host_mode: off\n\n\
-                   \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n"
-                <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains)
-                <> "\n\n\
-                   \# SOCKS proxy port for forwarding messages to destination servers.\n\
-                   \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n"
-                <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy)
-                <> "\n\n\
-                   \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
-                   \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
-                   \# socks_mode: onion\n\n\
-                   \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
-                <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency)
-                <> "\n\n\
-                   \[INACTIVE_CLIENTS]\n\
-                   \# TTL and interval to check inactive clients\n\
-                   \disconnect: on\n"
-                <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
-                <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration))
-                <> "\n\n\
-                   \[WEB]\n\
-                   \# Set path to generate static mini-site for server information and qr codes/links\n"
-                <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")
-                <> "# Run an embedded server on this port\n\
-                   \# Onion sites can use any port and register it in the hidden service config.\n\
-                   \# Running on a port 80 may require setting process capabilities.\n\
-                   \# http: 8000\n\n\
-                   \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
-                   \# Not required for running relay on onion address.\n"
-                <> (webDisabled <> "https: 443\n")
-                <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
-                <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
-              where
-                webDisabled = if disableWeb then "# " else ""
-    runServer ini = do
+    runServer startOptions ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
       fp <- checkSavedFingerprint cfgPath defaultX509Config
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {information, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
+          cfg@ServerConfig {information, serverStoreCfg, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
           sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
           srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
       printServiceInfo serverVersion srv
       printSourceCode sourceCode'
-      printServerConfig transports storeLogFile
+      printSMPServerConfig transports serverStoreCfg
+      checkMsgStoreMode ini iniStoreType
       putStrLn $ case messageExpiration of
         Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
         _ -> "not expiring messages"
@@ -266,10 +364,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             then maybe "allowed" (const "requires password") newQueueBasicAuth
             else "NOT allowed"
       -- print information
-      let persistence
-            | isNothing storeLogFile = SPMMemoryOnly
-            | isJust (storeMsgsFile cfg) = SPMMessages
-            | otherwise = SPMQueues
+      let persistence = case serverStoreCfg of
+            ASSCfg _ _ (SSCMemory Nothing) -> SPMMemoryOnly
+            ASSCfg _ _ (SSCMemory (Just StorePaths {storeMsgsFile})) | isNothing storeMsgsFile -> SPMQueues
+            _ -> SPMMessages
       let config =
             ServerPublicConfig
               { persistence,
@@ -292,22 +390,24 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           runSMPServer cfg Nothing
       logDebug "Bye"
       where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
         restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of
           Just True -> Just path
           Just False -> Nothing
           -- if the setting is not set, it is enabled when store log is enabled
-          _ -> enableStoreLog $> path
+          _ -> enableStoreLog' ini $> path
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
+        iniStoreType = either error id $! readStoreType ini
         serverConfig =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
               tbqSize = 128,
-              msgQueueQuota = 128,
+              msgQueueQuota = defaultMsgQueueQuota,
+              maxJournalMsgCount = defaultMaxJournalMsgCount,
+              maxJournalStateLines = defaultMaxJournalStateLines,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
               smpCredentials =
@@ -317,9 +417,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     certificateFile = c serverCrtFile
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile = restoreMessagesFile $ combine logPath "smp-server-messages.log",
-              storeNtfsFile = restoreMessagesFile $ combine logPath "smp-server-ntfs.log",
+              serverStoreCfg = case iniStoreType of
+                ASType SQSMemory SMSMemory ->
+                  ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
+                ASType SQSMemory SMSJournal ->
+                  ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
+                ASType SQSPostgres SMSJournal ->
+                  let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
+                      storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
+                   in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir},
+              storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
               newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
@@ -330,6 +437,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   defaultMessageExpiration
                     { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                     },
+              expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
+              idleQueueInterval = defaultIdleQueueInterval,
               notificationExpiration =
                 defaultNtfExpiration
                   { ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
@@ -344,6 +453,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
+              prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
+              prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
               pendingENDInterval = 15000000, -- 15 seconds
               ntfDeliveryInterval = 3000000, -- 3 seconds
               smpServerVRange = supportedServerSMPRelayVRange,
@@ -356,8 +467,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 defaultSMPClientAgentConfig
                   { smpCfg =
                       (smpCfg defaultSMPClientAgentConfig)
-                        { serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
+                        { serverVRange = supportedProxyClientSMPRelayVRange,
                           agreeSecret = True,
+                          proxyServer = True,
                           networkConfig =
                             defaultNetworkConfig
                               { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
@@ -371,7 +483,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   },
               allowSMPProxy = True,
               serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
-              information = serverPublicInfo ini
+              information = serverPublicInfo ini,
+              startOptions
             }
         textToOwnServers :: Text -> [ByteString]
         textToOwnServers = map encodeUtf8 . T.words
@@ -393,6 +506,69 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             pure WebHttpsParams {port, cert, key}
         webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
 
+    checkMsgStoreMode :: Ini -> AStoreType -> IO ()
+    checkMsgStoreMode ini mode = do
+      msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
+      msgsFileExists <- doesFileExist storeMsgsFilePath
+      storeLogExists <- doesFileExist storeLogFilePath
+      case mode of
+        ASType qs SMSJournal
+          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+          | msgsFileExists -> do
+              putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
+              putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
+              exitFailure
+          | not msgsDirExists ->
+              putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
+          | otherwise -> case qs of
+              SQSMemory ->
+                unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
+#if defined(dbServerPostgres)
+              SQSPostgres -> do
+                let DBOpts {connstr, schema} = iniDBOptions ini
+                schemaExists <- checkSchemaExists connstr schema
+                case enableDbStoreLog' ini of
+                  Just ()
+                    | not schemaExists -> noDatabaseSchema connstr schema
+                    | not storeLogExists -> do
+                        putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
+                        exitFailure
+                    | otherwise -> pure ()
+                  Nothing
+                    | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
+                    | storeLogExists -> do
+                        putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
+                        putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
+                        exitFailure
+                    | not schemaExists -> noDatabaseSchema connstr schema
+                    | otherwise -> pure ()
+                where
+                  noDatabaseSchema connstr schema = do
+                    putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
+                    exitFailure
+#else
+              SQSPostgres -> noPostgresExit
+#endif
+        ASType SQSMemory SMSMemory
+          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+          | msgsDirExists -> do
+              putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
+              putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
+              exitFailure
+          | otherwise -> pure ()
+
+    exitConfigureMsgStorage = do
+      putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
+      putStrLn "Configure memory storage."
+      exitFailure
+
+#if defined(dbServerPostgres)
+    exitConfigureQueueStore connstr schema = do
+      putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
+      putStrLn "Configure queue storage."
+      exitFailure
+#endif
+
 data EmbeddedWebParams = EmbeddedWebParams
   { webStaticPath :: FilePath,
     webHttpPort :: Maybe Int,
@@ -415,58 +591,6 @@ getServerSourceCode =
 simplexmqSource :: String
 simplexmqSource = "https://github.com/simplex-chat/simplexmq"
 
-defaultControlPort :: Int
-defaultControlPort = 5224
-
-informationIniContent :: InitOptions -> Text
-informationIniContent InitOptions {sourceCode, serverInfo} =
-  "[INFORMATION]\n\
-  \# AGPLv3 license requires that you make any source code modifications\n\
-  \# available to the end users of the server.\n\
-  \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
-  \# Include correct source code URI in case the server source code is modified in any way.\n\
-  \# If any other information fields are present, source code property also MUST be present.\n\n"
-    <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode)
-    <> "\n\n\
-       \# Declaring all below information is optional, any of these fields can be omitted.\n\
-       \\n\
-       \# Server usage conditions and amendments.\n\
-       \# It is recommended to use standard conditions with any amendments in a separate document.\n\
-       \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\
-       \# condition_amendments: link\n\
-       \\n\
-       \# Server location and operator.\n"
-    <> countryStr "server" serverCountry
-    <> enitiyStrs "operator" operator
-    <> (optDisabled website <> "website: " <> fromMaybe "" website)
-    <> "\n\n\
-       \# Administrative contacts.\n\
-       \# admin_simplex: SimpleX address\n\
-       \# admin_email:\n\
-       \# admin_pgp:\n\
-       \# admin_pgp_fingerprint:\n\
-       \\n\
-       \# Contacts for complaints and feedback.\n\
-       \# complaints_simplex: SimpleX address\n\
-       \# complaints_email:\n\
-       \# complaints_pgp:\n\
-       \# complaints_pgp_fingerprint:\n\
-       \\n\
-       \# Hosting provider.\n"
-    <> enitiyStrs "hosting" hosting
-    <> "\n\
-       \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n"
-    <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n")
-  where
-    ServerPublicInfo {operator, website, hosting, hostingType, serverCountry}= serverInfo
-    countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n"
-    enitiyStrs optName entity =
-      optDisabled entity
-        <> optName <> ": "
-        <> maybe ("entity (organization or person name)") name entity
-        <> "\n"
-        <> countryStr optName (country =<< entity)
-
 serverPublicInfo :: Ini -> Maybe ServerPublicInfo
 serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
   where
@@ -499,9 +623,6 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
             (Nothing, Nothing, _, Nothing) -> Nothing
             (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
 
-optDisabled :: Maybe a -> Text
-optDisabled p = if isNothing p then "# " else ""
-
 validCountryValue :: String -> String -> Either String Text
 validCountryValue field s
   | length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
@@ -517,39 +638,22 @@ printSourceCode = \case
 data CliCommand
   = Init InitOptions
   | OnlineCert CertOptions
-  | Start
+  | Start StartOptions
   | Delete
+  | Journal StoreCmd
+  | Database StoreCmd DBOpts
 
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    logStats :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName,
-    password :: Maybe ServerPassword,
-    controlPort :: Maybe Int,
-    socksProxy :: Maybe SocksProxy,
-    ownDomains :: Maybe (L.NonEmpty TransportHost),
-    sourceCode :: Maybe Text,
-    serverInfo :: ServerPublicInfo,
-    operatorCountry :: Maybe Text,
-    hostingCountry :: Maybe Text,
-    webStaticPath :: Maybe FilePath,
-    disableWeb :: Bool,
-    scripted :: Bool
-  }
-  deriving (Show)
-
-data ServerPassword = ServerPassword BasicAuth | SPRandom
-  deriving (Show)
+data StoreCmd = SCImport | SCExport | SCDelete
 
 cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
     ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
         <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+        <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -560,6 +664,7 @@ cliCommandP cfgPath logPath iniFile =
               <> short 'l'
               <> help "Enable store log for persistence"
           )
+      dbOptions <- dbOptsP
       logStats <-
         switch
           ( long "daily-stats"
@@ -607,22 +712,21 @@ cliCommandP cfgPath logPath iniFile =
           <|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing)
       socksProxy <-
         flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050")
-          <|>
-            option
-              strParse
-              ( long "socks-proxy"
-                  <> metavar "PROXY"
-                  <> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
-                  <> value Nothing
-              )
+          <|> option
+            strParse
+            ( long "socks-proxy"
+                <> metavar "PROXY"
+                <> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
+                <> value Nothing
+            )
       ownDomains :: Maybe (L.NonEmpty TransportHost) <-
         option
           strParse
-            ( long "own-domains"
-                <> metavar "DOMAINS"
-                <> help "Own server domain names (comma-separated)"
-                <> value Nothing
-            )
+          ( long "own-domains"
+              <> metavar "DOMAINS"
+              <> help "Own server domain names (comma-separated)"
+              <> value Nothing
+          )
       sourceCode <-
         flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")"))
           <|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code")
@@ -663,6 +767,7 @@ cliCommandP cfgPath logPath iniFile =
       pure
         InitOptions
           { enableStoreLog,
+            dbOptions,
             logStats,
             signAlgorithm,
             ip,
@@ -690,6 +795,73 @@ cliCommandP cfgPath logPath iniFile =
             disableWeb,
             scripted
           }
+    startOptionsP = do
+      maintenance <-
+        switch
+          ( long "maintenance"
+              <> short 'm'
+              <> help "Do not start the server, only perform start and stop tasks"
+          )
+      compactLog <-
+        switch
+          ( long "compact-log"
+              <> help "Compact store log (always enabled with `memory` storage for queues)"
+          )
+      skipWarnings <-
+        switch
+          ( long "skip-warnings"
+              <> help "Start the server with non-critical start warnings"
+          )
+      confirmMigrations <-
+        option
+          parseConfirmMigrations
+          ( long "confirm-migrations"
+              <> metavar "CONFIRM_MIGRATIONS"
+              <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
+              <> value MCConsole
+          )
+      pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations}
+    journalCmdP = storeCmdP "message log file" "journal storage"
+    databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
+    storeCmdP src dest =
+      hsubparser
+        ( command "import" (info (pure SCImport) (progDesc $ "Import " <> src <> " into a new " <> dest))
+            <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
+            <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
+        )
+    dbOptsP = do
+      connstr <-
+        strOption
+          ( long "database"
+              <> short 'd'
+              <> metavar "DB_CONN"
+              <> help "Database connection string"
+              <> value defaultDBConnStr
+              <> showDefault
+          )
+      schema <-
+        strOption
+          ( long "schema"
+              <> metavar "DB_SCHEMA"
+              <> help "Database schema"
+              <> value defaultDBSchema
+              <> showDefault
+          )
+      poolSize <-
+        option
+          auto
+          ( long "pool-size"
+              <> metavar "POOL_SIZE"
+              <> help "Database pool size"
+              <> value defaultDBPoolSize
+              <> showDefault
+          )
+      pure DBOpts {connstr, schema, poolSize, createSchema = False}
+    parseConfirmMigrations :: ReadM MigrationConfirmation
+    parseConfirmMigrations = eitherReader $ \case
+      "up" -> Right MCYesUp
+      "down" -> Right MCYesUpDown
+      _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)

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

@@ -0,0 +1,230 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Server.Main.Init where
+
+import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
+import qualified Data.List.NonEmpty as L
+import Data.Maybe (fromMaybe, isNothing)
+import Numeric.Natural (Natural)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Network.Socket (HostName)
+import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (BasicAuth)
+import Simplex.Messaging.Server.CLI (SignAlgorithm, onOff)
+import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
+import Simplex.Messaging.Server.Information (Entity (..), ServerPublicInfo (..))
+import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import System.FilePath ((</>))
+
+defaultControlPort :: Int
+defaultControlPort = 5224
+
+defaultDBConnStr :: ByteString
+defaultDBConnStr = "postgresql://smp@/smp_server_store"
+
+defaultDBSchema :: ByteString
+defaultDBSchema = "smp_server"
+
+defaultDBPoolSize :: Natural
+defaultDBPoolSize = 10
+
+-- time to retain deleted queues in the database (days), for debugging
+defaultDeletedTTL :: Int64
+defaultDeletedTTL = 21
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    dbOptions :: DBOpts,
+    logStats :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName,
+    password :: Maybe ServerPassword,
+    controlPort :: Maybe Int,
+    socksProxy :: Maybe SocksProxy,
+    ownDomains :: Maybe (L.NonEmpty TransportHost),
+    sourceCode :: Maybe Text,
+    serverInfo :: ServerPublicInfo,
+    operatorCountry :: Maybe Text,
+    hostingCountry :: Maybe Text,
+    webStaticPath :: Maybe FilePath,
+    disableWeb :: Bool,
+    scripted :: Bool
+  }
+  deriving (Show)
+
+data ServerPassword = ServerPassword BasicAuth | SPRandom
+  deriving (Show)
+
+iniFileContent :: FilePath -> FilePath -> InitOptions -> HostName -> Maybe BasicAuth -> Maybe (Text, Text) -> Text
+iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
+  informationIniContent opts
+    <> "[STORE_LOG]\n\
+        \# The server uses memory or PostgreSQL database for persisting queue records.\n\
+        \# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\
+        \# Log is compacted on start (deleted objects are removed).\n"
+    <> ("enable: " <> onOff enableStoreLog <> "\n\n")
+    <> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\
+        \# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\
+        \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\
+        \store_queues: memory\n\n\
+        \# Database connection settings for PostgreSQL database (`store_queues: database`).\n"
+    <> (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n")
+    <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n")
+    <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n")
+    <> "# Write database changes to store log file\n\
+        \# db_store_log: off\n\n\
+        \# Time to retain deleted queues in the database, days.\n"
+    <> ("db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n")
+    <> "# Message storage mode: `memory` or `journal`.\n\
+        \store_messages: memory\n\n\
+        \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
+        \# when the server restarts, they are preserved in the .bak file until the next restart.\n"
+    <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
+    <> "# Messages and notifications expiration periods.\n"
+    <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
+    <> "expire_messages_on_start: on\n"
+    <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
+    <> "# Log daily server statistics to CSV file\n"
+    <> ("log_stats: " <> onOff logStats <> "\n\n")
+    <> "# Log interval for real-time Prometheus metrics\n\
+        \# prometheus_interval: 300\n\n\
+        \[AUTH]\n\
+        \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
+        \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
+        \new_queues: on\n\n\
+        \# Use create_password option to enable basic auth to create new messaging queues.\n\
+        \# The password should be used as part of server address in client configuration:\n\
+        \# smp://fingerprint:password@host1,host2\n\
+        \# The password will not be shared with the connecting contacts, you must share it only\n\
+        \# with the users who you want to allow creating messaging queues on your server.\n"
+    <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')"
+          in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth
+        )
+    <> "\n\n"
+    <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
+    <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
+    <> "\n\
+        \[TRANSPORT]\n\
+        \# Host is only used to print server address on start.\n\
+        \# You can specify multiple server ports.\n"
+    <> ("host: " <> T.pack host <> "\n")
+    <> ("port: " <> defaultServerPorts <> "\n")
+    <> "log_tls_errors: off\n\n\
+        \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
+        \# This option is deprecated and should be used for testing only.\n\
+        \# , port 443 should be specified in port above\n\
+        \websockets: off\n"
+    <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort))
+    <> "\n\n\
+        \[PROXY]\n\
+        \# Network configuration for SMP proxy client.\n\
+        \# `host_mode` can be 'public' (default) or 'onion'.\n\
+        \# It defines prefferred hostname for destination servers with multiple hostnames.\n\
+        \# host_mode: public\n\
+        \# required_host_mode: off\n\n\
+        \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n"
+    <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains)
+    <> "\n\n\
+        \# SOCKS proxy port for forwarding messages to destination servers.\n\
+        \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n"
+    <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy)
+    <> "\n\n\
+        \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
+        \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
+        \# socks_mode: onion\n\n\
+        \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
+    <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency)
+    <> "\n\n\
+        \[INACTIVE_CLIENTS]\n\
+        \# TTL and interval to check inactive clients\n\
+        \disconnect: on\n"
+    <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
+    <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration))
+    <> "\n\n\
+        \[WEB]\n\
+        \# Set path to generate static mini-site for server information and qr codes/links\n"
+    <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")
+    <> "# Run an embedded server on this port\n\
+        \# Onion sites can use any port and register it in the hidden service config.\n\
+        \# Running on a port 80 may require setting process capabilities.\n\
+        \# http: 8000\n\n\
+        \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
+        \# Not required for running relay on onion address.\n"
+    <> (webDisabled <> "https: 443\n")
+    <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
+    <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
+  where
+    InitOptions {enableStoreLog, dbOptions, socksProxy, ownDomains, controlPort, webStaticPath, disableWeb, logStats} = opts
+    DBOpts {connstr, schema, poolSize} = dbOptions
+    defaultServerPorts = "5223,443"
+    defaultStaticPath = logPath </> "www"
+    httpsCertFile = cfgPath </> "web.crt"
+    httpsKeyFile = cfgPath </> "web.key"
+    webDisabled = if disableWeb then "# " else ""
+
+informationIniContent :: InitOptions -> Text
+informationIniContent InitOptions {sourceCode, serverInfo} =
+  "[INFORMATION]\n\
+  \# AGPLv3 license requires that you make any source code modifications\n\
+  \# available to the end users of the server.\n\
+  \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
+  \# Include correct source code URI in case the server source code is modified in any way.\n\
+  \# If any other information fields are present, source code property also MUST be present.\n\n"
+    <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode)
+    <> "\n\n\
+       \# Declaring all below information is optional, any of these fields can be omitted.\n\
+       \\n\
+       \# Server usage conditions and amendments.\n\
+       \# It is recommended to use standard conditions with any amendments in a separate document.\n\
+       \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\
+       \# condition_amendments: link\n\
+       \\n\
+       \# Server location and operator.\n"
+    <> countryStr "server" serverCountry
+    <> enitiyStrs "operator" operator
+    <> (optDisabled website <> "website: " <> fromMaybe "" website)
+    <> "\n\n\
+       \# Administrative contacts.\n\
+       \# admin_simplex: SimpleX address\n\
+       \# admin_email:\n\
+       \# admin_pgp:\n\
+       \# admin_pgp_fingerprint:\n\
+       \\n\
+       \# Contacts for complaints and feedback.\n\
+       \# complaints_simplex: SimpleX address\n\
+       \# complaints_email:\n\
+       \# complaints_pgp:\n\
+       \# complaints_pgp_fingerprint:\n\
+       \\n\
+       \# Hosting provider.\n"
+    <> enitiyStrs "hosting" hosting
+    <> "\n\
+       \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n"
+    <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n")
+  where
+    ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo
+    countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n"
+    enitiyStrs optName entity =
+      optDisabled entity
+        <> optName
+        <> ": "
+        <> maybe "entity (organization or person name)" name entity
+        <> "\n"
+        <> countryStr optName (country =<< entity)
+
+optDisabled :: Maybe a -> Text
+optDisabled = optDisabled' . isNothing
+{-# INLINE optDisabled #-}
+
+optDisabled' :: Bool -> Text
+optDisabled' cond = if cond then "# " else ""
+{-# INLINE optDisabled' #-}

src/Simplex/Messaging/Server/MsgStore/Journal.hs

@@ -0,0 +1,982 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Server.MsgStore.Journal
+  ( JournalMsgStore (random, expireBackupsBefore),
+    QStore (..),
+    QStoreCfg (..),
+    JournalQueue,
+    JournalMsgQueue (queue, state),
+    JMQueue (queueDirectory, statePath),
+    JournalStoreConfig (..),
+    closeMsgQueue,
+    closeMsgQueueHandles,
+    -- below are exported for tests
+    MsgQueueState (..),
+    JournalState (..),
+    SJournalType (..),
+    msgQueueDirectory,
+    msgQueueStatePath,
+    readQueueState,
+    newMsgQueueState,
+    newJournalId,
+    appendState,
+    queueLogFileName,
+    journalFilePath,
+    logFileExt,
+    stmQueueStore,
+#if defined(dbServerPostgres)
+    postgresQueueStore,
+#endif
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Trans.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.List (intercalate, sort)
+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
+import GHC.IO (catchAny)
+import Simplex.Messaging.Agent.Client (getMapLock)
+import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore.Journal.SharedLock
+import Simplex.Messaging.Server.MsgStore.Types
+import Simplex.Messaging.Server.QueueStore
+#if defined(dbServerPostgres)
+import Simplex.Messaging.Server.QueueStore.Postgres
+#endif
+import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>))
+import System.Directory
+import System.FilePath (takeFileName, (</>))
+import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..))
+import qualified System.IO as IO
+import System.Random (StdGen, genByteString, newStdGen)
+
+data JournalMsgStore s = JournalMsgStore
+  { config :: JournalStoreConfig s,
+    random :: TVar StdGen,
+    queueLocks :: TMap RecipientId Lock,
+    sharedLock :: TMVar RecipientId,
+    queueStore_ :: QStore s,
+    expireBackupsBefore :: UTCTime
+  }
+
+data QStore (s :: QSType) where
+  MQStore :: QStoreType 'QSMemory -> QStore 'QSMemory
+#if defined(dbServerPostgres)
+  PQStore :: QStoreType 'QSPostgres -> QStore 'QSPostgres
+#endif
+
+type family QStoreType s where
+  QStoreType 'QSMemory = STMQueueStore (JournalQueue 'QSMemory)
+#if defined(dbServerPostgres)
+  QStoreType 'QSPostgres = PostgresQueueStore (JournalQueue 'QSPostgres)
+#endif
+
+withQS :: (QueueStoreClass (JournalQueue s) (QStoreType s) => QStoreType s -> r) -> QStore s -> r
+withQS f = \case
+  MQStore st -> f st
+#if defined(dbServerPostgres)
+  PQStore st -> f st
+#endif
+{-# INLINE withQS #-}
+
+stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory)
+stmQueueStore st = case queueStore_ st of
+  MQStore st' -> st'
+
+#if defined(dbServerPostgres)
+postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres)
+postgresQueueStore st = case queueStore_ st of
+  PQStore st' -> st'
+#endif
+
+data JournalStoreConfig s = JournalStoreConfig
+  { storePath :: FilePath,
+    pathParts :: Int,
+    queueStoreCfg :: QStoreCfg s,
+    quota :: Int,
+    -- Max number of messages per journal file - ignored in STM store.
+    -- When this limit is reached, the file will be changed.
+    -- This number should be set bigger than queue quota.
+    maxMsgCount :: Int,
+    maxStateLines :: Int,
+    stateTailSize :: Int,
+    -- time in seconds after which the queue will be closed after message expiration
+    idleInterval :: Int64,
+    -- expire state backup files
+    expireBackupsAfter :: NominalDiffTime,
+    keepMinBackups :: Int
+  }
+
+data QStoreCfg s where
+  MQStoreCfg :: QStoreCfg 'QSMemory
+#if defined(dbServerPostgres)
+  PQStoreCfg :: PostgresStoreCfg -> QStoreCfg 'QSPostgres
+#endif
+
+data JournalQueue (s :: QSType) = JournalQueue
+  { recipientId' :: RecipientId,
+    queueLock :: Lock,
+    sharedLock :: TMVar RecipientId,
+    -- To avoid race conditions and errors when restoring queues,
+    -- Nothing is written to TVar when queue is deleted.
+    queueRec' :: TVar (Maybe QueueRec),
+    msgQueue' :: TVar (Maybe (JournalMsgQueue s)),
+    -- system time in seconds since epoch
+    activeAt :: TVar Int64,
+    queueState :: TVar (Maybe QState) -- Nothing - unknown
+  }
+
+data QState = QState
+  { hasPending :: Bool,
+    hasStored :: Bool
+  }
+
+data JMQueue = JMQueue
+  { queueDirectory :: FilePath,
+    statePath :: FilePath
+  }
+
+data JournalMsgQueue (s :: QSType) = JournalMsgQueue
+  { queue :: JMQueue,
+    state :: TVar MsgQueueState,
+    -- tipMsg contains last message and length incl. newline
+    -- Nothing - unknown, Just Nothing - empty queue.
+    -- It  prevents reading each message twice,
+    -- and reading it after it was just written.
+    tipMsg :: TVar (Maybe (Maybe (Message, Int64))),
+    handles :: TVar (Maybe MsgQueueHandles)
+  }
+
+data MsgQueueState = MsgQueueState
+  { readState :: JournalState 'JTRead,
+    writeState :: JournalState 'JTWrite,
+    canWrite :: Bool,
+    size :: Int
+  }
+  deriving (Show)
+
+data MsgQueueHandles = MsgQueueHandles
+  { stateHandle :: Handle, -- handle to queue state log file, rotates and removes old backups when server is restarted
+    readHandle :: Handle,
+    writeHandle :: Maybe Handle -- optional, used when write file is different from read file
+  }
+
+data JournalState t = JournalState
+  { journalType :: SJournalType t,
+    journalId :: ByteString,
+    msgPos :: Int,
+    msgCount :: Int,
+    bytePos :: Int64,
+    byteCount :: Int64
+  }
+  deriving (Show)
+
+qState :: MsgQueueState -> QState
+qState MsgQueueState {size, readState = rs, writeState = ws} =
+  let hasPending = size > 0
+   in QState {hasPending, hasStored = hasPending || msgCount rs > 0 || msgCount ws > 0}
+{-# INLINE qState #-}
+
+data JournalType = JTRead | JTWrite
+
+data SJournalType (t :: JournalType) where
+  SJTRead :: SJournalType 'JTRead
+  SJTWrite :: SJournalType 'JTWrite
+
+class JournalTypeI t where sJournalType :: SJournalType t
+
+instance JournalTypeI 'JTRead where sJournalType = SJTRead
+
+instance JournalTypeI 'JTWrite where sJournalType = SJTWrite
+
+deriving instance Show (SJournalType t)
+
+newMsgQueueState :: ByteString -> MsgQueueState
+newMsgQueueState journalId =
+  MsgQueueState
+    { writeState = newJournalState journalId,
+      readState = newJournalState journalId,
+      canWrite = True,
+      size = 0
+    }
+
+newJournalState :: JournalTypeI t => ByteString -> JournalState t
+newJournalState journalId = JournalState sJournalType journalId 0 0 0 0
+
+journalFilePath :: FilePath -> ByteString -> FilePath
+journalFilePath dir journalId = dir </> (msgLogFileName <> "." <> B.unpack journalId <> logFileExt)
+
+instance StrEncoding MsgQueueState where
+  strEncode MsgQueueState {writeState, readState, canWrite, size} =
+    B.unwords
+      [ "write=" <> strEncode writeState,
+        "read=" <> strEncode readState,
+        "canWrite=" <> strEncode canWrite,
+        "size=" <> strEncode size
+      ]
+  strP = do
+    writeState <- "write=" *> strP
+    readState <- " read=" *> strP
+    canWrite <- " canWrite=" *> strP
+    size <- " size=" *> strP
+    pure MsgQueueState {writeState, readState, canWrite, size}
+
+instance JournalTypeI t => StrEncoding (JournalState t) where
+  strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} =
+    B.intercalate "," [journalId, e msgPos, e msgCount, e bytePos, e byteCount]
+    where
+      e :: StrEncoding a => a -> ByteString
+      e = strEncode
+  strP = do
+    journalId <- A.takeTill (== ',')
+    JournalState sJournalType journalId <$> i <*> i <*> i <*> i
+    where
+      i :: Integral a => A.Parser a
+      i = A.char ',' *> A.decimal
+
+queueLogFileName :: String
+queueLogFileName = "queue_state"
+
+msgLogFileName :: String
+msgLogFileName = "messages"
+
+logFileExt :: String
+logFileExt = ".log"
+
+newtype StoreIO (s :: QSType) a = StoreIO {unStoreIO :: IO a}
+  deriving newtype (Functor, Applicative, Monad)
+
+instance StoreQueueClass (JournalQueue s) where
+  type MsgQueue (JournalQueue s) = JournalMsgQueue s
+  recipientId = recipientId'
+  {-# INLINE recipientId #-}
+  queueRec = queueRec'
+  {-# INLINE queueRec #-}
+  msgQueue = msgQueue'
+  {-# INLINE msgQueue #-}
+  withQueueLock :: JournalQueue s -> String -> IO a -> IO a
+  withQueueLock JournalQueue {recipientId', queueLock, sharedLock} =
+    withLockWaitShared recipientId' queueLock sharedLock
+  {-# INLINE withQueueLock #-}
+
+instance QueueStoreClass (JournalQueue s) (QStore s) where
+  type QueueStoreCfg (QStore s) = QStoreCfg s
+
+  newQueueStore :: QStoreCfg s -> IO (QStore s)
+  newQueueStore = \case
+    MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) ()
+#if defined(dbServerPostgres)
+    PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg
+#endif
+
+  closeQueueStore = withQS (closeQueueStore @(JournalQueue s))
+  {-# INLINE closeQueueStore #-}
+  loadedQueues = withQS loadedQueues
+  {-# INLINE loadedQueues #-}
+  compactQueues = withQS (compactQueues @(JournalQueue s))
+  {-# INLINE compactQueues #-}
+  queueCounts = withQS (queueCounts @(JournalQueue s))
+  {-# INLINE queueCounts #-}
+  addQueue_ = withQS addQueue_
+  {-# INLINE addQueue_ #-}
+  getQueue_ = withQS getQueue_
+  {-# INLINE getQueue_ #-}
+  secureQueue = withQS secureQueue
+  {-# INLINE secureQueue #-}
+  addQueueNotifier = withQS addQueueNotifier
+  {-# INLINE addQueueNotifier #-}
+  deleteQueueNotifier = withQS deleteQueueNotifier
+  {-# INLINE deleteQueueNotifier #-}
+  suspendQueue = withQS suspendQueue
+  {-# INLINE suspendQueue #-}
+  blockQueue = withQS blockQueue
+  {-# INLINE blockQueue #-}
+  unblockQueue = withQS unblockQueue
+  {-# INLINE unblockQueue #-}
+  updateQueueTime = withQS updateQueueTime
+  {-# INLINE updateQueueTime #-}
+  deleteStoreQueue = withQS deleteStoreQueue
+  {-# INLINE deleteStoreQueue #-}
+
+#if defined(dbServerPostgres)
+mkTempQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s)
+mkTempQueue ms rId qr = createLockIO >>= makeQueue_ ms rId qr
+{-# INLINE mkTempQueue #-}
+#endif
+
+makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s)
+makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do
+  queueRec' <- newTVarIO $ Just qr
+  msgQueue' <- newTVarIO Nothing
+  activeAt <- newTVarIO 0
+  queueState <- newTVarIO Nothing
+  pure $
+    JournalQueue
+      { recipientId' = rId,
+        queueLock,
+        sharedLock,
+        queueRec',
+        msgQueue',
+        activeAt,
+        queueState
+      }
+
+instance MsgStoreClass (JournalMsgStore s) where
+  type StoreMonad (JournalMsgStore s) = StoreIO s
+  type QueueStore (JournalMsgStore s) = QStore s
+  type StoreQueue (JournalMsgStore s) = JournalQueue s
+  type MsgStoreConfig (JournalMsgStore s) = JournalStoreConfig s
+
+  newMsgStore :: JournalStoreConfig s -> IO (JournalMsgStore s)
+  newMsgStore config@JournalStoreConfig {queueStoreCfg} = do
+    random <- newTVarIO =<< newStdGen
+    queueLocks <- TM.emptyIO
+    sharedLock <- newEmptyTMVarIO
+    queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg
+    expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime
+    pure JournalMsgStore {config, random, queueLocks, sharedLock, queueStore_, expireBackupsBefore}
+
+  closeMsgStore :: JournalMsgStore s -> IO ()
+  closeMsgStore ms = do
+    let st = queueStore_ ms
+    closeQueues $ loadedQueues @(JournalQueue s) st
+    closeQueueStore @(JournalQueue s) st
+    where
+      closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue
+
+  withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
+  withActiveMsgQueues = withQS withLoadedQueues . queueStore_
+
+  -- This function can only be used in server CLI commands or before server is started.
+  -- It does not cache queues and is NOT concurrency safe.
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
+  unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of
+    MQStore st -> withLoadedQueues st run 
+#if defined(dbServerPostgres)
+    PQStore st -> foldQueueRecs tty st Nothing $ uncurry (mkTempQueue ms) >=> run
+#endif
+    where
+      run q = do
+        r <- action q
+        closeMsgQueue q
+        pure r
+
+  -- This function is concurrency safe
+  expireOldMessages :: Bool -> JournalMsgStore s -> Int64 -> Int64 -> IO MessageStats
+  expireOldMessages tty ms now ttl = case queueStore_ ms of
+    MQStore st ->
+      withLoadedQueues st $ \q -> run $ isolateQueue q "deleteExpiredMsgs" $ do
+        StoreIO (readTVarIO $ queueRec q) >>= \case
+          Just QueueRec {updatedAt = Just (RoundedSystemTime t)} | t > veryOld ->
+            expireQueueMsgs ms now old q
+          _ -> pure newMessageStats
+#if defined(dbServerPostgres)
+    PQStore st -> do
+      let JournalMsgStore {queueLocks, sharedLock} = ms
+      foldQueueRecs tty st (Just veryOld) $ \(rId, qr) -> do
+        q <- mkTempQueue ms rId qr
+        withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $
+          getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old
+#endif
+    where
+      old = now - ttl
+      veryOld = now - 2 * ttl - 86400
+      run :: ExceptT ErrorType IO MessageStats -> IO MessageStats
+      run = fmap (fromRight newMessageStats) . runExceptT
+      -- Use cached queue if available.
+      -- Also see the comment in loadQueue in PostgresQueueStore
+      getLoadedQueue :: JournalQueue s -> IO (JournalQueue s)
+      getLoadedQueue q = fromMaybe q <$> TM.lookupIO (recipientId q) (loadedQueues $ queueStore_ ms)
+
+  logQueueStates :: JournalMsgStore s -> IO ()
+  logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState
+
+  logQueueState :: JournalQueue s -> StoreIO s ()
+  logQueueState q =
+    StoreIO . void $
+      readTVarIO (msgQueue' q)
+        $>>= \mq -> readTVarIO (handles mq)
+        $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
+
+  queueStore = queueStore_
+  {-# INLINE queueStore #-}
+
+  mkQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s)
+  mkQueue ms rId qr = do
+    lock <- atomically $ getMapLock (queueLocks ms) rId
+    makeQueue_ ms rId qr lock
+
+  getMsgQueue :: JournalMsgStore s -> JournalQueue s -> Bool -> StoreIO s (JournalMsgQueue s)
+  getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId' = rId, msgQueue'} forWrite =
+    StoreIO $ readTVarIO msgQueue' >>= maybe newQ pure
+    where
+      newQ = do
+        let dir = msgQueueDirectory ms rId
+            statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
+            queue = JMQueue {queueDirectory = dir, statePath}
+        q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue)
+        atomically $ writeTVar msgQueue' $ Just q
+        st <- readTVarIO $ state q
+        atomically $ writeTVar (queueState q') $ Just $! qState st
+        pure q
+        where
+          createQ :: JMQueue -> IO (JournalMsgQueue s)
+          createQ queue = do
+            -- folder and files are not created here,
+            -- to avoid file IO for queues without messages during subscription
+            journalId <- newJournalId random
+            mkJournalQueue queue (newMsgQueueState journalId) Nothing
+
+  getPeekMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message))
+  getPeekMsgQueue ms q@JournalQueue {queueState} =
+    StoreIO (readTVarIO queueState) >>= \case
+      Just QState {hasPending} -> if hasPending then peek else pure Nothing
+      Nothing -> do
+        -- We only close the queue if we just learnt it's empty.
+        -- This is needed to reduce file descriptors and memory usage
+        -- after the server just started and many clients subscribe.
+        -- In case the queue became non-empty on write and then again empty on read
+        -- we won't be closing it, to avoid frequent open/close on active queues.
+        r <- peek
+        when (isNothing r) $ StoreIO $ closeMsgQueue q
+        pure r
+    where
+      peek = do
+        mq <- getMsgQueue ms q False
+        (mq,) <$$> tryPeekMsg_ q mq
+
+  -- only runs action if queue is not empty
+  withIdleMsgQueue :: Int64 -> JournalMsgStore s -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int)
+  withIdleMsgQueue now ms@JournalMsgStore {config} q@JournalQueue {queueState} action =
+    StoreIO $ readTVarIO (msgQueue' q) >>= \case
+      Nothing ->
+        E.bracket
+          getNonEmptyMsgQueue
+          (mapM_ $ \_ -> closeMsgQueue q)
+          (maybe (pure (Nothing, 0)) (unStoreIO . run))
+        where
+          run mq = do
+            r <- action mq
+            sz <- getQueueSize_ mq
+            pure (Just r, sz)
+      Just mq -> do
+        ts <- readTVarIO $ activeAt q
+        r <- if now - ts >= idleInterval config
+          then Just <$> unStoreIO (action mq) `E.finally` closeMsgQueue q
+          else pure Nothing
+        sz <- unStoreIO $ getQueueSize_ mq
+        pure (r, sz)
+    where
+      getNonEmptyMsgQueue :: IO (Maybe (JournalMsgQueue s))
+      getNonEmptyMsgQueue =
+        readTVarIO queueState >>= \case
+          Just QState {hasStored}
+            | hasStored -> Just <$> unStoreIO (getMsgQueue ms q False)
+            | otherwise -> pure Nothing
+          Nothing -> do
+            mq <- unStoreIO $ getMsgQueue ms q False
+            -- queueState was updated in getMsgQueue
+            readTVarIO queueState >>= \case
+              Just QState {hasStored} | not hasStored -> closeMsgQueue q $> Nothing
+              _ -> pure $ Just mq
+
+  deleteQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType QueueRec)
+  deleteQueue ms q = fst <$$> deleteQueue_ ms q
+
+  deleteQueueSize :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int))
+  deleteQueueSize ms q =
+    deleteQueue_ ms q >>= mapM (traverse getSize)
+    -- traverse operates on the second tuple element
+    where
+      getSize = maybe (pure (-1)) (fmap size . readTVarIO . state)
+
+  getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message]
+  getQueueMessages_ drainMsgs q' q = StoreIO (run [])
+    where
+      run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
+      getMsg msgs hs = chooseReadJournal q' q drainMsgs hs >>= maybe (pure msgs) readMsg
+        where
+          readMsg (rs, h) = do
+            (msg, len) <- hGetMsgAt h $ bytePos rs
+            updateReadPos q' q drainMsgs len hs
+            (msg :) <$> run msgs
+
+  writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do
+    q <- getMsgQueue ms q' True
+    StoreIO $ (`E.finally` updateActiveAt q') $ do
+      st@MsgQueueState {canWrite, size} <- readTVarIO (state q)
+      let empty = size == 0
+      if canWrite || empty
+        then do
+          let canWrt' = quota > size
+          if canWrt'
+            then writeToJournal q st canWrt' msg $> Just (msg, empty)
+            else writeToJournal q st canWrt' msgQuota $> Nothing
+        else pure Nothing
+    where
+      JournalStoreConfig {quota, maxMsgCount} = config ms
+      msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
+      writeToJournal q st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do
+        let msgStr = strEncode msg' `B.snoc` '\n'
+            msgLen = fromIntegral $ B.length msgStr
+        hs <- maybe createQueueDir pure =<< readTVarIO handles
+        (ws, wh) <- case writeHandle hs of
+          Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs
+          wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_)
+        let msgPos' = msgPos ws + 1
+            bytePos' = bytePos ws + msgLen
+            ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'}
+            rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs
+            !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1}
+        hAppend wh (bytePos ws) msgStr
+        updateQueueState q' q logState hs st' $
+          when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen))
+        where
+          JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q
+          createQueueDir = do
+            createDirectoryIfMissing True queueDirectory
+            sh <- openFile statePath AppendMode
+            rh <- createNewJournal queueDirectory $ journalId rs
+            let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing}
+            atomically $ writeTVar handles $ Just hs
+            pure hs
+          switchWriteJournal hs = do
+            journalId <- newJournalId $ random ms
+            wh <- createNewJournal queueDirectory journalId
+            atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh}
+            pure (newJournalState journalId, wh)
+
+  -- can ONLY be used while restoring messages, not while server running
+  setOverQuota_ :: JournalQueue s -> IO ()
+  setOverQuota_ q =
+    readTVarIO (msgQueue' q)
+      >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False})
+
+  getQueueSize_ :: JournalMsgQueue s -> StoreIO s Int
+  getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
+
+  tryPeekMsg_ :: JournalQueue s -> JournalMsgQueue s -> StoreIO s (Maybe Message)
+  tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
+    StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg)
+    where
+      peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst)
+        where
+          readMsg = do
+            ml@(msg, _) <- hGetMsgAt h $ bytePos rs
+            atomically $ writeTVar tipMsg $ Just (Just ml)
+            pure $ Just msg
+
+  tryDeleteMsg_ :: JournalQueue s -> JournalMsgQueue s -> Bool -> StoreIO s ()
+  tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $
+    void $
+      readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
+        $>>= (pure . fmap snd)
+        $>>= \len -> readTVarIO handles
+        $>>= \hs -> updateReadPos q mq logState len hs $> Just ()
+
+  isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a
+  isolateQueue sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO
+
+  unsafeRunStore :: JournalQueue s -> String -> StoreIO s a -> IO a
+  unsafeRunStore sq op a =
+    unStoreIO a `E.catch` \e -> storeError op (recipientId' sq) e >> E.throwIO e
+
+updateActiveAt :: JournalQueue s -> IO ()
+updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime
+
+tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
+tryStore' op rId = tryStore op rId . fmap Right
+
+tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+tryStore op rId a = ExceptT $ E.mask_ $ a `E.catch` storeError op rId
+
+storeError :: String -> RecipientId -> E.SomeException -> IO (Either ErrorType a)
+storeError op rId e =
+  let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
+    in logError ("STORE: " <> T.pack e') $> Left (STORE e')
+
+isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+isolateQueueId op JournalMsgStore {queueLocks, sharedLock} rId =
+  tryStore op rId . withLockMapWaitShared rId queueLocks sharedLock op
+
+openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s)
+openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do
+  (st_, shouldBackup) <- readQueueState ms statePath
+  case st_ of
+    Nothing -> do
+      st <- newMsgQueueState <$> newJournalId (random ms)
+      when shouldBackup $ backupQueueState statePath -- rename invalid state file
+      mkJournalQueue q st Nothing
+    Just st
+      | size st == 0 -> do
+          (st', hs_) <- removeJournals st shouldBackup
+          mkJournalQueue q st' hs_
+      | otherwise -> do
+          sh <- openBackupQueueState st shouldBackup
+          (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh
+          let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_}
+          mkJournalQueue q st' (Just hs)
+  where
+    -- If the queue is empty, journals are deleted.
+    -- New journal is created if queue is written to.
+    -- canWrite is set to True.
+    removeJournals MsgQueueState {readState = rs, writeState = ws} shouldBackup = E.uninterruptibleMask_ $ do
+      rjId <- newJournalId $ random ms
+      let st = newMsgQueueState rjId
+      hs_ <-
+        if forWrite
+          then Just <$> newJournalHandles st rjId
+          else Nothing <$ backupQueueState statePath
+      removeJournalIfExists dir rs
+      unless (journalId ws == journalId rs) $ removeJournalIfExists dir ws
+      pure (st, hs_)
+      where
+        newJournalHandles st rjId = do
+          sh <- openBackupQueueState st shouldBackup
+          appendState_ sh st
+          rh <- closeOnException sh $ createNewJournal dir rjId
+          pure MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing}
+    openBackupQueueState st shouldBackup
+      | shouldBackup = do
+          -- State backup is made in two steps to mitigate the crash during the backup.
+          -- Temporary backup file will be used when it is present.
+          let tempBackup = statePath <> ".bak"
+          renameFile statePath tempBackup -- 1) temp backup
+          sh <- openFile statePath AppendMode
+          closeOnException sh $ appendState sh st -- 2) save state to new file
+          backupQueueState tempBackup -- 3) timed backup
+          pure sh
+      | otherwise = openFile statePath AppendMode
+    backupQueueState path = do
+      ts <- getCurrentTime
+      renameFile path $ stateBackupPath statePath ts
+      -- remove old backups
+      times <- sort . mapMaybe backupPathTime <$> listDirectory dir
+      let toDelete = filter (< expireBackupsBefore ms) $ take (length times - keepMinBackups config) times
+      mapM_ (safeRemoveFile "removeBackups" . stateBackupPath statePath) toDelete
+      where
+        backupPathTime :: FilePath -> Maybe UTCTime
+        backupPathTime = iso8601ParseM . T.unpack <=< T.stripSuffix ".bak" <=< T.stripPrefix statePathPfx . T.pack
+        statePathPfx = T.pack $ takeFileName statePath <> "."
+
+mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s)
+mkJournalQueue queue st hs_ = do
+  state <- newTVarIO st
+  tipMsg <- newTVarIO Nothing
+  handles <- newTVarIO hs_
+  -- using the same queue lock which is currently locked,
+  -- to avoid map lookup on queue operations
+  pure JournalMsgQueue {queue, state, tipMsg, handles}
+
+chooseReadJournal :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
+chooseReadJournal q' q log' hs = do
+  st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q)
+  case writeHandle hs of
+    Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do
+      -- switching to write journal
+      atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing}
+      hClose $ readHandle hs
+      when log' $ removeJournal (queueDirectory $ queue q) rs
+      let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws}
+          !st' = st {readState = rs'}
+      updateQueueState q' q log' hs st' $ pure ()
+      pure $ Just (rs', wh)
+    _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing
+    _ -> pure $ Just (rs, readHandle hs)
+
+updateQueueState :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
+updateQueueState q' q log' hs st a = do
+  unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st
+  when log' $ appendState (stateHandle hs) st
+  atomically $ writeTVar (queueState q') $ Just $! qState st
+  atomically $ writeTVar (state q) st >> a
+
+appendState :: Handle -> MsgQueueState -> IO ()
+appendState h = E.uninterruptibleMask_ . appendState_ h
+{-# INLINE appendState #-}
+
+appendState_ :: Handle -> MsgQueueState -> IO ()
+appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n'
+
+updateReadPos :: JournalQueue s -> JournalMsgQueue s -> Bool -> Int64 -> MsgQueueHandles -> IO ()
+updateReadPos q' q log' len hs = do
+  st@MsgQueueState {readState = rs, size} <- readTVarIO (state q)
+  let JournalState {msgPos, bytePos} = rs
+  let msgPos' = msgPos + 1
+      rs' = rs {msgPos = msgPos', bytePos = bytePos + len}
+      st' = st {readState = rs', size = size - 1}
+  updateQueueState q' q log' hs st' $ writeTVar (tipMsg q) Nothing
+
+msgQueueDirectory :: JournalMsgStore s -> RecipientId -> FilePath
+msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId =
+  storePath </> B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId)
+  where
+    splitSegments _ "" = []
+    splitSegments 1 s = [s]
+    splitSegments n s =
+      let (seg, s') = B.splitAt 2 s
+       in seg : splitSegments (n - 1) s'
+
+msgQueueStatePath :: FilePath -> String -> FilePath
+msgQueueStatePath dir queueId = dir </> (queueLogFileName <> "." <> queueId <> logFileExt)
+
+createNewJournal :: FilePath -> ByteString -> IO Handle
+createNewJournal dir journalId = do
+  let path = journalFilePath dir journalId -- TODO retry if file exists
+  h <- openFile path ReadWriteMode
+  B.hPutStr h ""
+  pure h
+
+newJournalId :: TVar StdGen -> IO ByteString
+newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12)
+
+openJournals :: JournalMsgStore s -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
+openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do
+  let rjId = journalId rs
+      wjId = journalId ws
+  openJournal rs >>= \case
+    Left path
+      | rjId == wjId -> do
+          logError $ "STORE: openJournals, no read/write file - creating new file, " <> T.pack path
+          newReadJournal
+      | otherwise -> do
+          let rs' = (newJournalState wjId) {msgCount = msgCount ws, byteCount = byteCount ws}
+              st' = st {readState = rs', size = msgCount ws}
+          openJournal rs' >>= \case
+            Left path' -> do
+              logError $ "STORE: openJournals, no read and write files - creating new file, read: " <> T.pack path <> ", write: " <> T.pack path'
+              newReadJournal
+            Right rh -> do
+              logError $ "STORE: openJournals, no read file - switched to write file, " <> T.pack path
+              closeOnException rh $ fixFileSize rh $ bytePos ws
+              pure (st', rh, Nothing)
+    Right rh
+      | rjId == wjId -> do
+          closeOnException rh $ fixFileSize rh $ bytePos ws
+          pure (st, rh, Nothing)
+      | otherwise -> closeOnException rh $ do
+          fixFileSize rh $ byteCount rs
+          openJournal ws >>= \case
+            Left path -> do
+              let msgs = msgCount rs
+                  bytes = byteCount rs
+                  size' = msgs - msgPos rs
+                  ws' = (newJournalState rjId) {msgPos = msgs, msgCount = msgs, bytePos = bytes, byteCount = bytes}
+                  st' = st {writeState = ws', size = size'} -- we don't amend canWrite to trigger QCONT
+              logError $ "STORE: openJournals, no write file, " <> T.pack path
+              pure (st', rh, Nothing)
+            Right wh -> do
+              closeOnException wh $ fixFileSize wh $ bytePos ws
+              pure (st, rh, Just wh)
+  where
+    newReadJournal = do
+      rjId' <- newJournalId $ random ms
+      rh <- createNewJournal dir rjId'
+      let st' = newMsgQueueState rjId'
+      closeOnException rh $ appendState sh st'
+      pure (st', rh, Nothing)
+    openJournal :: JournalState t -> IO (Either FilePath Handle)
+    openJournal JournalState {journalId} =
+      let path = journalFilePath dir journalId
+       in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path)
+    -- do that for all append operations
+
+fixFileSize :: Handle -> Int64 -> IO ()
+fixFileSize h pos = do
+  let pos' = fromIntegral pos
+  size <- IO.hFileSize h
+  if
+    | size > pos' -> do
+        name <- IO.hShow h
+        logWarn $ "STORE: fixFileSize, size " <> tshow size <> " > pos " <> tshow pos <> " - truncating, " <> T.pack name
+        IO.hSetFileSize h pos'
+    | size < pos' -> do
+        -- From code logic this can't happen.
+        name <- IO.hShow h
+        E.throwIO $ userError $ "fixFileSize size " <> show size <> " < pos " <> show pos <> " - aborting: " <> name
+    | otherwise -> pure ()
+
+removeJournal :: FilePath -> JournalState t -> IO ()
+removeJournal dir JournalState {journalId} =
+  safeRemoveFile "removeJournal" $ journalFilePath dir journalId
+
+removeJournalIfExists :: FilePath -> JournalState t -> IO ()
+removeJournalIfExists dir JournalState {journalId} = do
+  let path = journalFilePath dir journalId
+  handleError "removeJournalIfExists" path $
+    whenM (doesFileExist path) $ removeFile path
+
+safeRemoveFile :: Text -> FilePath -> IO ()
+safeRemoveFile cxt path = handleError cxt path $ removeFile path
+
+handleError :: Text -> FilePath -> IO () -> IO ()
+handleError cxt path a =
+  a `catchAny` \e -> logError $ "STORE: " <> cxt <> ", " <> T.pack path <> ", " <> tshow e
+
+-- This function is supposed to be resilient to crashes while updating state files,
+-- and also resilient to crashes during its execution.
+readQueueState :: JournalMsgStore s -> FilePath -> IO (Maybe MsgQueueState, Bool)
+readQueueState JournalMsgStore {config} statePath =
+  ifM
+    (doesFileExist tempBackup)
+    (renameFile tempBackup statePath >> readState)
+    (ifM (doesFileExist statePath) readState $ pure (Nothing, False))
+  where
+    tempBackup = statePath <> ".bak"
+    readState = do
+      ls <- B.lines <$> readFileTail
+      case ls of
+        [] -> do
+          logWarn $ "STORE: readWriteQueueState, empty queue state, " <> T.pack statePath
+          pure (Nothing, False)
+        _ -> do
+          r <- useLastLine (length ls) True ls
+          forM_ (fst r) $ \st ->
+            unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st
+          pure r
+    useLastLine len isLastLine ls = case strDecode $ last ls of
+      Right st ->
+        -- when state file has fewer than maxStateLines, we don't compact it
+        let shouldBackup = len > maxStateLines config || not isLastLine
+         in pure (Just st, shouldBackup)
+      Left e -- if the last line failed to parse
+        | isLastLine -> case init ls of -- or use the previous line
+            [] -> do
+              logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath
+              pure (Nothing, True) -- backup state file, because last line was invalid
+            ls' -> do
+              logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath
+              useLastLine len False ls'
+        | otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e
+    readFileTail =
+      IO.withFile statePath ReadMode $ \h -> do
+        size <- IO.hFileSize h
+        let sz = stateTailSize config
+            sz' = fromIntegral sz
+        if size > sz'
+          then IO.hSeek h AbsoluteSeek (size - sz') >> B.hGet h sz
+          else B.hGet h (fromIntegral size)
+
+stateBackupPath :: FilePath -> UTCTime -> FilePath
+stateBackupPath statePath ts = statePath <> "." <> iso8601Show ts <> ".bak"
+
+validQueueState :: MsgQueueState -> Bool
+validQueueState MsgQueueState {readState = rs, writeState = ws, size}
+  | journalId rs == journalId ws =
+      alwaysValid
+        && msgPos rs <= msgPos ws
+        && msgCount rs == msgCount ws
+        && bytePos rs <= bytePos ws
+        && byteCount rs == byteCount ws
+        && size == msgCount rs - msgPos rs
+  | otherwise =
+      alwaysValid
+        && size == msgCount ws + msgCount rs - msgPos rs
+  where
+    alwaysValid =
+      msgPos rs <= msgCount rs
+        && bytePos rs <= byteCount rs
+        && msgPos ws == msgCount ws
+        && bytePos ws == byteCount ws
+
+-- TODO [postgres] possibly, we need to remove the lock from map
+deleteQueue_ :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s)))
+deleteQueue_ ms q =
+  runExceptT $ isolateQueueId "deleteQueue_" ms rId $
+    deleteStoreQueue (queueStore_ ms) q >>= mapM remove
+  where
+    rId = recipientId q
+    remove r@(_, mq_) = do
+      mapM_ closeMsgQueueHandles mq_
+      removeQueueDirectory ms rId
+      pure r
+
+closeMsgQueue :: JournalQueue s -> IO ()
+closeMsgQueue JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ closeMsgQueueHandles
+
+closeMsgQueueHandles :: JournalMsgQueue s -> IO ()
+closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
+  where
+    closeHandles (MsgQueueHandles sh rh wh_) = do
+      hClose sh
+      hClose rh
+      mapM_ hClose wh_
+
+removeQueueDirectory :: JournalMsgStore s -> RecipientId -> IO ()
+removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st
+
+removeQueueDirectory_ :: FilePath -> IO ()
+removeQueueDirectory_ dir =
+  handleError "removeQueueDirectory" dir $ removePathForcibly dir
+
+hAppend :: Handle -> Int64 -> ByteString -> IO ()
+hAppend h pos s = do
+  fixFileSize h pos
+  IO.hSeek h SeekFromEnd 0
+  B.hPutStr h s
+
+hGetMsgAt :: Handle -> Int64 -> IO (Message, Int64)
+hGetMsgAt h pos = do
+  IO.hSeek h AbsoluteSeek $ fromIntegral pos
+  s <- B.hGetLine h
+  case strDecode s of
+    Right !msg ->
+      let !len = fromIntegral (B.length s) + 1
+       in pure (msg, len)
+    Left e -> E.throwIO $ userError $ "hGetMsgAt invalid message: " <> e
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile f mode = do
+  h <- IO.openFile f mode
+  IO.hSetBuffering h LineBuffering
+  pure h
+
+hClose :: Handle -> IO ()
+hClose h =
+  IO.hClose h `catchAny` \e -> do
+    name <- IO.hShow h
+    logError $ "STORE: hClose, " <> T.pack name <> ", " <> tshow e
+
+closeOnException :: Handle -> IO a -> IO a
+closeOnException h a = a `E.onException` hClose h

src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs

@@ -0,0 +1,43 @@
+module Simplex.Messaging.Server.MsgStore.Journal.SharedLock
+  ( withLockWaitShared,
+    withLockMapWaitShared,
+    withSharedWaitLock,
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Monad
+import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Agent.Client (getMapLock)
+import Simplex.Messaging.Protocol (RecipientId)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (($>>), ($>>=))
+
+-- wait until shared lock with passed ID is released and take lock
+withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> String -> IO a -> IO a
+withLockWaitShared rId lock shared name =
+  E.bracket_
+    (atomically $ waitShared rId shared >> putTMVar lock name)
+    (void $ atomically $ takeTMVar lock)
+
+-- wait until shared lock with passed ID is released and take lock from Map for this ID
+withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> String -> IO a -> IO a
+withLockMapWaitShared rId locks shared name a =
+  E.bracket
+    (atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name)
+    (atomically . takeTMVar)
+    (const a)
+
+waitShared :: RecipientId -> TMVar RecipientId -> STM ()
+waitShared rId shared = tryReadTMVar shared >>= mapM_ (\rId' -> when (rId == rId') retry)
+
+-- wait until lock with passed ID in Map is released and take shared lock for this ID
+withSharedWaitLock :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> IO a -> IO a
+withSharedWaitLock rId locks shared =
+  E.bracket_
+    (atomically $ waitLock >> putTMVar shared rId)
+    (atomically $ takeTMVar shared)
+  where
+    waitLock = TM.lookup rId locks $>>= tryReadTMVar $>> retry

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

@@ -1,129 +1,180 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.STM
-  ( STMMsgStore,
-    MsgQueue (msgQueue),
-    newMsgStore,
-    getMsgQueue,
-    delMsgQueue,
-    delMsgQueueSize,
-    writeMsg,
-    tryPeekMsg,
-    tryPeekMsgIO,
-    tryDelMsg,
-    tryDelPeekMsg,
-    deleteExpiredMsgs,
-    getQueueSize,
+  ( STMMsgStore (..),
+    STMStoreConfig (..),
+    STMQueue,
   )
 where
 
-import qualified Data.ByteString.Char8 as B
+import Control.Concurrent.STM
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime (systemSeconds))
-import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import UnliftIO.STM
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore.Types
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Util ((<$$>), ($>>=))
 
-data MsgQueue = MsgQueue
-  { msgQueue :: TQueue Message,
-    quota :: Int,
+data STMMsgStore = STMMsgStore
+  { storeConfig :: STMStoreConfig,
+    queueStore_ :: STMQueueStore STMQueue
+  }
+
+data STMQueue = STMQueue
+  { -- To avoid race conditions and errors when restoring queues,
+    -- Nothing is written to TVar when queue is deleted.
+    recipientId' :: RecipientId,
+    queueRec' :: TVar (Maybe QueueRec),
+    msgQueue' :: TVar (Maybe STMMsgQueue)
+  }
+
+data STMMsgQueue = STMMsgQueue
+  { msgTQueue :: TQueue Message,
     canWrite :: TVar Bool,
     size :: TVar Int
   }
 
-type STMMsgStore = TMap RecipientId MsgQueue
+data STMStoreConfig = STMStoreConfig
+  { storePath :: Maybe FilePath,
+    quota :: Int
+  }
 
-newMsgStore :: IO STMMsgStore
-newMsgStore = TM.emptyIO
+instance StoreQueueClass STMQueue where
+  type MsgQueue STMQueue = STMMsgQueue
+  recipientId = recipientId'
+  {-# INLINE recipientId #-}
+  queueRec = queueRec'
+  {-# INLINE queueRec #-}
+  msgQueue = msgQueue'
+  {-# INLINE msgQueue #-}
+  withQueueLock _ _ = id
+  {-# INLINE withQueueLock #-}
 
--- The reason for double lookup is that majority of messaging queues exist,
--- because multiple messages are sent to the same queue,
--- so the first lookup without STM transaction will return the queue faster.
--- In case the queue does not exist, it needs to be looked-up again inside transaction.
-getMsgQueue :: STMMsgStore -> RecipientId -> Int -> IO MsgQueue
-getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) pure
-  where
-    maybeNewQ = TM.lookup rId st >>= maybe newQ pure
-    newQ = do
-      msgQueue <- newTQueue
-      canWrite <- newTVar True
-      size <- newTVar 0
-      let q = MsgQueue {msgQueue, quota, canWrite, size}
-      TM.insert rId q st
-      pure q
+instance MsgStoreClass STMMsgStore where
+  type StoreMonad STMMsgStore = STM
+  type QueueStore STMMsgStore = STMQueueStore STMQueue
+  type StoreQueue STMMsgStore = STMQueue
+  type MsgStoreConfig STMMsgStore = STMStoreConfig
 
-delMsgQueue :: STMMsgStore -> RecipientId -> IO ()
-delMsgQueue st rId = atomically $ TM.delete rId st
+  newMsgStore :: STMStoreConfig -> IO STMMsgStore
+  newMsgStore storeConfig = do
+    queueStore_ <- newQueueStore @STMQueue ()
+    pure STMMsgStore {storeConfig, queueStore_}
 
-delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
-delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size)
+  closeMsgStore = closeQueueStore @STMQueue . queueStore_
+  {-# INLINE closeMsgStore #-}
+  withActiveMsgQueues = withLoadedQueues . queueStore_
+  {-# INLINE withActiveMsgQueues #-}
+  unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
+  {-# INLINE unsafeWithAllMsgQueues #-}
 
-writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool))
-writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do
-  canWrt <- readTVar canWrite
-  empty <- isEmptyTQueue q
-  if canWrt || empty
-    then do
-      canWrt' <- (quota >) <$> readTVar size
-      writeTVar canWrite $! canWrt'
-      modifyTVar' size (+ 1)
-      if canWrt'
-        then writeTQueue q msg $> Just (msg, empty)
-        else (writeTQueue q $! msgQuota) $> Nothing
-    else pure Nothing
-  where
-    msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+  expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
+  expireOldMessages _tty ms now ttl =
+    withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs ms now (now - ttl)
 
-tryPeekMsgIO :: MsgQueue -> IO (Maybe Message)
-tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsgIO #-}
+  logQueueStates _ = pure ()
+  {-# INLINE logQueueStates #-}
+  logQueueState _ = pure ()
+  {-# INLINE logQueueState #-}
+  queueStore = queueStore_
+  {-# INLINE queueStore #-}
 
--- TODO remove once deliverToSub is split
-tryPeekMsg :: MsgQueue -> STM (Maybe Message)
-tryPeekMsg = tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsg #-}
+  mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
+  {-# INLINE mkQueue #-}
 
-tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message)
-tryDelMsg mq msgId' = atomically $
-  tryPeekMsg mq >>= \case
-    msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_
-      | otherwise -> pure Nothing
-    _ -> pure Nothing
+  getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue
+  getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure
+    where
+      newQ = do
+        msgTQueue <- newTQueue
+        canWrite <- newTVar True
+        size <- newTVar 0
+        let q = STMMsgQueue {msgTQueue, canWrite, size}
+        writeTVar msgQueue' (Just q)
+        pure q
 
--- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message)
-tryDelPeekMsg mq msgId' = atomically $
-  tryPeekMsg mq >>= \case
-    msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq)
-      | otherwise -> pure (Nothing, msg_)
-    _ -> pure (Nothing, Nothing)
+  getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
+  getPeekMsgQueue _ q@STMQueue {msgQueue'} = readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
 
-deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int
-deleteExpiredMsgs mq old = atomically $ loop 0
-  where
-    loop dc =
-      tryPeekMsg mq >>= \case
-        Just Message {msgTs}
-          | systemSeconds msgTs < old ->
-              tryDeleteMsg_ mq >> loop (dc + 1)
-        _ -> pure dc
+  -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
+  withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
+  withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case
+    Just q -> do
+      r <- action q
+      sz <- getQueueSize_ q
+      pure (Just r, sz)
+    Nothing -> pure (Nothing, 0)
 
-tryDeleteMsg_ :: MsgQueue -> STM ()
-tryDeleteMsg_ MsgQueue {msgQueue = q, size} =
-  tryReadTQueue q >>= \case
-    Just _ -> modifyTVar' size (subtract 1)
-    _ -> pure ()
+  deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
+  deleteQueue ms q = fst <$$> deleteStoreQueue (queueStore_ ms) q
 
-getQueueSize :: MsgQueue -> IO Int
-getQueueSize MsgQueue {size} = readTVarIO size
+  deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
+  deleteQueueSize ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM (traverse getSize)
+    -- traverse operates on the second tuple element
+    where
+      getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
+
+  getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message]
+  getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
+    where
+      snapshotTQueue q = do
+        msgs <- flushTQueue q
+        mapM_ (writeTQueue q) msgs
+        pure msgs
+
+  writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg ms q' _logState msg = liftIO $ atomically $ do
+    STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True
+    canWrt <- readTVar canWrite
+    empty <- isEmptyTQueue q
+    if canWrt || empty
+      then do
+        canWrt' <- (quota >) <$> readTVar size
+        writeTVar canWrite $! canWrt'
+        modifyTVar' size (+ 1)
+        if canWrt'
+          then (writeTQueue q $! msg) $> Just (msg, empty)
+          else (writeTQueue q $! msgQuota) $> Nothing
+      else pure Nothing
+    where
+      STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms
+      msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
+
+  setOverQuota_ :: STMQueue -> IO ()
+  setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
+
+  getQueueSize_ :: STMMsgQueue -> STM Int
+  getQueueSize_ STMMsgQueue {size} = readTVar size
+
+  tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
+  tryPeekMsg_ _ = tryPeekTQueue . msgTQueue
+  {-# INLINE tryPeekMsg_ #-}
+
+  tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
+  tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState =
+    tryReadTQueue q >>= \case
+      Just _ -> modifyTVar' size (subtract 1)
+      _ -> pure ()
+
+  isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a
+  isolateQueue _ _ = liftIO . atomically
+  {-# INLINE isolateQueue #-}
+
+  unsafeRunStore :: STMQueue -> String -> STM a -> IO a
+  unsafeRunStore _ _ = atomically
+  {-# INLINE unsafeRunStore #-}

src/Simplex/Messaging/Server/MsgStore/Types.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Redundant multi-way if" #-}
+
+module Simplex.Messaging.Server.MsgStore.Types where
+
+import Control.Concurrent.STM
+import Control.Monad.Trans.Except
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.Kind
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock.System (SystemTime (systemSeconds))
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Util ((<$$>), ($>>=))
+
+class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where
+  type StoreMonad s = (m :: Type -> Type) | m -> s
+  type MsgStoreConfig s = c | c -> s
+  type StoreQueue s = q | q -> s
+  type QueueStore s = qs | qs -> s
+  newMsgStore :: MsgStoreConfig s -> IO s
+  closeMsgStore :: s -> IO ()
+  withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
+  -- This function can only be used in server CLI commands or before server is started.
+  unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
+  -- tty, store, now, ttl
+  expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
+  logQueueStates :: s -> IO ()
+  logQueueState :: StoreQueue s -> StoreMonad s ()
+  queueStore :: s -> QueueStore s
+
+  -- message store methods
+  mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s)
+  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s))
+  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue s), Message))
+
+  -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
+  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue (StoreQueue s) -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
+  deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
+  deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
+  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s [Message]
+  writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
+  getQueueSize_ :: MsgQueue (StoreQueue s) -> StoreMonad s Int
+  tryPeekMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s (Maybe Message)
+  tryDeleteMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> Bool -> StoreMonad s ()
+  isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
+  unsafeRunStore :: StoreQueue s -> String -> StoreMonad s a -> IO a
+
+data MSType = MSMemory | MSJournal
+
+data QSType = QSMemory | QSPostgres
+
+data SMSType :: MSType -> Type where
+  SMSMemory :: SMSType 'MSMemory
+  SMSJournal :: SMSType 'MSJournal
+
+data SQSType :: QSType -> Type where
+  SQSMemory :: SQSType 'QSMemory
+  SQSPostgres :: SQSType 'QSPostgres
+
+data MessageStats = MessageStats
+  { storedMsgsCount :: Int,
+    expiredMsgsCount :: Int,
+    storedQueues :: Int
+  }
+
+instance Monoid MessageStats where
+  mempty = MessageStats 0 0 0
+  {-# INLINE mempty #-}
+
+instance Semigroup MessageStats where
+  MessageStats a b c <> MessageStats x y z = MessageStats (a + x) (b + y) (c + z)
+  {-# INLINE (<>) #-}
+
+newMessageStats :: MessageStats
+newMessageStats = MessageStats 0 0 0
+
+addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
+addQueue st = addQueue_ (queueStore st) (mkQueue st)
+{-# INLINE addQueue #-}
+
+getQueue :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
+getQueue st = getQueue_ (queueStore st) (mkQueue st)
+{-# INLINE getQueue #-}
+
+getQueueRec :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
+getQueueRec st party qId =
+  getQueue st party qId
+    $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q))
+
+getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int
+getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
+{-# INLINE getQueueSize #-}
+
+tryPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
+tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
+{-# INLINE tryPeekMsg #-}
+
+tryDelMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
+tryDelMsg st q msgId' =
+  withPeekMsgQueue st q "tryDelMsg" $
+    maybe (pure Nothing) $ \(mq, msg) ->
+      if
+        | messageId msg == msgId' ->
+            tryDeleteMsg_ q mq True $> Just msg
+        | otherwise -> pure Nothing
+
+-- atomic delete (== read) last and peek next message if available
+tryDelPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
+tryDelPeekMsg st q msgId' =
+  withPeekMsgQueue st q "tryDelPeekMsg" $
+    maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
+      if
+        | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
+        | otherwise -> pure (Nothing, Just msg)
+
+-- The action is called with Nothing when it is known that the queue is empty
+withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
+withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a
+{-# INLINE withPeekMsgQueue #-}
+
+deleteExpiredMsgs :: MsgStoreClass s => s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
+deleteExpiredMsgs st q old =
+  isolateQueue q "deleteExpiredMsgs" $
+    getMsgQueue st q False >>= deleteExpireMsgs_ old q
+
+expireQueueMsgs :: MsgStoreClass s => s -> Int64 -> Int64 -> StoreQueue s -> StoreMonad s MessageStats
+expireQueueMsgs st now old q = do
+  (expired_, stored) <- withIdleMsgQueue now st q $ deleteExpireMsgs_ old q
+  pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1}
+
+deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int
+deleteExpireMsgs_ old q mq = do
+  n <- loop 0
+  logQueueState q
+  pure n
+  where
+    loop dc =
+      tryPeekMsg_ q mq >>= \case
+        Just Message {msgTs}
+          | systemSeconds msgTs < old ->
+              tryDeleteMsg_ q mq False >> loop (dc + 1)
+        _ -> pure dc

src/Simplex/Messaging/Server/Prometheus.hs

@@ -0,0 +1,386 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
+
+module Simplex.Messaging.Server.Prometheus where
+
+import Data.Int (Int64)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime (..), diffUTCTime)
+import Data.Time.Clock.System (systemEpochDay)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Network.Socket (ServiceName)
+import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Transport.Server (SocketStats (..))
+
+data ServerMetrics = ServerMetrics
+  { statsData :: ServerStatsData,
+    activeQueueCounts :: PeriodStatCounts,
+    activeNtfCounts :: PeriodStatCounts,
+    queueCount :: Int,
+    notifierCount :: Int
+  }
+
+data RealTimeMetrics = RealTimeMetrics
+  { socketStats :: [(ServiceName, SocketStats)],
+    threadsCount :: Int,
+    clientsCount :: Int,
+    smpSubsCount :: Int,
+    smpSubClientsCount :: Int,
+    ntfSubsCount :: Int,
+    ntfSubClientsCount :: Int
+  }
+
+{-# FOURMOLU_DISABLE\n#-}
+prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
+prometheusMetrics sm rtm ts =
+  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info
+  where
+    ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} = sm
+    RealTimeMetrics
+      { socketStats,
+        threadsCount,
+        clientsCount,
+        smpSubsCount,
+        smpSubClientsCount,
+        ntfSubsCount,
+        ntfSubClientsCount
+      } = rtm
+    ServerStatsData
+      { _fromTime,
+        _qCreated,
+        _qSecured,
+        _qDeletedAll,
+        _qDeletedAllB,
+        _qDeletedNew,
+        _qDeletedSecured,
+        _qBlocked,
+        _qSub,
+        _qSubAllB,
+        _qSubAuth,
+        _qSubDuplicate,
+        _qSubProhibited,
+        _qSubEnd,
+        _qSubEndB,
+        _ntfCreated,
+        _ntfDeleted,
+        _ntfDeletedB,
+        _ntfSub,
+        _ntfSubB,
+        _ntfSubAuth,
+        _ntfSubDuplicate,
+        _msgSent,
+        _msgSentAuth,
+        _msgSentQuota,
+        _msgSentLarge,
+        _msgSentBlock,
+        _msgRecv,
+        _msgRecvGet,
+        _msgGet,
+        _msgGetNoMsg,
+        _msgGetAuth,
+        _msgGetDuplicate,
+        _msgGetProhibited,
+        _msgExpired,
+        _activeQueues,
+        _msgSentNtf,
+        _msgRecvNtf,
+        _activeQueuesNtf,
+        _msgNtfs,
+        _msgNtfsB,
+        _msgNtfNoSub,
+        _msgNtfLost,
+        _msgNtfExpired,
+        _pRelays,
+        _pRelaysOwn,
+        _pMsgFwds,
+        _pMsgFwdsOwn,
+        _pMsgFwdsRecv,
+        _qCount,
+        _msgCount,
+        _ntfCount
+      } = statsData
+    time =
+      "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
+      \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\
+      \\n"
+    queues =
+      "# Queues\n\
+      \# ------\n\
+      \\n\
+      \# HELP simplex_smp_queues_created Created queues\n\
+      \# TYPE simplex_smp_queues_created counter\n\
+      \simplex_smp_queues_created " <> mshow _qCreated <> "\n# qCreated\n\
+      \\n\
+      \# HELP simplex_smp_queues_secured Secured queues\n\
+      \# TYPE simplex_smp_queues_secured counter\n\
+      \simplex_smp_queues_secured " <> mshow _qSecured <> "\n# qSecured\n\
+      \\n\
+      \# HELP simplex_smp_queues_deleted Deleted queues\n\
+      \# TYPE simplex_smp_queues_deleted counter\n\
+      \simplex_smp_queues_deleted{type=\"all\"} " <> mshow _qDeletedAll <> "\n# qDeleted\n\
+      \simplex_smp_queues_deleted{type=\"new\"} " <> mshow _qDeletedNew <> "\n# qDeletedNew\n\
+      \simplex_smp_queues_deleted{type=\"secured\"} " <> mshow _qDeletedSecured <> "\n# qDeletedSecured\n\
+      \\n\
+      \# HELP simplex_smp_queues_blocked Deleted queues\n\
+      \# TYPE simplex_smp_queues_blocked counter\n\
+      \simplex_smp_queues_blocked " <> mshow _qBlocked <> "\n# qBlocked\n\
+      \\n\
+      \# HELP simplex_smp_queues_deleted_batch Batched requests to delete queues\n\
+      \# TYPE simplex_smp_queues_deleted_batch counter\n\
+      \simplex_smp_queues_deleted_batch " <> mshow _qDeletedAllB <> "\n# qDeletedAllB\n\
+      \\n\
+      \# HELP simplex_smp_queues_total1 Total number of stored queues (first type of count).\n\
+      \# TYPE simplex_smp_queues_total1 gauge\n\
+      \simplex_smp_queues_total1 " <> mshow _qCount <> "\n# qCount\n\
+      \\n\
+      \# HELP simplex_smp_queues_total2 Total number of stored queues (second type of count).\n\
+      \# TYPE simplex_smp_queues_total2 gauge\n\
+      \simplex_smp_queues_total2 " <> mshow queueCount <> "\n# qCount2\n\
+      \\n\
+      \# HELP simplex_smp_queues_daily Daily active queues.\n\
+      \# TYPE simplex_smp_queues_daily gauge\n\
+      \simplex_smp_queues_daily " <> mstr (dayCount ps) <> "\n# dayMsgQueues\n\
+      \\n\
+      \# HELP simplex_smp_queues_weekly Weekly active queues.\n\
+      \# TYPE simplex_smp_queues_weekly gauge\n\
+      \simplex_smp_queues_weekly " <> mstr (weekCount ps) <> "\n# weekMsgQueues\n\
+      \\n\
+      \# HELP simplex_smp_queues_monthly Monthly active queues.\n\
+      \# TYPE simplex_smp_queues_monthly gauge\n\
+      \simplex_smp_queues_monthly " <> mstr (monthCount ps) <> "\n# monthMsgQueues\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_daily Daily active queues with notifications.\n\
+      \# TYPE simplex_smp_queues_notify_daily gauge\n\
+      \simplex_smp_queues_notify_daily " <> mstr (dayCount psNtf) <> "\n# dayCountNtf\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_weekly Weekly active queues with notifications.\n\
+      \# TYPE simplex_smp_queues_notify_weekly gauge\n\
+      \simplex_smp_queues_notify_weekly " <> mstr (weekCount psNtf) <> "\n# weekCountNtf\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\
+      \# TYPE simplex_smp_queues_notify_monthly gauge\n\
+      \simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\
+      \\n"
+    subscriptions =
+      "# Subscriptions\n\
+      \# -------------\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_successes Successful subscriptions.\n\
+      \# TYPE simplex_smp_subscribtion_successes counter\n\
+      \simplex_smp_subscribtion_successes " <> mshow _qSub <> "\n# qSub\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_successes_batch Batched successful subscriptions.\n\
+      \# TYPE simplex_smp_subscribtion_successes_batch counter\n\
+      \simplex_smp_subscribtion_successes_batch " <> mshow _qSubAllB <> "\n# qSubAllB\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_end Ended subscriptions.\n\
+      \# TYPE simplex_smp_subscribtion_end counter\n\
+      \simplex_smp_subscribtion_end " <> mshow _qSubEnd <> "\n# qSubEnd\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_end_batch Batched ended subscriptions.\n\
+      \# TYPE simplex_smp_subscribtion_end_batch counter\n\
+      \simplex_smp_subscribtion_end_batch " <> mshow _qSubEndB <> "\n# qSubEndB\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_errors Subscription errors.\n\
+      \# TYPE simplex_smp_subscribtion_errors counter\n\
+      \simplex_smp_subscribtion_errors{type=\"auth\"} " <> mshow _qSubAuth <> "\n# qSubAuth\n\
+      \simplex_smp_subscribtion_errors{type=\"duplicate\"} " <> mshow _qSubDuplicate <> "\n# qSubDuplicate\n\
+      \simplex_smp_subscribtion_errors{type=\"prohibited\"} " <> mshow _qSubProhibited <> "\n# qSubProhibited\n\
+      \\n"
+    messages =
+      "# Messages\n\
+      \# --------\n\
+      \\n\
+      \# HELP simplex_smp_messages_sent Sent messages.\n\
+      \# TYPE simplex_smp_messages_sent counter\n\
+      \simplex_smp_messages_sent " <> mshow _msgSent <> "\n# msgSent\n\
+      \\n\
+      \# HELP simplex_smp_messages_sent_errors Total number of messages errors by type.\n\
+      \# TYPE simplex_smp_messages_sent_errors counter\n\
+      \simplex_smp_messages_sent_errors{type=\"auth\"} " <> mshow _msgSentAuth <> "\n# msgSentAuth\n\
+      \simplex_smp_messages_sent_errors{type=\"quota\"} " <> mshow _msgSentQuota <> "\n# msgSentQuota\n\
+      \simplex_smp_messages_sent_errors{type=\"large\"} " <> mshow _msgSentLarge <> "\n# msgSentLarge\n\
+      \simplex_smp_messages_sent_errors{type=\"block\"} " <> mshow _msgSentBlock <> "\n# msgSentBlock\n\
+      \\n\
+      \# HELP simplex_smp_messages_received Received messages.\n\
+      \# TYPE simplex_smp_messages_received counter\n\
+      \simplex_smp_messages_received " <> mshow _msgRecv <> "\n# msgRecv\n\
+      \\n\
+      \# HELP simplex_smp_messages_expired Expired messages.\n\
+      \# TYPE simplex_smp_messages_expired counter\n\
+      \simplex_smp_messages_expired " <> mshow _msgExpired <> "\n# msgExpired\n\
+      \\n\
+      \# HELP simplex_smp_messages_total Total number of messages stored.\n\
+      \# TYPE simplex_smp_messages_total gauge\n\
+      \simplex_smp_messages_total " <> mshow _msgCount <> "\n# msgCount\n\
+      \\n"
+    ntfMessages =
+      "# Notification messages (client)\n\
+      \# ------------------------------\n\
+      \\n\
+      \# HELP simplex_smp_messages_notify_sent Sent messages with notification flag (cleint).\n\
+      \# TYPE simplex_smp_messages_notify_sent counter\n\
+      \simplex_smp_messages_notify_sent " <> mshow _msgSentNtf <> "\n# msgSentNtf\n\
+      \\n\
+      \# HELP simplex_smp_messages_notify_received Received messages with notification flag (client).\n\
+      \# TYPE simplex_smp_messages_notify_received counter\n\
+      \simplex_smp_messages_notify_received " <> mshow _msgRecvNtf <> "\n# msgRecvNtf\n\
+      \\n\
+      \# HELP simplex_smp_messages_notify_get_sent Requests to get messages with notification flag (client).\n\
+      \# TYPE simplex_smp_messages_notify_get_sent counter\n\
+      \simplex_smp_messages_notify_get_sent " <> mshow _msgGet <> "\n# msgGet\n\
+      \\n\
+      \# HELP simplex_smp_messages_notify_get_received Succesfully received get requests messages with notification flag (client).\n\
+      \# TYPE simplex_smp_messages_notify_get_received counter\n\
+      \simplex_smp_messages_notify_get_received " <> mshow _msgRecvGet <> "\n# msgRecvGet\n\
+      \\n\
+      \# HELP simplex_smp_messages_notify_get_errors Error events with messages with notification flag (client). \n\
+      \# TYPE simplex_smp_messages_notify_get_errors counter\n\
+      \simplex_smp_messages_notify_get_errors{type=\"nomsg\"} " <> mshow _msgGetNoMsg <> "\n# msgGetNoMsg\n\
+      \simplex_smp_messages_notify_get_errors{type=\"auth\"} " <> mshow _msgGetAuth <> "\n# msgGetAuth\n\
+      \simplex_smp_messages_notify_get_errors{type=\"duplicate\"} " <> mshow _msgGetDuplicate <> "\n# msgGetDuplicate\n\
+      \simplex_smp_messages_notify_get_errors{type=\"prohibited\"} " <> mshow _msgGetProhibited <> "\n# msgGetProhibited\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\n\
+      \# TYPE simplex_smp_queues_notify_created counter\n\
+      \simplex_smp_queues_notify_created " <> mshow _ntfCreated <> "\n# ntfCreated\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\n\
+      \# TYPE simplex_smp_queues_notify_deleted counter\n\
+      \simplex_smp_queues_notify_deleted " <> mshow _ntfDeleted <> "\n# ntfDeleted\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\
+      \# TYPE simplex_smp_queues_notify_deleted_batch counter\n\
+      \simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_total1 Total number of stored queues with notification flag (first type of count).\n\
+      \# TYPE simplex_smp_queues_notify_total1 gauge\n\
+      \simplex_smp_queues_notify_total1 " <> mshow _ntfCount <> "\n# ntfCount1\n\
+      \\n\
+      \# HELP simplex_smp_queues_notify_total2 Total number of stored queues with notification flag (second type of count).\n\
+      \# TYPE simplex_smp_queues_notify_total2 gauge\n\
+      \simplex_smp_queues_notify_total2 " <> mshow notifierCount <> "\n# ntfCount2\n\
+      \\n"
+    ntfs =
+      "# Notifications (server)\n\
+      \# ----------------------\n\
+      \\n\
+      \# HELP simplex_smp_messages_ntf_successes Successful events with notification messages (to ntf server). \n\
+      \# TYPE simplex_smp_messages_ntf_successes counter\n\
+      \simplex_smp_messages_ntf_successes " <> mshow _msgNtfs <> "\n# msgNtfs\n\
+      \\n\
+      \# HELP simplex_smp_messages_ntf_successes_batch Successful batched events with notification messages (to ntf server). \n\
+      \# TYPE simplex_smp_messages_ntf_successes_batch counter\n\
+      \simplex_smp_messages_ntf_successes_batch " <> mshow _msgNtfsB <> "\n# msgNtfsB\n\
+      \\n\
+      \# HELP simplex_smp_messages_ntf_errors Error events with notification messages (to ntf server). \n\
+      \# TYPE simplex_smp_messages_ntf_errors counter\n\
+      \simplex_smp_messages_ntf_errors{type=\"nosub\"} " <> mshow _msgNtfNoSub <> "\n# msgNtfNoSub\n\
+      \simplex_smp_messages_ntf_errors{type=\"lost\"} " <> mshow _msgNtfLost <> "\n# msgNtfLost\n\
+      \simplex_smp_messages_ntf_errors{type=\"expired\"} " <> mshow _msgNtfExpired <> "\n# msgNtfExpired\n\
+      \\n\
+      \# HELP simplex_smp_subscription_ntf_requests Subscription requests with notification flag (from ntf server). \n\
+      \# TYPE simplex_smp_subscription_ntf_requests counter\n\
+      \simplex_smp_subscription_ntf_requests " <> mshow _ntfSub <> "\n# ntfSub\n\
+      \\n\
+      \# HELP simplex_smp_subscription_ntf_requests_batch Batched subscription requests with notification flag (from ntf server). \n\
+      \# TYPE simplex_smp_subscription_ntf_requests_batch counter\n\
+      \simplex_smp_subscription_ntf_requests_batch " <> mshow _ntfSubB <> "\n# ntfSubB\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_ntf_errors Subscription errors with notification flag (from ntf server). \n\
+      \# TYPE simplex_smp_subscribtion_ntf_errors counter\n\
+      \simplex_smp_subscribtion_ntf_errors{type=\"auth\"} " <> mshow _ntfSubAuth <> "\n# ntfSubAuth\n\
+      \simplex_smp_subscribtion_ntf_errors{type=\"duplicate\"} " <> mshow _ntfSubDuplicate <> "\n# ntfSubDuplicate\n\
+      \\n"
+    relays =
+      "# Relays\n\
+      \# ------\n\
+      \\n\
+      \# HELP simplex_smp_relay_sessions_requests Session requests through relay.\n\
+      \# TYPE simplex_smp_relay_sessions_requests counter\n\
+      \simplex_smp_relay_sessions_requests{source=\"all\"} " <> mshow (_pRequests _pRelays) <> "\n# pRelays_pRequests\n\
+      \simplex_smp_relay_sessions_requests{source=\"own\"} " <> mshow (_pRequests _pRelaysOwn) <> "\n# pRelaysOwn_pRequests\n\
+      \\n\
+      \# HELP simplex_smp_relay_sessions_successes Successful session events through relay.\n\
+      \# TYPE simplex_smp_relay_sessions_successes counter\n\
+      \simplex_smp_relay_sessions_successes{source=\"all\"} " <> mshow (_pSuccesses _pRelays) <> "\n# pRelays_pSuccesses\n\
+      \simplex_smp_relay_sessions_successes{source=\"own\"} " <> mshow (_pSuccesses _pRelaysOwn) <> "\n# pRelaysOwn_pSuccesses\n\
+      \\n\
+      \# HELP simplex_smp_relay_sessions_errors Error session events through relay.\n\
+      \# TYPE simplex_smp_relay_sessions_errors counter\n\
+      \simplex_smp_relay_sessions_errors{source=\"all\",type=\"connect\"} " <> mshow (_pErrorsConnect _pRelays) <> "\n# pRelays_pErrorsConnect\n\
+      \simplex_smp_relay_sessions_errors{source=\"all\",type=\"compat\"} " <> mshow (_pErrorsCompat _pRelays) <> "\n# pRelays_pErrorsCompat\n\
+      \simplex_smp_relay_sessions_errors{source=\"all\",type=\"other\"} " <> mshow (_pErrorsOther _pRelays) <> "\n# pRelays_pErrorsOther\n\
+      \simplex_smp_relay_sessions_errors{source=\"own\",type=\"connect\"} " <> mshow (_pErrorsConnect _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsConnect\n\
+      \simplex_smp_relay_sessions_errors{source=\"own\",type=\"compat\"} " <> mshow (_pErrorsCompat _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsCompat\n\
+      \simplex_smp_relay_sessions_errors{source=\"own\",type=\"other\"} " <> mshow (_pErrorsOther _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsOther\n\
+      \\n\
+      \# HELP simplex_smp_relay_messages_requests Message requests sent through relay.\n\
+      \# TYPE simplex_smp_relay_messages_requests counter\n\
+      \simplex_smp_relay_messages_requests{source=\"all\"} " <> mshow (_pRequests _pMsgFwds) <> "\n# pMsgFwds_pRequests\n\
+      \simplex_smp_relay_messages_requests{source=\"own\"} " <> mshow (_pRequests _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pRequests\n\
+      \\n\
+      \# HELP simplex_smp_relay_messages_successes Successful messages sent through relay.\n\
+      \# TYPE simplex_smp_relay_messages_successes counter\n\
+      \simplex_smp_relay_messages_successes{source=\"all\"} " <> mshow (_pSuccesses _pMsgFwds) <> "\n# pMsgFwds_pSuccesses\n\
+      \simplex_smp_relay_messages_successes{source=\"own\"} " <> mshow (_pSuccesses _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pSuccesses\n\
+      \\n\
+      \# HELP simplex_smp_relay_messages_errors Error events with messages sent through relay.\n\
+      \# TYPE simplex_smp_relay_messages_errors counter\n\
+      \simplex_smp_relay_messages_errors{source=\"all\",type=\"connect\"} " <> mshow (_pErrorsConnect _pMsgFwds) <> "\n# pMsgFwds_pErrorsConnect\n\
+      \simplex_smp_relay_messages_errors{source=\"all\",type=\"compat\"} " <> mshow (_pErrorsCompat _pMsgFwds) <> "\n# pMsgFwds_pErrorsCompat\n\
+      \simplex_smp_relay_messages_errors{source=\"all\",type=\"other\"} " <> mshow (_pErrorsOther _pMsgFwds) <> "\n# pMsgFwds_pErrorsOther\n\
+      \simplex_smp_relay_messages_errors{source=\"own\",type=\"connect\"} " <> mshow (_pErrorsConnect _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsConnect\n\
+      \simplex_smp_relay_messages_errors{source=\"own\",type=\"compat\"} " <> mshow (_pErrorsCompat _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsCompat\n\
+      \simplex_smp_relay_messages_errors{source=\"own\",type=\"other\"} " <> mshow (_pErrorsOther _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsOther\n\
+      \\n\
+      \# HELP simplex_smp_relay_messages_received Relay messages statistics.\n\
+      \# TYPE simplex_smp_relay_messages_received counter\n\
+      \simplex_smp_relay_messages_received " <> mshow _pMsgFwdsRecv <> "\n# pMsgFwdsRecv\n\
+      \\n"
+    info =
+      "# Info\n\
+      \# ----\n\
+      \\n"
+      <> socketsMetric socketsAccepted "simplex_smp_sockets_accepted" "Accepted sockets"
+      <> socketsMetric socketsClosed "simplex_smp_sockets_closed" "Closed sockets"
+      <> socketsMetric socketsActive "simplex_smp_sockets_active" "Active sockets"
+      <> socketsMetric socketsLeaked "simplex_smp_sockets_leaked" "Leaked sockets"
+      <> "# HELP simplex_smp_threads_total Threads\n\
+      \# TYPE simplex_smp_threads_total gauge\n\
+      \simplex_smp_threads_total " <> mshow threadsCount <> "\n\
+      \\n\
+      \# HELP simplex_smp_clients_total Clients\n\
+      \# TYPE simplex_smp_clients_total gauge\n\
+      \simplex_smp_clients_total " <> mshow clientsCount <> "\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_total Total subscriptions\n\
+      \# TYPE simplex_smp_subscribtion_total gauge\n\
+      \simplex_smp_subscribtion_total " <> mshow smpSubsCount <> "\n# smpSubs\n\
+      \\n\
+      \# HELP simplex_smp_subscribtion_clients_total Subscribed clients, first counting method\n\
+      \# TYPE simplex_smp_subscribtion_clients_total gauge\n\
+      \simplex_smp_subscribtion_clients_total " <> mshow smpSubClientsCount <> "\n# smpSubClients\n\
+      \\n\
+      \# HELP simplex_smp_subscription_ntf_total Total notification subscripbtions (from ntf server)\n\
+      \# TYPE simplex_smp_subscription_ntf_total gauge\n\
+      \simplex_smp_subscription_ntf_total " <> mshow ntfSubsCount <> "\n# ntfSubs\n\
+      \\n\
+      \# HELP simplex_smp_subscription_ntf_clients_total Total subscribed NTF servers, first counting method\n\
+      \# TYPE simplex_smp_subscription_ntf_clients_total gauge\n\
+      \simplex_smp_subscription_ntf_clients_total " <> mshow ntfSubClientsCount <> "\n# ntfSubClients\n"
+    socketsMetric :: (SocketStats -> Int) -> Text -> Text -> Text
+    socketsMetric sel metric descr =
+      "# HELP " <> metric <> " " <> descr <> "\n"
+        <> "# TYPE " <> metric <> " gauge\n"
+        <> T.concat (map (\(port, ss) -> metric <> "{port=\"" <> T.pack port <> "\"} " <> mshow (sel ss) <> "\n") socketStats)
+        <> "\n"
+    mstr a = T.pack a <> " " <> tsEpoch
+    mshow :: Show a => a -> Text
+    mshow = mstr . show
+    tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000
+    epoch = UTCTime systemEpochDay 0
+{-# FOURMOLU_ENABLE\n#-}

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,25 +1,37 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Server.QueueStore where
 
+import Control.Applicative ((<|>))
+import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+#if defined(dbServerPostgres)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
+import Simplex.Messaging.Util (eitherToMaybe)
+#endif
 
 data QueueRec = QueueRec
-  { recipientId :: !RecipientId,
-    recipientKey :: !RcvPublicAuthKey,
+  { recipientKey :: !RcvPublicAuthKey,
     rcvDhSecret :: !RcvDhSecret,
     senderId :: !SenderId,
     senderKey :: !(Maybe SndPublicAuthKey),
     sndSecure :: !SenderCanSecure,
     notifier :: !(Maybe NtfCreds),
-    status :: !ServerQueueStatus,
+    status :: !ServerEntityStatus,
     updatedAt :: !(Maybe RoundedSystemTime)
   }
   deriving (Show)
@@ -37,10 +49,33 @@ instance StrEncoding NtfCreds where
     (notifierId, notifierKey, rcvNtfDhSecret) <- strP
     pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
-data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
+data ServerEntityStatus
+  = EntityActive
+  | EntityBlocked BlockingInfo
+  | EntityOff
+  deriving (Eq, Show)
+
+instance StrEncoding ServerEntityStatus where
+  strEncode = \case
+    EntityActive -> "active"
+    EntityBlocked info -> "blocked," <> strEncode info
+    EntityOff -> "off"
+  strP =
+    "active" $> EntityActive
+      <|> "blocked," *> (EntityBlocked <$> strP)
+      <|> "off" $> EntityOff
+
+#if defined(dbServerPostgres)
+instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
+#endif
 
 newtype RoundedSystemTime = RoundedSystemTime Int64
   deriving (Eq, Ord, Show)
+#if defined(dbServerPostgres)
+  deriving newtype (FromField, ToField)
+#endif
 
 instance StrEncoding RoundedSystemTime where
   strEncode (RoundedSystemTime t) = strEncode t

src/Simplex/Messaging/Server/QueueStore/Postgres.hs

@@ -0,0 +1,444 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Simplex.Messaging.Server.QueueStore.Postgres
+  ( PostgresQueueStore (..),
+    PostgresStoreCfg (..),
+    batchInsertQueues,
+    foldQueueRecs,
+  )
+where
+
+import qualified Control.Exception as E
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Bitraversable (bimapM)
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.List (intersperse)
+import qualified Data.Map.Strict as M
+import Data.Maybe (catMaybes)
+import qualified Data.Text as T
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError)
+import qualified Database.PostgreSQL.Simple as DB
+import qualified Database.PostgreSQL.Simple.Copy as DB
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))
+import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import GHC.IO (catchAny)
+import Simplex.Messaging.Agent.Client (withLockMap)
+import Simplex.Messaging.Agent.Lock (Lock)
+import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Postgres.Config
+import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
+import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO)
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (firstRow, ifM, tshow, (<$$>))
+import System.Exit (exitFailure)
+import System.IO (IOMode (..), hFlush, stdout)
+import UnliftIO.STM
+
+#if !defined(dbPostgres)
+import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+#endif
+
+data PostgresQueueStore q = PostgresQueueStore
+  { dbStore :: DBStore,
+    dbStoreLog :: Maybe (StoreLog 'WriteMode),
+    -- this map caches all created and opened queues
+    queues :: TMap RecipientId q,
+    -- this map only cashes the queues that were attempted to send messages to,
+    senders :: TMap SenderId RecipientId,
+    -- this map only cashes the queues that were attempted to be subscribed to,
+    notifiers :: TMap NotifierId RecipientId,
+    notifierLocks :: TMap NotifierId Lock,
+    deletedTTL :: Int64
+  }
+
+instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
+  type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
+
+  newQueueStore :: PostgresStoreCfg  -> IO (PostgresQueueStore q)
+  newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
+    dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
+    queues <- TM.emptyIO
+    senders <- TM.emptyIO
+    notifiers <- TM.emptyIO
+    notifierLocks <- TM.emptyIO
+    pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, notifiers, notifierLocks, deletedTTL}
+    where
+      err e = do
+        logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
+        exitFailure
+
+  closeQueueStore :: PostgresQueueStore q -> IO ()
+  closeQueueStore PostgresQueueStore {dbStore, dbStoreLog} = do
+    closeDBStore dbStore
+    mapM_ closeStoreLog dbStoreLog
+
+  loadedQueues = queues
+  {-# INLINE loadedQueues #-}
+
+  compactQueues :: PostgresQueueStore q -> IO Int64
+  compactQueues st@PostgresQueueStore {deletedTTL} = do
+    old <- subtract deletedTTL . systemSeconds <$> liftIO getSystemTime
+    fmap (fromRight 0) $ runExceptT $ withDB' "removeDeletedQueues" st $ \db ->
+      DB.execute db "DELETE FROM msg_queues WHERE deleted_at < ?" (Only old)
+
+  queueCounts :: PostgresQueueStore q -> IO QueueCounts
+  queueCounts st =
+    withConnection (dbStore st) $ \db -> do
+      (queueCount, notifierCount) : _ <-
+        DB.query_
+          db
+          [sql|
+            SELECT
+              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count, 
+              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count
+          |]
+      pure QueueCounts {queueCount, notifierCount}
+
+  -- this implementation assumes that the lock is already taken by addQueue
+  -- and relies on unique constraints in the database to prevent duplicate IDs.
+  addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
+  addQueue_ st mkQ rId qr = do
+    sq <- mkQ rId qr
+    withQueueLock sq "addQueue_" $ E.uninterruptibleMask_ $ runExceptT $ do
+      void $ withDB "addQueue_" st $ \db ->
+        E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr))
+          >>= bimapM handleDuplicate pure
+      atomically $ TM.insert rId sq queues
+      atomically $ TM.insert (senderId qr) rId senders
+      withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
+      pure sq
+    where
+      PostgresQueueStore {queues, senders} = st
+      -- Not doing duplicate checks in maps as the probability of duplicates is very low.
+      -- It needs to be reconsidered when IDs are supplied by the users.
+      -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
+      -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
+
+  getQueue_ :: DirectParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ st mkQ party qId = case party of
+    SRecipient -> getRcvQueue qId
+    SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue
+    SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue
+    where
+      PostgresQueueStore {queues, senders, notifiers} = st
+      getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right)
+      loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure ()
+      loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders
+      loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare
+      loadQueue condition insertRef =
+        E.uninterruptibleMask_ $ runExceptT $ do
+          (rId, qRec) <-
+            withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
+              DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
+          liftIO $ do
+            sq <- mkQ rId qRec -- loaded queue
+            -- This lock prevents the scenario when the queue is added to cache,
+            -- while another thread is proccessing the same queue in withAllMsgQueues
+            -- without adding it to cache, possibly trying to open the same files twice.
+            -- Alse see comment in idleDeleteExpiredMsgs.
+            withQueueLock sq "getQueue_" $ atomically $
+              -- checking the cache again for concurrent reads,
+              -- use previously loaded queue if exists.
+              TM.lookup rId queues >>= \case
+                Just sq' -> pure sq'
+                Nothing -> do
+                  insertRef rId
+                  TM.insert rId sq queues
+                  pure sq
+
+  secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
+  secureQueue st sq sKey =
+    withQueueRec sq "secureQueue" $ \q -> do
+      verify q
+      assertUpdated $ withDB' "secureQueue" st $ \db ->
+        DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL" (sKey, rId)
+      atomically $ writeTVar (queueRec sq) $ Just q {senderKey = Just sKey}
+      withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey
+    where
+      rId = recipientId sq
+      verify q = case senderKey q of
+        Just k | sKey /= k -> throwE AUTH
+        _ -> pure ()
+
+  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
+    withQueueRec sq "addQueueNotifier" $ \q ->
+      ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
+        ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do
+          assertUpdated $ withDB "addQueueNotifier" st $ \db ->
+            E.try (update db) >>= bimapM handleDuplicate pure
+          nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId
+          let !q' = q {notifier = Just ntfCreds}
+          atomically $ writeTVar (queueRec sq) $ Just q'
+          -- cache queue notifier ID – after notifier is added ntf server will likely subscribe
+          atomically $ TM.insert nId rId notifiers
+          withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
+          pure nId_
+    where
+      PostgresQueueStore {notifiers} = st
+      rId = recipientId sq
+      update db =
+        DB.execute
+          db
+          [sql|
+            UPDATE msg_queues
+            SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ?
+            WHERE recipient_id = ? AND deleted_at IS NULL
+          |]
+          (nId, notifierKey, rcvNtfDhSecret, rId)
+
+  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier st sq =
+    withQueueRec sq "deleteQueueNotifier" $ \q ->
+      ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} ->
+        withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do
+          assertUpdated $ withDB' "deleteQueueNotifier" st update
+          atomically $ TM.delete nId $ notifiers st
+          atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
+          withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
+          pure nId
+    where
+      rId = recipientId sq
+      update db =
+        DB.execute
+          db
+          [sql|
+            UPDATE msg_queues
+            SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL
+            WHERE recipient_id = ? AND deleted_at IS NULL
+          |]
+          (Only rId)
+
+  suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
+  suspendQueue st sq =
+    setStatusDB "suspendQueue" st sq EntityOff $
+      withLog "suspendQueue" st (`logSuspendQueue` recipientId sq)
+
+  blockQueue :: PostgresQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ())
+  blockQueue st sq info =
+    setStatusDB "blockQueue" st sq (EntityBlocked info) $
+      withLog "blockQueue" st $ \sl -> logBlockQueue sl (recipientId sq) info
+
+  unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
+  unblockQueue st sq =
+    setStatusDB "unblockQueue" st sq EntityActive $
+      withLog "unblockQueue" st (`logUnblockQueue` recipientId sq)
+  
+  updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  updateQueueTime st sq t =
+    withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
+      if updatedAt == Just t
+        then pure q
+        else do
+          assertUpdated $ withDB' "updateQueueTime" st $ \db ->
+            DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (t, rId)
+          let !q' = q {updatedAt = Just t}
+          atomically $ writeTVar (queueRec sq) $ Just q'
+          withLog "updateQueueTime" st $ \sl -> logUpdateQueueTime sl rId t
+          pure q'
+    where
+      rId = recipientId sq
+
+  -- this method is called from JournalMsgStore deleteQueue that already locks the queue
+  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do
+    q <- ExceptT $ readQueueRecIO qr
+    RoundedSystemTime ts <- liftIO getSystemDate
+    assertUpdated $ withDB' "deleteStoreQueue" st $ \db ->
+      DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
+    atomically $ writeTVar qr Nothing
+    atomically $ TM.delete (senderId q) $ senders st
+    forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st
+    mq_ <- atomically $ swapTVar (msgQueue sq) Nothing
+    withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
+    pure (q, mq_)
+    where
+      rId = recipientId sq
+      qr = queueRec sq
+
+batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO Int64
+batchInsertQueues tty queues toStore = do
+  qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues)
+  putStrLn $ "Importing " <> show (length qs) <> " queues..."
+  let st = dbStore toStore
+  count <-
+    withConnection st $ \db -> do
+      DB.copy_ db "COPY msg_queues (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)"
+      mapM_ (putQueue db) (zip [1..] qs)
+      DB.putCopyEnd db
+  Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues")
+  putStrLn $ progress count
+  pure qCnt
+  where
+    putQueue db (i :: Int, q) = do
+      DB.putCopyData db $ queueRecToText q
+      when (tty && i `mod` 100000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout
+    progress i = "Imported: " <> show i <> " queues"
+
+insertQueueQuery :: Query
+insertQueueQuery =
+  [sql|
+    INSERT INTO msg_queues
+      (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at)
+    VALUES (?,?,?,?,?,?,?,?,?,?,?)
+  |]
+
+foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
+foldQueueRecs tty st skipOld_ f = do
+  (n, r) <- withConnection (dbStore st) $ \db ->
+    foldRecs db (0 :: Int, mempty) $ \(i, acc) row -> do
+      r <- f $ rowToQueueRec row
+      let !i' = i + 1
+          !acc' = acc <> r
+      when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout
+      pure (i', acc')
+  when tty $ putStrLn $ progress n
+  pure r
+  where
+    foldRecs db = case skipOld_ of
+      Nothing -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL")
+      Just old -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old)
+    progress i = "Processed: " <> show i <> " records"
+
+queueRecQuery :: Query
+queueRecQuery =
+  [sql|
+    SELECT recipient_id, recipient_key, rcv_dh_secret,
+      sender_id, sender_key, snd_secure,
+      notifier_id, notifier_key, rcv_ntf_dh_secret,
+      status, updated_at
+    FROM msg_queues
+  |]
+
+type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime)
+
+queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow
+queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
+  (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt)
+
+queueRecToText :: (RecipientId, QueueRec) -> ByteString
+queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
+  LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
+  where
+    tabFields = BB.char7 ',' `intersperse` fields
+    fields =
+      [ renderField (toField rId),
+        renderField (toField recipientKey),
+        renderField (toField rcvDhSecret),
+        renderField (toField senderId),
+        nullable senderKey,
+        renderField (toField sndSecure),
+        nullable (notifierId <$> n),
+        nullable (notifierKey <$> n),
+        nullable (rcvNtfDhSecret <$> n),
+        BB.char7 '"' <> renderField (toField status) <> BB.char7 '"',
+        nullable updatedAt
+      ]
+    nullable :: ToField a => Maybe a -> Builder
+    nullable = maybe mempty (renderField . toField)
+    renderField :: Action -> Builder
+    renderField = \case
+      Plain bld -> bld
+      Escape s -> BB.byteString s
+      EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s
+      EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
+      Many as -> mconcat (map renderField as)
+
+rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec)
+rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) =
+  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
+   in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt})
+
+setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
+setStatusDB op st sq status writeLog =
+  withQueueRec sq op $ \q -> do
+    assertUpdated $ withDB' op st $ \db ->
+      DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ? AND deleted_at IS NULL" (status, recipientId sq)
+    atomically $ writeTVar (queueRec sq) $ Just q {status}
+    writeLog
+
+withQueueRec :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
+withQueueRec sq op action =
+  withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
+
+assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO ()
+assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH))
+
+withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a
+withDB' op st action = withDB op st $ fmap Right . action
+
+withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a
+withDB op st action =
+  ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure
+  where
+    logErr :: E.SomeException -> IO (Either ErrorType a)
+    logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err)
+      where
+        err = op <> ", withDB, " <> show e
+
+withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m ()
+withLog op PostgresQueueStore {dbStoreLog} action =
+  forM_ dbStoreLog $ \sl -> liftIO $ action sl `catchAny` \e ->
+    logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e)
+
+handleDuplicate :: SqlError -> IO ErrorType
+handleDuplicate e = case constraintViolation e of
+  Just (UniqueViolation _) -> pure AUTH
+  _ -> E.throwIO e
+
+-- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL
+
+instance ToField EntityId where toField (EntityId s) = toField $ Binary s
+
+deriving newtype instance FromField EntityId
+
+#if !defined(dbPostgres)
+instance ToField (C.DhSecret 'C.X25519) where toField = toField . Binary . C.dhBytes'
+
+instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder strDecode
+
+instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey
+
+instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey
+#endif