test config, version

* agent: fix deleting messages after delivery to avoid deleting shared message bodies

* fix, comments

* rename

* comment

.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,27 @@
+# 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.

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

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.3.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: [email protected]
-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-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.

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,16 @@
 #!/usr/bin/env sh
 set -eu
 
+# Make sure that PATH variable contains /usr/local/bin
+PATH="/usr/local/bin:$PATH"
+
 # Links to scripts/configs
-scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
-scripts_systemd_smp="$scripts/smp-server.service"
-scripts_systemd_xftp="$scripts/xftp-server.service"
-scripts_update="$scripts/simplex-servers-update"
-scripts_uninstall="$scripts/simplex-servers-uninstall"
-scripts_stopscript="$scripts/simplex-servers-stopscript"
+scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/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"
 
 # Default installation paths
 path_bin="/usr/local/bin"
@@ -22,7 +25,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 +42,539 @@ 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)
+      bin_url="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 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
+        bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${VER}"
+        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
+
   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"
+  
+  curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path"
+
+  type="$(file "$path")"
+
+  case "$type" in
+    *script*|*executable*) chmod +x "$path" ;;
+  esac
+
+  if ! check_sanity "$path" "$check_pattern"; 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
+
+  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 "$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]

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.3.0
+version:        6.3.0.503
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -66,24 +62,26 @@ 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
+
 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 +95,12 @@ 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.Shared
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
@@ -154,34 +118,12 @@ 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.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 +137,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 +145,105 @@ library
       Simplex.RemoteControl.Discovery.Multicast
       Simplex.RemoteControl.Invitation
       Simplex.RemoteControl.Types
+  if flag(client_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.Migrations.M20241210_initial
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
+      if !flag(client_library)
+          exposed-modules:
+              Simplex.Messaging.Agent.Store.Postgres.Util
+  else
+      exposed-modules:
+          Simplex.Messaging.Agent.Store.SQLite
+          Simplex.Messaging.Agent.Store.SQLite.Common
+          Simplex.Messaging.Agent.Store.SQLite.DB
+          Simplex.Messaging.Agent.Store.SQLite.Migrations
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.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.MsgStore
+          Simplex.Messaging.Server.MsgStore.Journal
+          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.Stats
+          Simplex.Messaging.Server.StoreLog
+          Simplex.Messaging.Server.StoreLog.Types
+          Simplex.Messaging.Transport.WebSockets
   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 +253,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,10 +268,8 @@ 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
@@ -258,7 +287,6 @@ library
     , 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.*
@@ -267,24 +295,38 @@ library
     , 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.*
+      , websockets ==0.12.*
+  if flag(client_postgres)
+    build-depends:
+        postgresql-libpq >=0.10.0.0
+      , postgresql-simple ==0.7.*
+      , raw-strings-qq ==1.1.*
+    cpp-options: -DdbPostgres
+  else
+    build-depends:
+        direct-sqlcipher ==2.3.*
+      , sqlcipher-simple ==0.4.*
   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 +334,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 +354,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 +382,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 +398,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 +418,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
@@ -621,6 +432,7 @@ test-suite simplexmq-test
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
+      Fixtures
       NtfClient
       NtfServerTests
       RemoteControl
@@ -636,92 +448,71 @@ test-suite simplexmq-test
       Static
       Static.Embedded
       Paths_simplexmq
+  if !flag(client_postgres)
+      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.*
+      base
+    , aeson
+    , async
+    , base64-bytestring
+    , bytestring
+    , containers
+    , crypton
+    , crypton-x509
+    , crypton-x509-store
+    , crypton-x509-validation
     , deepseq ==1.4.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
+    , 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
+    , memory
+    , mtl
+    , network
+    , process
+    , 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)
     build-depends:
-        bytestring ==0.11.*
-      , template-haskell ==2.20.*
-      , text >=2.0.1 && <2.2
-  if impl(ghc < 9.6.2)
+        postgresql-libpq >=0.10.0.0
+      , postgresql-simple ==0.7.*
+      , raw-strings-qq ==1.1.*
+    cpp-options: -DdbPostgres
+  else
     build-depends:
-        bytestring ==0.10.*
-      , template-haskell ==2.16.*
-      , text >=1.2.3.0 && <1.3
+        sqlcipher-simple

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)
@@ -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
@@ -78,7 +81,8 @@ newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
 newFileRec senderId fileInfo createdAt = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt}
+  fileStatus <- newTVar EntityActive
+  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,6 +14,7 @@ module Simplex.FileTransfer.Server.StoreLog
     logPutFile,
     logAddRecipients,
     logDeleteFile,
+    logBlockFile,
     logAckFile,
   )
 where
@@ -31,7 +32,7 @@ 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.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
 import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow)
@@ -42,7 +43,8 @@ data FileStoreLogRecord
   | 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
@@ -51,6 +53,7 @@ instance StrEncoding FileStoreLogRecord where
     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
@@ -58,6 +61,7 @@ instance StrEncoding FileStoreLogRecord where
         "FPUT " *> (PutFile <$> strP_ <*> strP),
         "FADD " *> (AddRecipients <$> strP_ <*> strP),
         "FDEL " *> (DeleteFile <$> strP),
+        "FBLK " *> (BlockFile <$> strP_ <*> strP),
         "FACK " *> (AckFile <$> strP)
       ]
 
@@ -76,6 +80,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
 
@@ -96,6 +103,7 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
       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
 

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 (..))
 
 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,6 +1,7 @@
 module Simplex.Messaging.Agent.Lock
   ( Lock,
     createLock,
+    createLockIO,
     withLock,
     withLock',
     withGetLock,
@@ -24,6 +25,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 (..))
 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 = blobFieldParser smpP
+
 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.Agent.Store.DB (FromField (..), ToField (..))
 import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
-import Simplex.Messaging.Protocol (SMPServer, XFTPServer, NtfServer)
+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,11 @@ 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 (DBOpts, appMigrations, createDBStore)
+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 +45,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 +542,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 +568,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 +647,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,19 @@
+{-# 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/Postgres.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Store.Postgres
+  ( DBOpts (..),
+    Migrations.appMigrations,
+    Migrations.getCurrentMigrations,
+    createDBStore,
+    closeDBStore,
+    reopenDBStore,
+    execSQL,
+  )
+where
+
+import Control.Exception (throwIO)
+import Control.Monad (unless, void)
+import Data.ByteString (ByteString)
+import Data.Functor (($>))
+import Data.String (fromString)
+import Data.Text (Text)
+import Database.PostgreSQL.Simple (Only (..))
+import 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)
+import UnliftIO.Exception (bracketOnError, onException)
+import UnliftIO.MVar
+import UnliftIO.STM
+
+data DBOpts = DBOpts
+  { connstr :: ByteString,
+    schema :: String
+  }
+
+-- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
+-- If passed schema does not exist in connectInfo database, it will be created.
+-- Applies necessary migrations to schema.
+-- TODO [postgres] authentication / user password, db encryption (?)
+createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do
+  st <- connectPostgresStore connstr schema
+  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 :: ByteString -> String -> IO DBStore
+connectPostgresStore dbConnstr dbSchema = do
+  (dbConn, dbNew) <- connectDB dbConnstr dbSchema -- TODO [postgres] analogue for dbBusyLoop?
+  dbConnection <- newMVar dbConn
+  dbClosed <- newTVarIO False
+  pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed}
+
+connectDB :: ByteString -> String -> IO (DB.Connection, Bool)
+connectDB connstr schema = do
+  db <- PSQL.connectPostgreSQL connstr
+  schemaExists <- prepare db `onException` PSQL.close db
+  let dbNew = not schemaExists
+  pure (db, dbNew)
+  where
+    prepare db = do
+      void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
+      [Only schemaExists] <-
+        PSQL.query
+          db
+          [sql|
+            SELECT EXISTS (
+              SELECT 1 FROM pg_catalog.pg_namespace
+              WHERE nspname = ?
+            )
+          |]
+          (Only schema)
+      unless schemaExists $ void $ PSQL.execute_ db (fromString $ "CREATE SCHEMA " <> schema)
+      void $ PSQL.execute_ db (fromString $ "SET search_path TO " <> schema)
+      pure schemaExists
+
+-- can share with SQLite
+closeDBStore :: DBStore -> IO ()
+closeDBStore st@DBStore {dbClosed} =
+  ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $
+    withConnection st $ \conn -> do
+      DB.close conn
+      atomically $ writeTVar dbClosed True
+
+openPostgresStore_ :: DBStore -> IO ()
+openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} =
+  bracketOnError
+    (takeMVar dbConnection)
+    (tryPutMVar dbConnection)
+    $ \_dbConn -> do
+      (dbConn, _dbNew) <- connectDB dbConnstr dbSchema
+      atomically $ writeTVar dbClosed False
+      putMVar dbConnection dbConn
+
+reopenDBStore :: DBStore -> IO ()
+reopenDBStore st@DBStore {dbClosed} =
+  ifM (readTVarIO dbClosed) open (putStrLn "reopenDBStore: already opened")
+  where
+    open = openPostgresStore_ st
+
+-- TODO [postgres] not necessary for postgres (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,49 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Common
+  ( DBStore (..),
+    withConnection,
+    withConnection',
+    withTransaction,
+    withTransaction',
+    withTransactionPriority,
+  )
+where
+
+import Data.ByteString (ByteString)
+import qualified Database.PostgreSQL.Simple as PSQL
+import UnliftIO.MVar
+import UnliftIO.STM
+
+-- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type)
+data DBStore = DBStore
+  { dbConnstr :: ByteString,
+    dbSchema :: String,
+    dbConnection :: MVar PSQL.Connection,
+    dbClosed :: TVar Bool,
+    dbNew :: Bool
+  }
+
+-- TODO [postgres] connection pool
+withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
+withConnectionPriority DBStore {dbConnection} _priority action =
+  withMVar dbConnection action
+
+withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withConnection st = withConnectionPriority st False
+
+withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withConnection' = withConnection
+
+withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
+withTransaction' = 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,65 @@
+{-# 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_,
+  )
+where
+
+import Control.Monad (void)
+import Data.Int (Int64)
+import Data.Word (Word16, Word32)
+import Database.PostgreSQL.Simple (ResultError (..))
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.FromField (FromField (..), returnError)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+
+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"

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

@@ -0,0 +1,80 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations
+  ( appMigrations,
+    initialize,
+    run,
+    getCurrentMigrations,
+  )
+where
+
+import Control.Monad (void)
+import Data.List (sortOn)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time.Clock (getCurrentTime)
+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.Postgres.Migrations.M20241210_initial
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
+import Simplex.Messaging.Agent.Store.Shared
+import UnliftIO.MVar
+
+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}
+
+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 ->
+        void $ LibPQ.exec pqConn (TE.encodeUtf8 query)
+
+getCurrentMigrations :: PSQL.Connection -> IO [Migration]
+getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
+  where
+    toMigration (name, down) = Migration {name, up = T.pack "", 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/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,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Common
-  ( SQLiteStore (..),
+  ( DBStore (..),
     withConnection,
     withConnection',
     withTransaction,
@@ -30,7 +30,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 +39,8 @@ data SQLiteStore = SQLiteStore
     dbNew :: Bool
   }
 
-withConnectionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a
-withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action
+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 +50,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,63 @@
 {-# 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,
   )
 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 Data.Time (diffUTCTime, getCurrentTime)
-import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow)
+import Database.SQLite.Simple (FromRow, Query, ToRow)
 import qualified Database.SQLite.Simple as SQL
+import Database.SQLite.Simple.FromField (FromField (..))
+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 +66,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 +100,33 @@ 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 #-}
-
 $(J.deriveJSON defaultJSON ''SlowQueryStats)

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

@@ -5,40 +5,29 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Migrations
-  ( Migration (..),
-    MigrationsToRun (..),
-    MTRError (..),
-    DownMigration (..),
-    app,
+  ( appMigrations,
     initialize,
-    get,
     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 (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
@@ -76,13 +65,12 @@ 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
 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),
@@ -120,27 +108,28 @@ schemaMigrations =
     ("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)
+    ("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
-app :: [Migration]
-app = sortOn name $ map migration schemaMigrations
+appMigrations :: [Migration]
+appMigrations = 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 +137,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 +167,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/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,7 +145,6 @@ 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.Version
 import System.Mem.Weak (Weak, deRefWeak)
@@ -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 $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q x $> True)
+  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,10 +237,9 @@ 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 (..))
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
@@ -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 (..))
 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 (blobFieldDecoder, blobFieldParser, 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 = blobFieldParser smpP

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,13 +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 (..))
 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.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake)
 import Simplex.Messaging.Parsers (fromTextField_)
 import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
 import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
@@ -297,12 +296,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 +526,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 +539,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 +547,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,9 +9,8 @@ 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 (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
@@ -41,7 +40,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 +118,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 +137,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 #-}
 
@@ -20,12 +21,19 @@ import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601 (parseISO8601)
 import Data.Typeable (Typeable)
+import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
+import Text.Read (readMaybe)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (ResultError (..))
+import Database.PostgreSQL.Simple.FromField (FromField(..), FieldParser, returnError, Field (..))
+import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid)
+import qualified Data.Text.Encoding as TE
+#else
 import Database.SQLite.Simple (ResultError (..), SQLData (..))
 import Database.SQLite.Simple.FromField (FieldParser, returnError)
 import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
-import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
-import Text.Read (readMaybe)
+#endif
 
 base64P :: Parser ByteString
 base64P = decode <$?> paddedBase64 rawBase64P
@@ -70,6 +78,7 @@ 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
@@ -77,6 +86,14 @@ parseString p = either error id . p . B.pack
 blobFieldParser :: Typeable k => Parser k -> FieldParser k
 blobFieldParser = blobFieldDecoder . parseAll
 
+#if defined(dbPostgres)
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder dec f val = do
+  x <- fromField f val
+  case dec x of
+    Right k -> pure k
+    Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
+#else
 blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
 blobFieldDecoder dec = \case
   f@(Field (SQLBlob b) _) ->
@@ -84,7 +101,20 @@ blobFieldDecoder dec = \case
       Right k -> Ok k
       Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
   f -> returnError ConversionFailed f "expecting SQLBlob column type"
+#endif
 
+-- TODO [postgres] review
+#if defined(dbPostgres)
+fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a
+fromTextField_ fromText f val =
+  if typeOid f `elem` [textOid, varcharOid]
+    then case val of
+      Just t -> case fromText (TE.decodeUtf8 t) of
+        Just x -> pure x
+        _ -> returnError ConversionFailed f "invalid text value"
+      Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field"
+    else returnError Incompatible f "expecting TEXT or VARCHAR column type"
+#else
 fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
 fromTextField_ fromText = \case
   f@(Field (SQLText t) _) ->
@@ -92,6 +122,7 @@ fromTextField_ fromText = \case
       Just x -> Ok x
       _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
   f -> returnError ConversionFailed f "expecting SQLText column type"
+#endif
 
 fstToLower :: String -> String
 fstToLower "" = ""

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
@@ -1759,9 +1818,11 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca
 
 $(J.deriveJSON defaultJSON ''MsgFlags)
 
-$(J.deriveJSON (sumTypeJSON id) ''CommandError)
+$(J.deriveJSON (taggedObjectJSON id) ''CommandError)
 
-$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
+$(J.deriveJSON (taggedObjectJSON 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

@@ -44,11 +44,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)

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,14 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -21,7 +25,7 @@ import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (isJust, isNothing)
 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 (..))
@@ -35,9 +39,11 @@ 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
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
@@ -55,7 +61,10 @@ data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
+    msgStoreType :: AMSType,
     msgQueueQuota :: Int,
+    maxJournalMsgCount :: Int,
+    maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
@@ -70,6 +79,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 +96,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
@@ -111,9 +126,12 @@ defaultMessageExpiration :: ExpirationConfig
 defaultMessageExpiration =
   ExpirationConfig
     { ttl = defMsgExpirationDays * 86400, -- seconds
-      checkInterval = 43200 -- seconds, 12 hours
+      checkInterval = 14400 -- seconds, 4 hours
     }
 
+defaultIdleQueueInterval :: Int64
+defaultIdleQueueInterval = 28800 -- seconds, 8 hours
+
 defNtfExpirationHours :: Int64
 defNtfExpirationHours = 24
 
@@ -134,35 +152,62 @@ defaultInactiveClientExpiration =
 defaultProxyClientConcurrency :: Int
 defaultProxyClientConcurrency = 32
 
+journalMsgStoreDepth :: Int
+journalMsgStoreDepth = 5
+
+defaultMaxJournalStateLines :: Int
+defaultMaxJournalStateLines = 16
+
+defaultMaxJournalMsgCount :: Int
+defaultMaxJournalMsgCount = 256
+
+defaultMsgQueueQuota :: Int
+defaultMsgQueueQuota = 4 -- 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 MsgStore s where
+  MsgStore 'MSMemory = STMMsgStore
+  MsgStore 'MSJournal = JournalMsgStore
+
+data AMsgStore = forall s. (STMStoreClass (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s)
+
+data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s))
+
+data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s))
+
+msgPersistence :: AMsgStoreCfg -> Bool
+msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath
+msgPersistence (AMSC SMSJournal _) = True
+
 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 +219,16 @@ newtype ProxyAgent = ProxyAgent
 
 type ClientId = Int
 
-data Client = Client
+data AClient = forall s. MsgStoreClass (MsgStore s) => AClient (SMSType s) (Client (MsgStore s))
+
+clientId' :: AClient -> ClientId
+clientId' (AClient _ Client {clientId}) = 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 +261,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 :: SMSType s -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore s))
+newClient _msType clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   rcvQ <- newTBQueueIO qSize
@@ -241,17 +291,22 @@ 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, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
   serverActive <- newTVarIO True
   server <- newServer
-  queueStore <- newQueueStore
-  msgStore <- newMsgStore
+  msgStore@(AMS _ store) <- case msgStoreType of
+    AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota}
+    AMSType SMSJournal -> case storeMsgsFile of
+      Just storePath ->
+        let cfg = mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
+         in AMS SMSJournal <$> newMsgStore cfg
+      Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
-  storeLog <-
-    forM storeLogFile $ \f -> do
-      logInfo $ "restoring queues from file " <> T.pack f
-      readWriteQueueStore f queueStore
+  forM_ storeLogFile $ \f -> do
+    logInfo $ "restoring queues from file " <> T.pack f
+    sl <- readWriteQueueStore f store
+    setStoreLog store sl
   tlsServerCreds <- getCredentials "SMP" smpCredentials
   httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
   mapM_ checkHTTPSCredentials httpServerCreds
@@ -262,7 +317,7 @@ 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
     getCredentials protocol creds = do
       files <- missingCreds
@@ -299,10 +354,27 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg
       where
         persistence
           | isNothing storeLogFile = SPMMemoryOnly
-          | isJust (storeMsgsFile config) = SPMMessages
+          | isJust storeMsgsFile = SPMMessages
           | otherwise = SPMQueues
 
+mkJournalStoreConfig :: FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig
+mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
+  JournalStoreConfig
+    { storePath,
+      quota = msgQueueQuota,
+      pathParts = journalMsgStoreDepth,
+      maxMsgCount = maxJournalMsgCount,
+      maxStateLines = maxJournalStateLines,
+      stateTailSize = defaultStateTailSize,
+      idleInterval = idleQueueInterval,
+      expireBackupsAfter = 300, -- 14 * nominalDay,
+      keepMinBackups = 2
+    }
+
 newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}
+
+readWriteQueueStore :: STMStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode)
+readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore

src/Simplex/Messaging/Server/Main.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -20,6 +20,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,7 +28,7 @@ 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
@@ -38,17 +39,18 @@ 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.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
+import Simplex.Messaging.Server.QueueStore.STM (readQueueStore)
+import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (SocksProxy, 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, safeDecodeUtf8, tshow)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -70,25 +72,97 @@ 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 -> withIniFile runServer
     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
+      let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+      storeLogFile <- case enableStoreLog $> 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
+      case cmd of
+        JCImport
+          | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+          | msgsDirExists -> do
+              putStrLn $ storeMsgsJournalDir <> " directory already exists."
+              exitFailure
+          | not msgsFileExists -> do
+              putStrLn $ storeMsgsFilePath <> " file does not exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
+                "Messages not imported"
+              ms <- newJournalMsgStore
+              readQueueStore storeLogFile ms
+              msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration
+              putStrLn "Import completed"
+              printMessageStats "Messages" msgStats
+              putStrLn $ case readMsgStoreType ini of
+                Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
+                Right (AMSType SMSJournal) -> "store_messages set to `journal`"
+                Left e -> e <> ", update it to `journal` in INI file"
+        JCExport
+          | 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
+              readQueueStore storeLogFile ms
+              exportMessages True ms storeMsgsFilePath False
+              putStrLn "Export completed"
+              putStrLn $ case readMsgStoreType ini of
+                Right (AMSType SMSMemory) -> "store_messages set to `memory`"
+                Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
+                Left e -> e <> ", update it to `memory` in INI file"
+        JCDelete
+          | 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
   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`."
+    newJournalMsgStore =
+      let cfg = mkJournalStoreConfig 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"
+    storeMsgsFilePath = combine logPath "smp-server-messages.log"
+    storeMsgsJournalDir = combine logPath "messages"
+    storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
+    readMsgStoreType :: Ini -> Either String AMSType
+    readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages"
+    textToMsgStoreType = \case
+      "memory" -> Right $ AMSType SMSMemory
+      "journal" -> Right $ AMSType SMSJournal
+      s -> Left $ "invalid store_messages: " <> T.unpack s
     httpsCertFile = combine cfgPath "web.crt"
     httpsKeyFile = combine cfgPath "web.key"
     defaultStaticPath = combine logPath "www"
@@ -128,7 +202,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"
@@ -168,14 +242,20 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                    \# and restoring it when the server is started.\n\
                    \# Log is compacted on start (deleted objects are removed).\n"
                 <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-                <> "# 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")
+                <> "# 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")
-                <> "[AUTH]\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\
@@ -248,12 +328,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       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, storeLogFile, msgStoreType, 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
+      checkMsgStoreMode msgStoreType
       putStrLn $ case messageExpiration of
         Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
         _ -> "not expiring messages"
@@ -302,12 +383,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           _ -> enableStoreLog $> path
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
+        iniMsgStoreType = either error id $! readMsgStoreType ini
         serverConfig =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
               tbqSize = 128,
-              msgQueueQuota = 128,
+              msgStoreType = iniMsgStoreType,
+              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 =
@@ -318,8 +403,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                   },
               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",
+              storeMsgsFile = case iniMsgStoreType of
+                AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath
+                AMSType SMSJournal -> Just 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 +417,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 +433,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 +447,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,
@@ -393,6 +485,31 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             pure WebHttpsParams {port, cert, key}
         webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
 
+    checkMsgStoreMode :: AMSType -> IO ()
+    checkMsgStoreMode mode = do
+      msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
+      msgsFileExists <- doesFileExist storeMsgsFilePath
+      case mode of
+        _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
+        AMSType SMSJournal
+          | 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."
+        AMSType SMSMemory
+          | 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
+        _ -> pure ()
+
+    exitConfigureMsgStorage = do
+      putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
+      putStrLn "Configure memory storage."
+      exitFailure
+
 data EmbeddedWebParams = EmbeddedWebParams
   { webStaticPath :: FilePath,
     webHttpPort :: Maybe Int,
@@ -458,12 +575,13 @@ informationIniContent InitOptions {sourceCode, serverInfo} =
        \# 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
+    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
+        <> optName
+        <> ": "
+        <> maybe "entity (organization or person name)" name entity
         <> "\n"
         <> countryStr optName (country =<< entity)
 
@@ -519,6 +637,9 @@ data CliCommand
   | OnlineCert CertOptions
   | Start
   | Delete
+  | Journal JournalCmd
+
+data JournalCmd = JCImport | JCExport | JCDelete
 
 data InitOptions = InitOptions
   { enableStoreLog :: Bool,
@@ -550,6 +671,7 @@ cliCommandP cfgPath logPath iniFile =
         <> 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 "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+        <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
     )
   where
     initP :: Parser InitOptions
@@ -607,22 +729,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")
@@ -690,6 +811,13 @@ cliCommandP cfgPath logPath iniFile =
             disableWeb,
             scripted
           }
+    journalCmdP =
+      hsubparser
+        ( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage"))
+            <> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file"))
+            <> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage"))
+        )
+
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)

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

@@ -0,0 +1,833 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Server.MsgStore.Journal
+  ( JournalMsgStore (queueStore, random, expireBackupsBefore),
+    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,
+  )
+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.Functor (($>))
+import Data.Int (Int64)
+import Data.List (intercalate, sort)
+import Data.Maybe (catMaybes, 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, withLockMap)
+import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore.Types
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>))
+import System.Directory
+import System.Exit
+import System.FilePath (takeFileName, (</>))
+import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout)
+import qualified System.IO as IO
+import System.Random (StdGen, genByteString, newStdGen)
+
+data JournalMsgStore = JournalMsgStore
+  { config :: JournalStoreConfig,
+    random :: TVar StdGen,
+    queueLocks :: TMap RecipientId Lock,
+    queueStore :: STMQueueStore JournalQueue,
+    expireBackupsBefore :: UTCTime
+  }
+
+data JournalStoreConfig = JournalStoreConfig
+  { storePath :: FilePath,
+    pathParts :: Int,
+    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 JournalQueue = JournalQueue
+  { recipientId :: RecipientId,
+    queueLock :: Lock,
+    -- 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),
+    -- system time in seconds since epoch
+    activeAt :: TVar Int64,
+    -- Just True - empty, Just False - non-empty, Nothing - unknown
+    isEmpty :: TVar (Maybe Bool)
+  }
+
+data JMQueue = JMQueue
+  { queueDirectory :: FilePath,
+    statePath :: FilePath
+  }
+
+data JournalMsgQueue = 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)
+
+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 a = StoreIO {unStoreIO :: IO a}
+  deriving newtype (Functor, Applicative, Monad)
+
+instance STMStoreClass JournalMsgStore where
+  stmQueueStore JournalMsgStore {queueStore} = queueStore
+  mkQueue st rId qr = do
+    lock <- getMapLock (queueLocks st) rId
+    q <- newTVar $ Just qr
+    mq <- newTVar Nothing
+    activeAt <- newTVar 0
+    isEmpty <- newTVar Nothing
+    pure $ JournalQueue rId lock q mq activeAt isEmpty
+  msgQueue_' = msgQueue_
+
+instance MsgStoreClass JournalMsgStore where
+  type StoreMonad JournalMsgStore = StoreIO
+  type StoreQueue JournalMsgStore = JournalQueue
+  type MsgQueue JournalMsgStore = JournalMsgQueue
+  type MsgStoreConfig JournalMsgStore = JournalStoreConfig
+
+  newMsgStore :: JournalStoreConfig -> IO JournalMsgStore
+  newMsgStore config = do
+    random <- newTVarIO =<< newStdGen
+    queueLocks <- TM.emptyIO
+    queueStore <- newQueueStore
+    expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime
+    pure JournalMsgStore {config, random, queueLocks, queueStore, expireBackupsBefore}
+
+  setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO ()
+  setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl)
+
+  closeMsgStore JournalMsgStore {queueStore = st} = do
+    readTVarIO (storeLog st) >>= mapM_ closeStoreLog
+    readTVarIO (queues st) >>= mapM_ closeMsgQueue
+
+  -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result.
+  -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started.
+  -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID.
+  -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name.
+  withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (JournalQueue -> IO a) -> IO a
+  withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty)
+    where
+      processStore = do
+        (!count, !res) <- foldQueues 0 processQueue (0, mempty) ("", storePath)
+        putStrLn $ progress count
+        pure res
+      JournalStoreConfig {storePath, pathParts} = config
+      processQueue :: (Int, a) -> (String, FilePath) -> IO (Int, a)
+      processQueue (!i, !r) (queueId, dir) = do
+        when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout
+        r' <- case strDecode $ B.pack queueId of
+          Right rId ->
+            getQueue ms SRecipient rId >>= \case
+              Right q -> unStoreIO (getMsgQueue ms q False) *> action q <* closeMsgQueue q
+              Left AUTH -> do
+                logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir
+                removeQueueDirectory_ dir
+                pure mempty
+              Left e -> do
+                logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e
+                exitFailure
+          Left e -> do
+            logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e
+            exitFailure
+        pure (i + 1, r <> r')
+      progress i = "Processed: " <> show i <> " queues"
+      foldQueues depth f acc (queueId, path) = do
+        let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f
+        listDirs >>= foldM f' acc
+        where
+          listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path
+          queuePath dir = do
+            let !path' = path </> dir
+                !queueId' = queueId <> dir
+            ifM
+              (doesDirectoryExist path')
+              (pure $ Just (queueId', path'))
+              (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))
+
+  logQueueStates :: JournalMsgStore -> IO ()
+  logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState
+
+  logQueueState :: JournalQueue -> StoreIO ()
+  logQueueState q =
+    StoreIO . void $
+      readTVarIO (msgQueue_ q)
+        $>>= \mq -> readTVarIO (handles mq)
+        $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
+
+  recipientId' = recipientId
+  {-# INLINE recipientId' #-}
+
+  queueRec' = queueRec
+  {-# INLINE queueRec' #-}
+
+  getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue
+  getMsgQueue ms@JournalMsgStore {random} 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
+        pure q
+        where
+          createQ :: JMQueue -> IO JournalMsgQueue
+          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 -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message))
+  getPeekMsgQueue ms q@JournalQueue {isEmpty} =
+    StoreIO (readTVarIO isEmpty) >>= \case
+      Just True -> pure Nothing
+      Just False -> peek
+      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 -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int)
+  withIdleMsgQueue now ms@JournalMsgStore {config} q action =
+    StoreIO $ readTVarIO (msgQueue_ q) >>= \case
+      Nothing ->
+        E.bracket
+          (unStoreIO $ getPeekMsgQueue ms q)
+          (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)
+
+  deleteQueue :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType QueueRec)
+  deleteQueue ms q = fst <$$> deleteQueue_ ms q
+
+  deleteQueueSize :: JournalMsgStore -> JournalQueue -> 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 -> JournalMsgQueue -> StoreIO [Message]
+  getQueueMessages_ drainMsgs q = StoreIO (run [])
+    where
+      run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
+      getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg
+        where
+          readMsg (rs, h) = do
+            (msg, len) <- hGetMsgAt h $ bytePos rs
+            updateReadPos q drainMsgs len hs
+            (msg :) <$> run msgs
+
+  writeMsg :: JournalMsgStore -> JournalQueue -> 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
+          atomically $ writeTVar (isEmpty q') (Just False)
+          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 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 -> IO ()
+  setOverQuota_ q =
+    readTVarIO (msgQueue_ q)
+      >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False})
+
+  getQueueSize_ :: JournalMsgQueue -> StoreIO Int
+  getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
+
+  tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message)
+  tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
+    StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty
+    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
+      setEmpty msg = do
+        atomically $ writeTVar (isEmpty q) (Just $ isNothing msg)
+        pure msg
+
+  tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO ()
+  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 mq logState len hs $> Just ()
+
+  isolateQueue :: JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
+  isolateQueue JournalQueue {recipientId, queueLock} op =
+    tryStore' op recipientId . withLock' queueLock op . unStoreIO
+
+updateActiveAt :: JournalQueue -> 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_ $ E.try a >>= either storeErr pure
+  where
+    storeErr :: E.SomeException -> IO (Either ErrorType a)
+    storeErr e =
+      let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
+       in logError ("STORE: " <> T.pack e') $> Left (STORE e')
+
+isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op
+
+openMsgQueue :: JournalMsgStore -> JMQueue -> Bool -> IO JournalMsgQueue
+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
+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 :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
+chooseReadJournal 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 log' hs st' $ pure ()
+      pure $ Just (rs', wh)
+    _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing
+    _ -> pure $ Just (rs, readHandle hs)
+
+updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
+updateQueueState 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 (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 :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO ()
+updateReadPos 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 log' hs st' $ writeTVar (tipMsg q) Nothing
+
+msgQueueDirectory :: JournalMsgStore -> 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 -> 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 -> 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
+
+deleteQueue_ :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue))
+deleteQueue_ ms q =
+  runExceptT $ isolateQueueId "deleteQueue_" ms rId $
+    deleteQueue' ms q >>= mapM remove
+  where
+    rId = recipientId q
+    remove r@(_, mq_) = do
+      mapM_ closeMsgQueueHandles mq_
+      removeQueueDirectory ms rId
+      pure r
+
+closeMsgQueue :: JournalQueue -> IO ()
+closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles
+
+closeMsgQueueHandles :: JournalMsgQueue -> IO ()
+closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
+  where
+    closeHandles (MsgQueueHandles sh rh wh_) = do
+      hClose sh
+      hClose rh
+      mapM_ hClose wh_
+
+removeQueueDirectory :: JournalMsgStore -> 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/STM.hs

@@ -1,129 +1,167 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# 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 (..),
   )
 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.StoreLog
+import Simplex.Messaging.Util ((<$$>), ($>>=))
+import System.IO (IOMode (..))
 
-data MsgQueue = MsgQueue
+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
   { msgQueue :: TQueue Message,
-    quota :: Int,
     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 STMStoreClass STMMsgStore where
+  stmQueueStore = queueStore
+  mkQueue _ rId qr = STMQueue rId <$> newTVar (Just qr) <*> newTVar Nothing
+  msgQueue_' = msgQueue_
 
--- 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 StoreQueue STMMsgStore = STMQueue
+  type MsgQueue STMMsgStore = STMMsgQueue
+  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
+    pure STMMsgStore {storeConfig, queueStore}
 
-delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
-delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size)
+  setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO ()
+  setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl)
 
-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}
+  closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog
 
-tryPeekMsgIO :: MsgQueue -> IO (Maybe Message)
-tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsgIO #-}
+  withAllMsgQueues _ = withActiveMsgQueues
+  {-# INLINE withAllMsgQueues #-}
 
--- TODO remove once deliverToSub is split
-tryPeekMsg :: MsgQueue -> STM (Maybe Message)
-tryPeekMsg = tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsg #-}
+  logQueueStates _ = pure ()
+  {-# INLINE logQueueStates #-}
 
-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
+  logQueueState _ = pure ()
+  {-# INLINE logQueueState #-}
 
--- 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)
+  recipientId' = recipientId
+  {-# INLINE recipientId' #-}
 
-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
+  queueRec' = queueRec
+  {-# INLINE queueRec' #-}
 
-tryDeleteMsg_ :: MsgQueue -> STM ()
-tryDeleteMsg_ MsgQueue {msgQueue = q, size} =
-  tryReadTQueue q >>= \case
-    Just _ -> modifyTVar' size (subtract 1)
-    _ -> pure ()
+  getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue
+  getMsgQueue _ STMQueue {msgQueue_} _ = readTVar msgQueue_ >>= maybe newQ pure
+    where
+      newQ = do
+        msgQueue <- newTQueue
+        canWrite <- newTVar True
+        size <- newTVar 0
+        let q = STMMsgQueue {msgQueue, canWrite, size}
+        writeTVar msgQueue_ (Just q)
+        pure q
 
-getQueueSize :: MsgQueue -> IO Int
-getQueueSize MsgQueue {size} = readTVarIO size
+  getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
+  getPeekMsgQueue _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
+
+  -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
+  withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
+  withIdleMsgQueue _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case
+    Just q -> do
+      r <- action q
+      sz <- getQueueSize_ q
+      pure (Just r, sz)
+    Nothing -> pure (Nothing, 0)
+
+  deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
+  deleteQueue ms q = fst <$$> deleteQueue' ms q
+
+  deleteQueueSize :: STMMsgStore -> STMQueue -> 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 0) (\STMMsgQueue {size} -> readTVarIO size)
+
+  getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message]
+  getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue
+    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 {msgQueue = 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 . msgQueue
+  {-# INLINE tryPeekMsg_ #-}
+
+  tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
+  tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState =
+    tryReadTQueue q >>= \case
+      Just _ -> modifyTVar' size (subtract 1)
+      _ -> pure ()
+
+  isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a
+  isolateQueue _ _ = liftIO . atomically

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

@@ -0,0 +1,142 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+{-# 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 (foldM)
+import Control.Monad.Trans.Except
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.Kind
+import Data.Time.Clock.System (SystemTime (systemSeconds))
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.StoreLog.Types
+import Simplex.Messaging.TMap (TMap)
+import Simplex.Messaging.Util ((<$$>))
+import System.IO (IOMode (..))
+
+data STMQueueStore q = STMQueueStore
+  { queues :: TMap RecipientId q,
+    senders :: TMap SenderId RecipientId,
+    notifiers :: TMap NotifierId RecipientId,
+    storeLog :: TVar (Maybe (StoreLog 'WriteMode))
+  }
+
+class MsgStoreClass s => STMStoreClass s where
+  stmQueueStore :: s -> STMQueueStore (StoreQueue s)
+  mkQueue :: s -> RecipientId -> QueueRec -> STM (StoreQueue s)
+  msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s))
+
+class Monad (StoreMonad 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 MsgQueue s = q | q -> s
+  newMsgStore :: MsgStoreConfig s -> IO s
+  setStoreLog :: s -> StoreLog 'WriteMode -> IO ()
+  closeMsgStore :: s -> IO ()
+  withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
+  logQueueStates :: s -> IO ()
+  logQueueState :: StoreQueue s -> StoreMonad s ()
+  recipientId' :: StoreQueue s -> RecipientId
+  queueRec' :: StoreQueue s -> TVar (Maybe QueueRec)
+  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
+  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
+
+  -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
+  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
+  deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
+  deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
+  getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message]
+  writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
+  getQueueSize_ :: MsgQueue s -> StoreMonad s Int
+  tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
+  tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
+  isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
+
+data MSType = MSMemory | MSJournal
+
+data SMSType :: MSType -> Type where
+  SMSMemory :: SMSType 'MSMemory
+  SMSJournal :: SMSType 'MSJournal
+
+data AMSType = forall s. AMSType (SMSType s)
+
+withActiveMsgQueues :: (STMStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a
+withActiveMsgQueues st f = readTVarIO (queues $ stmQueueStore st) >>= foldM run mempty
+  where
+    run !acc = fmap (acc <>) . f
+
+getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message]
+getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst)
+{-# INLINE getQueueMessages #-}
+
+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 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
+
+-- closed and idle queues will be closed after expiration
+-- returns (expired count, queue size after expiration)
+idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int)
+idleDeleteExpiredMsgs now st q old =
+  isolateQueue q "idleDeleteExpiredMsgs" $
+    withIdleMsgQueue now st q (deleteExpireMsgs_ old q)
+
+deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
+deleteExpireMsgs_ old q mq = do
+  n <- loop 0
+  logQueueState q
+  pure n
+  where
+    loop dc =
+      tryPeekMsg_ q mq >>= \case
+        Just Message {msgTs}
+          | systemSeconds msgTs < old ->
+              tryDeleteMsg_ q mq False >> loop (dc + 1)
+        _ -> pure dc

src/Simplex/Messaging/Server/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,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# 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
 
 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,7 +40,21 @@ 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
 
 newtype RoundedSystemTime = RoundedSystemTime Int64
   deriving (Eq, Ord, Show)

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

@@ -1,120 +1,229 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Simplex.Messaging.Server.QueueStore.STM
-  ( QueueStore (..),
-    newQueueStore,
-    addQueue,
+  ( addQueue,
     getQueue,
+    getQueueRec,
     secureQueue,
     addQueueNotifier,
     deleteQueueNotifier,
     suspendQueue,
+    blockQueue,
+    unblockQueue,
     updateQueueTime,
-    deleteQueue,
+    deleteQueue',
+    newQueueStore,
+    readQueueStore,
+    withLog',
   )
 where
 
+import qualified Control.Exception as E
+import Control.Logger.Simple
 import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Data.Bitraversable (bimapM)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.TMap (TMap)
+import Simplex.Messaging.Server.StoreLog
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, ($>>=))
+import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$))
+import System.IO
 import UnliftIO.STM
 
-data QueueStore = QueueStore
-  { queues :: TMap RecipientId (TVar QueueRec),
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId
-  }
-
-newQueueStore :: IO QueueStore
+newQueueStore :: IO (STMQueueStore q)
 newQueueStore = do
   queues <- TM.emptyIO
   senders <- TM.emptyIO
   notifiers <- TM.emptyIO
-  pure QueueStore {queues, senders, notifiers}
+  storeLog <- newTVarIO Nothing
+  pure STMQueueStore {queues, senders, notifiers, storeLog}
 
-addQueue :: QueueStore -> QueueRec -> IO (Either ErrorType ())
-addQueue QueueStore {queues, senders, notifiers} q@QueueRec {recipientId = rId, senderId = sId, notifier} = atomically $ do
-  ifM hasId (pure $ Left DUPLICATE_) $ do
-    TM.insertM rId (newTVar q) queues
-    TM.insert sId rId senders
-    forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
-    pure $ Right ()
+addQueue :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
+addQueue st rId qr@QueueRec {senderId = sId, notifier}=
+  atomically add
+    $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr)
   where
-    hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
+    STMQueueStore {queues, senders, notifiers} = stmQueueStore st
+    add = ifM hasId (pure $ Left DUPLICATE_) $ do
+      q <- mkQueue st rId qr
+      TM.insert rId q queues
+      TM.insert sId rId senders
+      forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
+      pure $ Right q
+    hasId = or <$> sequence [TM.member rId queues, TM.member sId senders, hasNotifier]
+    hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
 
-getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> IO (Either ErrorType QueueRec)
-getQueue QueueStore {queues, senders, notifiers} party qId =
-  toResult <$> (mapM readTVarIO =<< getVar)
+getQueue :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
+getQueue st party qId =
+  maybe (Left AUTH) Right <$> case party of
+    SRecipient -> TM.lookupIO qId queues
+    SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
+    SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
   where
-    getVar = case party of
-      SRecipient -> TM.lookupIO qId queues
-      SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
-      SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
+    STMQueueStore {queues, senders, notifiers} = stmQueueStore st
 
-secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> IO (Either ErrorType QueueRec)
-secureQueue QueueStore {queues} rId sKey = toResult <$> do
-  TM.lookupIO rId queues $>>= \qVar -> atomically $ 
-    readTVar qVar >>= \q -> case senderKey q of
-      Just k -> pure $ if sKey == k then Just q else Nothing
-      _ ->
-        let !q' = q {senderKey = Just sKey}
-         in writeTVar qVar q' $> Just q'
+getQueueRec :: (STMStoreClass 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))
 
-addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
-addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
-  TM.lookupIO rId queues >>= \case
-    Just qVar -> atomically $ ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
-      q <- readTVar qVar
+secureQueue :: STMStoreClass s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ())
+secureQueue st sq sKey =
+  atomically (readQueueRec qr $>>= secure)
+    $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey
+  where
+    qr = queueRec' sq
+    secure q = case senderKey q of
+      Just k -> pure $ if sKey == k then Right () else Left AUTH
+      Nothing -> do
+        writeTVar qr $ Just q {senderKey = Just sKey}
+        pure $ Right ()
+
+addQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
+  atomically (readQueueRec qr $>>= add)
+    $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
+  where
+    rId = recipientId' sq
+    qr = queueRec' sq
+    STMQueueStore {notifiers} = stmQueueStore st
+    add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
       nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
       let !q' = q {notifier = Just ntfCreds}
-      writeTVar qVar q'
+      writeTVar qr $ Just q'
       TM.insert nId rId notifiers
       pure $ Right nId_
-    Nothing -> pure $ Left AUTH
 
-deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType (Maybe NotifierId))
-deleteQueueNotifier QueueStore {queues, notifiers} rId =
-  withQueue rId queues $ \qVar -> do
-    q <- readTVar qVar
-    forM (notifier q) $ \NtfCreds {notifierId} -> do
-      TM.delete notifierId notifiers
-      writeTVar qVar $! q {notifier = Nothing}
+deleteQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId))
+deleteQueueNotifier st sq =
+  atomically (readQueueRec qr >>= mapM delete)
+    $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId' sq)
+  where
+    qr = queueRec' sq
+    delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do
+      TM.delete notifierId $ notifiers $ stmQueueStore st
+      writeTVar qr $! Just q {notifier = Nothing}
       pure notifierId
 
-suspendQueue :: QueueStore -> RecipientId -> IO (Either ErrorType ())
-suspendQueue QueueStore {queues} rId =
-  withQueue rId queues (`modifyTVar'` \q -> q {status = QueueOff})
+suspendQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ())
+suspendQueue st sq =
+  atomically (readQueueRec qr >>= mapM suspend)
+    $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq)
+  where
+    qr = queueRec' sq
+    suspend q = writeTVar qr $! Just q {status = EntityOff}
 
-updateQueueTime :: QueueStore -> RecipientId -> RoundedSystemTime -> IO ()
-updateQueueTime QueueStore {queues} rId t =
-  void $ withQueue rId queues (`modifyTVar'` \q -> q {updatedAt = Just t})
+blockQueue :: STMStoreClass s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ())
+blockQueue st sq info =
+  atomically (readQueueRec qr >>= mapM block)
+    $>>= \_ -> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId' sq) info)
+  where
+    qr = queueRec' sq
+    block q = writeTVar qr $ Just q {status = EntityBlocked info}
 
-deleteQueue :: QueueStore -> RecipientId -> IO (Either ErrorType QueueRec)
-deleteQueue QueueStore {queues, senders, notifiers} rId = atomically $ do
-  TM.lookupDelete rId queues >>= \case
-    Just qVar ->
-      readTVar qVar >>= \q -> do
-        TM.delete (senderId q) senders
-        forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-        pure $ Right q
-    _ -> pure $ Left AUTH
+unblockQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ())
+unblockQueue st sq =
+  atomically (readQueueRec qr >>= mapM unblock)
+    $>>= \_ -> withLog "unblockQueue" st (`logUnblockQueue` recipientId' sq)
+  where
+    qr = queueRec' sq
+    unblock q = writeTVar qr $ Just q {status = EntityActive}
 
-toResult :: Maybe a -> Either ErrorType a
-toResult = maybe (Left AUTH) Right
+updateQueueTime :: STMStoreClass s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log'
+  where
+    qr = queueRec' sq
+    update q@QueueRec {updatedAt}
+      | updatedAt == Just t = pure (q, False)
+      | otherwise =
+          let !q' = q {updatedAt = Just t}
+           in (writeTVar qr $! Just q') $> (q', True)
+    log' (q, changed)
+      | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t)
+      | otherwise = pure $ Right q
 
-withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM a) -> IO (Either ErrorType a)
-withQueue rId queues f = toResult <$> TM.lookupIO rId queues >>= atomically . mapM f
+deleteQueue' :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s)))
+deleteQueue' st sq =
+  atomically (readQueueRec qr >>= mapM delete)
+    $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` recipientId' sq)
+    >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing))
+  where
+    qr = queueRec' sq
+    STMQueueStore {senders, notifiers} = stmQueueStore st
+    delete q = do
+      writeTVar qr Nothing
+      TM.delete (senderId q) senders
+      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
+      pure q
+
+readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
+readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr
+{-# INLINE readQueueRec #-}
+
+withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
+withLog' name sl action =
+  readTVarIO sl
+    >>= maybe (pure $ Right ()) (E.try . action >=> bimapM logErr pure)
+  where
+    logErr :: E.SomeException -> IO ErrorType
+    logErr e = logError ("STORE: " <> T.pack err) $> STORE err
+      where
+        err = name <> ", withLog, " <> show e
+
+withLog :: STMStoreClass s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
+withLog name = withLog' name . storeLog . stmQueueStore
+
+readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO ()
+readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines
+  where
+    processLine :: LB.ByteString -> IO ()
+    processLine s' = either printError procLogRecord (strDecode s)
+      where
+        s = LB.toStrict s'
+        procLogRecord :: StoreLogRecord -> IO ()
+        procLogRecord = \case
+          CreateQueue rId q -> addQueue st rId q >>= qError rId "CreateQueue"
+          SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
+          AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
+          SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
+          BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info
+          UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st
+          DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st
+          DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st
+          UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t
+        printError :: String -> IO ()
+        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
+        withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO ()
+        withQueue qId op a = runExceptT go >>= qError qId op
+          where
+            go = do
+              q <- ExceptT $ getQueue st SRecipient qId
+              liftIO (readTVarIO $ queueRec' q) >>= \case
+                Nothing -> logWarn $ logPfx qId op <> "already deleted"
+                Just _ -> void $ ExceptT $ a q
+        qError qId op = \case
+          Left e -> logError $ logPfx qId op <> tshow e
+          Right _ -> pure ()
+        logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", "

src/Simplex/Messaging/Server/Stats.hs

@@ -34,6 +34,7 @@ data ServerStats = ServerStats
     qDeletedAllB :: IORef Int,
     qDeletedNew :: IORef Int,
     qDeletedSecured :: IORef Int,
+    qBlocked :: IORef Int,
     qSub :: IORef Int, -- only includes subscriptions when there were pending messages
     -- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions
     qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages)
@@ -53,6 +54,7 @@ data ServerStats = ServerStats
     msgSentAuth :: IORef Int,
     msgSentQuota :: IORef Int,
     msgSentLarge :: IORef Int,
+    msgSentBlock :: IORef Int,
     msgRecv :: IORef Int,
     msgRecvGet :: IORef Int,
     msgGet :: IORef Int,
@@ -89,6 +91,7 @@ data ServerStatsData = ServerStatsData
     _qDeletedAllB :: Int,
     _qDeletedNew :: Int,
     _qDeletedSecured :: Int,
+    _qBlocked :: Int,
     _qSub :: Int,
     _qSubAllB :: Int,
     _qSubAuth :: Int,
@@ -107,6 +110,7 @@ data ServerStatsData = ServerStatsData
     _msgSentAuth :: Int,
     _msgSentQuota :: Int,
     _msgSentLarge :: Int,
+    _msgSentBlock :: Int,
     _msgRecv :: Int,
     _msgRecvGet :: Int,
     _msgGet :: Int,
@@ -144,6 +148,7 @@ newServerStats ts = do
   qDeletedAllB <- newIORef 0
   qDeletedNew <- newIORef 0
   qDeletedSecured <- newIORef 0
+  qBlocked <- newIORef 0
   qSub <- newIORef 0
   qSubAllB <- newIORef 0
   qSubAuth <- newIORef 0
@@ -162,6 +167,7 @@ newServerStats ts = do
   msgSentAuth <- newIORef 0
   msgSentQuota <- newIORef 0
   msgSentLarge <- newIORef 0
+  msgSentBlock <- newIORef 0
   msgRecv <- newIORef 0
   msgRecvGet <- newIORef 0
   msgGet <- newIORef 0
@@ -196,6 +202,7 @@ newServerStats ts = do
         qDeletedAllB,
         qDeletedNew,
         qDeletedSecured,
+        qBlocked,
         qSub,
         qSubAllB,
         qSubAuth,
@@ -214,6 +221,7 @@ newServerStats ts = do
         msgSentAuth,
         msgSentQuota,
         msgSentLarge,
+        msgSentBlock,
         msgRecv,
         msgRecvGet,
         msgGet,
@@ -250,6 +258,7 @@ getServerStatsData s = do
   _qDeletedAllB <- readIORef $ qDeletedAllB s
   _qDeletedNew <- readIORef $ qDeletedNew s
   _qDeletedSecured <- readIORef $ qDeletedSecured s
+  _qBlocked <- readIORef $ qBlocked s
   _qSub <- readIORef $ qSub s
   _qSubAllB <- readIORef $ qSubAllB s
   _qSubAuth <- readIORef $ qSubAuth s
@@ -268,6 +277,7 @@ getServerStatsData s = do
   _msgSentAuth <- readIORef $ msgSentAuth s
   _msgSentQuota <- readIORef $ msgSentQuota s
   _msgSentLarge <- readIORef $ msgSentLarge s
+  _msgSentBlock <- readIORef $ msgSentBlock s
   _msgRecv <- readIORef $ msgRecv s
   _msgRecvGet <- readIORef $ msgRecvGet s
   _msgGet <- readIORef $ msgGet s
@@ -302,6 +312,7 @@ getServerStatsData s = do
         _qDeletedAllB,
         _qDeletedNew,
         _qDeletedSecured,
+        _qBlocked,
         _qSub,
         _qSubAllB,
         _qSubAuth,
@@ -320,6 +331,7 @@ getServerStatsData s = do
         _msgSentAuth,
         _msgSentQuota,
         _msgSentLarge,
+        _msgSentBlock,
         _msgRecv,
         _msgRecvGet,
         _msgGet,
@@ -357,6 +369,7 @@ setServerStats s d = do
   writeIORef (qDeletedAllB s) $! _qDeletedAllB d
   writeIORef (qDeletedNew s) $! _qDeletedNew d
   writeIORef (qDeletedSecured s) $! _qDeletedSecured d
+  writeIORef (qBlocked s) $! _qBlocked d
   writeIORef (qSub s) $! _qSub d
   writeIORef (qSubAllB s) $! _qSubAllB d
   writeIORef (qSubAuth s) $! _qSubAuth d
@@ -375,6 +388,7 @@ setServerStats s d = do
   writeIORef (msgSentAuth s) $! _msgSentAuth d
   writeIORef (msgSentQuota s) $! _msgSentQuota d
   writeIORef (msgSentLarge s) $! _msgSentLarge d
+  writeIORef (msgSentBlock s) $! _msgSentBlock d
   writeIORef (msgRecv s) $! _msgRecv d
   writeIORef (msgRecvGet s) $! _msgRecvGet d
   writeIORef (msgGet s) $! _msgGet d
@@ -411,6 +425,7 @@ instance StrEncoding ServerStatsData where
         "qDeletedNew=" <> strEncode (_qDeletedNew d),
         "qDeletedSecured=" <> strEncode (_qDeletedSecured d),
         "qDeletedAllB=" <> strEncode (_qDeletedAllB d),
+        "qBlocked=" <> strEncode (_qBlocked d),
         "qCount=" <> strEncode (_qCount d),
         "qSub=" <> strEncode (_qSub d),
         "qSubAllB=" <> strEncode (_qSubAllB d),
@@ -430,6 +445,7 @@ instance StrEncoding ServerStatsData where
         "msgSentAuth=" <> strEncode (_msgSentAuth d),
         "msgSentQuota=" <> strEncode (_msgSentQuota d),
         "msgSentLarge=" <> strEncode (_msgSentLarge d),
+        "msgSentBlock=" <> strEncode (_msgSentBlock d),
         "msgRecv=" <> strEncode (_msgRecv d),
         "msgRecvGet=" <> strEncode (_msgRecvGet d),
         "msgGet=" <> strEncode (_msgGet d),
@@ -467,6 +483,7 @@ instance StrEncoding ServerStatsData where
       (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine)
         <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine))
     _qDeletedAllB <- opt "qDeletedAllB="
+    _qBlocked <- opt "qBlocked="
     _qCount <- opt "qCount="
     _qSub <- opt "qSub="
     _qSubNoMsg <- skipInt "qSubNoMsg=" -- skipping it for backward compatibility
@@ -487,6 +504,7 @@ instance StrEncoding ServerStatsData where
     _msgSentAuth <- opt "msgSentAuth="
     _msgSentQuota <- opt "msgSentQuota="
     _msgSentLarge <- opt "msgSentLarge="
+    _msgSentBlock <- opt "msgSentBlock="
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
     _msgRecvGet <- opt "msgRecvGet="
     _msgGet <- opt "msgGet="
@@ -532,6 +550,7 @@ instance StrEncoding ServerStatsData where
           _qDeletedAllB,
           _qDeletedNew,
           _qDeletedSecured,
+          _qBlocked,
           _qSub,
           _qSubAllB,
           _qSubAuth,
@@ -550,6 +569,7 @@ instance StrEncoding ServerStatsData where
           _msgSentAuth,
           _msgSentQuota,
           _msgSentLarge,
+          _msgSentBlock,
           _msgRecv,
           _msgRecvGet,
           _msgGet,
@@ -638,6 +658,14 @@ data PeriodStatCounts = PeriodStatCounts
     monthCount :: String
   }
 
+periodStatDataCounts :: PeriodStatsData -> PeriodStatCounts
+periodStatDataCounts PeriodStatsData {_day, _week, _month} =
+  PeriodStatCounts
+    { dayCount = show $ IS.size _day,
+      weekCount = show $ IS.size _week,
+      monthCount = show $ IS.size _month
+    }
+
 periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts
 periodStatCounts ps ts = do
   let d = utctDay ts

src/Simplex/Messaging/Server/StoreLog.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Server.StoreLog
@@ -20,44 +21,45 @@ module Simplex.Messaging.Server.StoreLog
     logSecureQueue,
     logAddNotifier,
     logSuspendQueue,
+    logBlockQueue,
+    logUnblockQueue,
     logDeleteQueue,
     logDeleteNotifier,
     logUpdateQueueTime,
-    readWriteQueueStore,
     readWriteStoreLog,
+    writeQueueStore,
   )
 where
 
 import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM
+import qualified Control.Exception as E
 import Control.Logger.Simple
-import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.ByteString.Base64.URL as B64
+import Data.Functor (($>))
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
+import GHC.IO (catchAny)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Util (bshow, ifM, unlessM, whenM)
+import Simplex.Messaging.Server.StoreLog.Types
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
 
--- | opaque container for file handle with a type-safe IOMode
--- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
-data StoreLog (a :: IOMode) where
-  ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
-  WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode
-
 data StoreLogRecord
-  = CreateQueue QueueRec
+  = CreateQueue RecipientId QueueRec
   | SecureQueue QueueId SndPublicAuthKey
   | AddNotifier QueueId NtfCreds
   | SuspendQueue QueueId
+  | BlockQueue QueueId BlockingInfo
+  | UnblockQueue QueueId
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
   | UpdateTime QueueId RoundedSystemTime
@@ -68,15 +70,16 @@ data SLRTag
   | SecureQueue_
   | AddNotifier_
   | SuspendQueue_
+  | BlockQueue_
+  | UnblockQueue_
   | DeleteQueue_
   | DeleteNotifier_
   | UpdateTime_
 
 instance StrEncoding QueueRec where
-  strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} =
+  strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} =
     B.unwords
-      [ "rid=" <> strEncode recipientId,
-        "rk=" <> strEncode recipientKey,
+      [ "rk=" <> strEncode recipientKey,
         "rdh=" <> strEncode rcvDhSecret,
         "sid=" <> strEncode senderId,
         "sk=" <> strEncode senderKey
@@ -84,13 +87,16 @@ instance StrEncoding QueueRec where
       <> sndSecureStr
       <> maybe "" notifierStr notifier
       <> maybe "" updatedAtStr updatedAt
+      <> statusStr
     where
       sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
       notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
       updatedAtStr t = " updated_at=" <> strEncode t
+      statusStr = case status of
+        EntityActive -> ""
+        _ -> " status=" <> strEncode status
 
   strP = do
-    recipientId <- "rid=" *> strP_
     recipientKey <- "rk=" *> strP_
     rcvDhSecret <- "rdh=" *> strP_
     senderId <- "sid=" *> strP_
@@ -98,7 +104,8 @@ instance StrEncoding QueueRec where
     sndSecure <- (" sndSecure=" *> strP) <|> pure False
     notifier <- optional $ " notifier=" *> strP
     updatedAt <- optional $ " updated_at=" *> strP
-    pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt}
+    status <- (" status=" *> strP) <|> pure EntityActive
+    pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}
 
 instance StrEncoding SLRTag where
   strEncode = \case
@@ -106,37 +113,45 @@ instance StrEncoding SLRTag where
     SecureQueue_ -> "SECURE"
     AddNotifier_ -> "NOTIFIER"
     SuspendQueue_ -> "SUSPEND"
+    BlockQueue_ -> "BLOCK"
+    UnblockQueue_ -> "UNBLOCK"
     DeleteQueue_ -> "DELETE"
     DeleteNotifier_ -> "NDELETE"
     UpdateTime_ -> "TIME"
 
   strP =
-    A.takeTill (== ' ') >>= \case
-      "CREATE" -> pure CreateQueue_
-      "SECURE" -> pure SecureQueue_
-      "NOTIFIER" -> pure AddNotifier_
-      "SUSPEND" -> pure SuspendQueue_
-      "DELETE" -> pure DeleteQueue_
-      "NDELETE" -> pure DeleteNotifier_
-      "TIME" -> pure UpdateTime_
-      s -> fail $ "invalid log record tag: " <> B.unpack s
+    A.choice
+      [ "CREATE" $> CreateQueue_,
+        "SECURE" $> SecureQueue_,
+        "NOTIFIER" $> AddNotifier_,
+        "SUSPEND" $> SuspendQueue_,
+        "BLOCK" $> BlockQueue_,
+        "UNBLOCK" $> UnblockQueue_,
+        "DELETE" $> DeleteQueue_,
+        "NDELETE" $> DeleteNotifier_,
+        "TIME" $> UpdateTime_
+      ]
 
 instance StrEncoding StoreLogRecord where
   strEncode = \case
-    CreateQueue q -> strEncode (CreateQueue_, q)
+    CreateQueue rId q -> B.unwords [strEncode CreateQueue_, "rid=" <> strEncode rId, strEncode q]
     SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey)
     AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds)
     SuspendQueue rId -> strEncode (SuspendQueue_, rId)
+    BlockQueue rId info -> strEncode (BlockQueue_, rId, info)
+    UnblockQueue rId -> strEncode (UnblockQueue_, rId)
     DeleteQueue rId -> strEncode (DeleteQueue_, rId)
     DeleteNotifier rId -> strEncode (DeleteNotifier_, rId)
     UpdateTime rId t ->  strEncode (UpdateTime_, rId, t)
 
   strP =
     strP_ >>= \case
-      CreateQueue_ -> CreateQueue <$> strP
+      CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP
       SecureQueue_ -> SecureQueue <$> strP_ <*> strP
       AddNotifier_ -> AddNotifier <$> strP_ <*> strP
       SuspendQueue_ -> SuspendQueue <$> strP
+      BlockQueue_ -> BlockQueue <$> strP_ <*> strP
+      UnblockQueue_ -> UnblockQueue <$> strP
       DeleteQueue_ -> DeleteQueue <$> strP
       DeleteNotifier_ -> DeleteNotifier <$> strP
       UpdateTime_ -> UpdateTime <$> strP_ <*> strP
@@ -159,16 +174,18 @@ storeLogFilePath = \case
 
 closeStoreLog :: StoreLog a -> IO ()
 closeStoreLog = \case
-  WriteStoreLog _ h -> hClose h
-  ReadStoreLog _ h -> hClose h
+  WriteStoreLog _ h -> close_ h
+  ReadStoreLog _ h -> close_ h
+  where
+    close_ h = hClose h `catchAny` \e -> logError ("STORE: closeStoreLog, error closing, " <> tshow e)
 
 writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
-writeStoreLogRecord (WriteStoreLog _ h) r = do
+writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do
   B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024
   hFlush h
 
-logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()
-logCreateQueue s = writeStoreLogRecord s . CreateQueue
+logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO ()
+logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q
 
 logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO ()
 logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
@@ -179,6 +196,12 @@ logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds
 logSuspendQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
 logSuspendQueue s = writeStoreLogRecord s . SuspendQueue
 
+logBlockQueue :: StoreLog 'WriteMode -> QueueId -> BlockingInfo -> IO ()
+logBlockQueue s qId info = writeStoreLogRecord s $ BlockQueue qId info
+
+logUnblockQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
+logUnblockQueue s = writeStoreLogRecord s . UnblockQueue
+
 logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 
@@ -188,9 +211,6 @@ logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
 logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
 
-readWriteQueueStore :: FilePath -> QueueStore -> IO (StoreLog 'WriteMode)
-readWriteQueueStore = readWriteStoreLog readQueues writeQueues
-
 readWriteStoreLog :: (FilePath -> s -> IO ()) -> (StoreLog 'WriteMode -> s -> IO ()) -> FilePath -> s -> IO (StoreLog 'WriteMode)
 readWriteStoreLog readStore writeStore f st =
   ifM
@@ -226,31 +246,11 @@ readWriteStoreLog readStore writeStore f st =
       renameFile tempBackup timedBackup
       logInfo $ "original state preserved as " <> T.pack timedBackup
 
-writeQueues :: StoreLog 'WriteMode -> QueueStore -> IO ()
-writeQueues s st = readTVarIO (queues st) >>= mapM_ writeQueue
+writeQueueStore :: STMStoreClass s => StoreLog 'WriteMode -> s -> IO ()
+writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs
   where
-    writeQueue v = readTVarIO v >>= \q -> when (active q) $ logCreateQueue s q
-    active QueueRec {status} = status == QueueActive
-
-readQueues :: FilePath -> QueueStore -> IO ()
-readQueues f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines
-  where
-    processLine :: LB.ByteString -> IO ()
-    processLine s' = either printError procLogRecord (strDecode s)
-      where
-        s = LB.toStrict s'
-        procLogRecord :: StoreLogRecord -> IO ()
-        procLogRecord = \case
-          CreateQueue q -> addQueue st q >>= qError "create" (recipientId q)
-          SecureQueue qId sKey -> secureQueue st qId sKey >>= qError "secure" qId
-          AddNotifier qId ntfCreds -> addQueueNotifier st qId ntfCreds >>= qError "addNotifier" qId
-          SuspendQueue qId -> suspendQueue st qId >>= qError "suspend" qId
-          DeleteQueue qId -> deleteQueue st qId >>= qError "delete" qId
-          DeleteNotifier qId -> deleteQueueNotifier st qId >>= qError "deleteNotifier" qId
-          UpdateTime qId t -> updateQueueTime st qId t
-        printError :: String -> IO ()
-        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
-        qError :: B.ByteString -> RecipientId -> Either ErrorType a -> IO ()
-        qError op (EntityId qId) = \case
-          Left e -> B.putStrLn $ op <> " stored queue " <> B64.encode qId <> " error: " <> bshow e
-          Right _ -> pure ()
+    qs = queues $ stmQueueStore st
+    writeQueue (rId, q) =
+      readTVarIO (queueRec' q) >>= \case
+        Just q' -> logCreateQueue s rId q'
+        Nothing -> atomically $ TM.delete rId qs

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

@@ -0,0 +1,13 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Simplex.Messaging.Server.StoreLog.Types where
+
+import System.IO (Handle, IOMode (..))
+
+-- | opaque container for file handle with a type-safe IOMode
+-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
+data StoreLog (a :: IOMode) where
+  ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
+  WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode

src/Simplex/Messaging/Transport.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
@@ -14,6 +15,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- |
 -- Module      : Simplex.Messaging.Transport
@@ -36,19 +38,20 @@ module Simplex.Messaging.Transport
     supportedSMPHandshakes,
     supportedClientSMPRelayVRange,
     supportedServerSMPRelayVRange,
+    supportedProxyClientSMPRelayVRange,
     proxiedSMPRelayVRange,
+    minClientSMPRelayVersion,
+    minServerSMPRelayVersion,
     legacyServerSMPRelayVRange,
     currentClientSMPRelayVersion,
     legacyServerSMPRelayVersion,
     currentServerSMPRelayVersion,
-    batchCmdsSMPVersion,
-    basicAuthSMPVersion,
-    subModeSMPVersion,
     authCmdsSMPVersion,
     sendingProxySMPVersion,
     sndAuthKeySMPVersion,
     deletedEventSMPVersion,
     encryptedBlockSMPVersion,
+    blockedEntitySMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -89,7 +92,7 @@ where
 
 import Control.Applicative (optional)
 import Control.Concurrent.STM
-import Control.Monad (forM, (<$!>))
+import Control.Monad (forM, when, (<$!>))
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except (throwE)
@@ -138,10 +141,12 @@ smpBlockSize = 16384
 -- 5 - basic auth for SMP servers (11/12/2022)
 -- 6 - allow creating queues without subscribing (9/10/2023)
 -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
--- 8 - SMP proxy for sender commands
--- 9 - faster handshake: SKEY command for sender to secure queue
--- 10 - DELD event to subscriber when queue is deleted via another connnection
--- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024)
+-- 8 - SMP proxy for sender commands (6/03/2024)
+-- 9 - faster handshake: SKEY command for sender to secure queue (6/30/2024)
+-- 10 - DELD event to subscriber when queue is deleted via another connnection (9/11/2024)
+-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024)
+-- 12 - BLOCKED error for blocked queues (1/11/2025)
+-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
 
 data SMPVersion
 
@@ -154,14 +159,8 @@ type VersionRangeSMP = VersionRange SMPVersion
 pattern VersionSMP :: Word16 -> VersionSMP
 pattern VersionSMP v = Version v
 
-batchCmdsSMPVersion :: VersionSMP
-batchCmdsSMPVersion = VersionSMP 4
-
-basicAuthSMPVersion :: VersionSMP
-basicAuthSMPVersion = VersionSMP 5
-
-subModeSMPVersion :: VersionSMP
-subModeSMPVersion = VersionSMP 6
+_subModeSMPVersion :: VersionSMP
+_subModeSMPVersion = VersionSMP 6
 
 authCmdsSMPVersion :: VersionSMP
 authCmdsSMPVersion = VersionSMP 7
@@ -178,14 +177,26 @@ deletedEventSMPVersion = VersionSMP 10
 encryptedBlockSMPVersion :: VersionSMP
 encryptedBlockSMPVersion = VersionSMP 11
 
+blockedEntitySMPVersion :: VersionSMP
+blockedEntitySMPVersion = VersionSMP 12
+
+proxyServerHandshakeSMPVersion :: VersionSMP
+proxyServerHandshakeSMPVersion = VersionSMP 14
+
+minClientSMPRelayVersion :: VersionSMP
+minClientSMPRelayVersion = VersionSMP 6
+
+minServerSMPRelayVersion :: VersionSMP
+minServerSMPRelayVersion = VersionSMP 6
+
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 11
+currentClientSMPRelayVersion = VersionSMP 14
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 11
+currentServerSMPRelayVersion = VersionSMP 14
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -193,20 +204,22 @@ currentServerSMPRelayVersion = VersionSMP 11
 -- to prevent client version fingerprinting by the
 -- destination relays when clients upgrade at different times.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 9
+proxiedSMPRelayVersion = VersionSMP 14
 
--- minimal supported protocol version is 4
+-- minimal supported protocol version is 6
 -- TODO remove code that supports sending commands without batching
 supportedClientSMPRelayVRange :: VersionRangeSMP
-supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion
+supportedClientSMPRelayVRange = mkVersionRange minClientSMPRelayVersion currentClientSMPRelayVersion
 
 legacyServerSMPRelayVRange :: VersionRangeSMP
-legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion
+legacyServerSMPRelayVRange = mkVersionRange minServerSMPRelayVersion legacyServerSMPRelayVersion
 
 supportedServerSMPRelayVRange :: VersionRangeSMP
-supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion
+supportedServerSMPRelayVRange = mkVersionRange minServerSMPRelayVersion currentServerSMPRelayVersion
+
+supportedProxyClientSMPRelayVRange :: VersionRangeSMP
+supportedProxyClientSMPRelayVRange = mkVersionRange minServerSMPRelayVersion currentServerSMPRelayVersion
 
--- This range initially allows only version 8 - see the comment above.
 proxiedSMPRelayVRange :: VersionRangeSMP
 proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion
 
@@ -407,7 +420,7 @@ data THandleParams v p = THandleParams
     -- | do NOT send session ID in transmission, but include it into signed message
     -- based on protocol version
     implySessId :: Bool,
-    -- -- | additional block encryption
+    -- | keys for additional transport encryption
     encryptBlock :: Maybe TSbChainKeys,
     -- | send multiple transmissions in a single block
     -- based on protocol version
@@ -448,18 +461,28 @@ data ClientHandshake = ClientHandshake
     smpVersion :: VersionSMP,
     -- | server identity - CA certificate fingerprint
     keyHash :: C.KeyHash,
-    -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
-    authPubKey :: Maybe C.PublicKeyX25519
+    -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
+    authPubKey :: Maybe C.PublicKeyX25519,
+    -- | Whether connecting client is a proxy server (send from SMP v12).
+    -- This property, if True, disables additional transport encrytion inside TLS.
+    -- (Proxy server connection already has additional encryption, so this layer is not needed there).
+    proxyServer :: Bool
   }
 
 instance Encoding ClientHandshake where
-  smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} =
-    smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey
+  smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} =
+    smpEncode (v, keyHash)
+      <> encodeAuthEncryptCmds v authPubKey
+      <> ifHasProxy v (smpEncode proxyServer) ""
   smpP = do
-    (smpVersion, keyHash) <- smpP
+    (v, keyHash) <- smpP
     -- TODO drop SMP v6: remove special parser and make key non-optional
-    authPubKey <- authEncryptCmdsP smpVersion smpP
-    pure ClientHandshake {smpVersion, keyHash, authPubKey}
+    authPubKey <- authEncryptCmdsP v smpP
+    proxyServer <- ifHasProxy v smpP (pure False)
+    pure ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer}
+
+ifHasProxy :: VersionSMP -> a -> a -> a
+ifHasProxy v a b = if v >= proxyServerHandshakeSMPVersion then a else b
 
 instance Encoding ServerHandshake where
   smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
@@ -567,54 +590,70 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
       smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
   sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
   getHandshake th >>= \case
-    ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
+    ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
       | keyHash /= kh ->
           throwE $ TEHandshake IDENTITY
       | otherwise ->
           case compatibleVRange' smpVersionRange v of
-            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k'
+            Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k' proxyServer
             Nothing -> throwE TEVersion
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient)
-smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
+smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
+smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
   let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
-  if sessionId /= sessId
-    then throwE TEBadSession
-    else case smpVersionRange `compatibleVRange` smpVRange of
-      Just (Compatible vr) -> do
-        ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
-          liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
-            case cert of
-              [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
-              _ -> throwError "bad certificate"
-            serverKey <- getServerVerifyKey c
-            pubKey <- C.verifyX509 serverKey exact
-            (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
-        let v = maxVersion vr
-        sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
-        liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_
-      Nothing -> throwE TEVersion
+  when (sessionId /= sessId) $ throwE TEBadSession
+  -- Below logic downgrades version range in case the "client" is SMP proxy server and it is
+  -- connected to the destination server of the version 11 or older.
+  -- It disables transport encryption between SMP proxy and destination relay.
+  --
+  -- Prior to version v6.3 the version between proxy and destination was capped at 8,
+  -- by mistake, which also disables transport encryption and the latest features.
+  --
+  -- Transport encryption between proxy and destination breaks clients with version 10 or earlier,
+  -- because of a larger message size (see maxMessageLength).
+  --
+  -- To summarize:
+  -- - proxy and relay version 12: the agreed version is 12, transport encryption disabled (see blockEncryption with proxyServer == True).
+  -- - proxy is v 12, relay is 11: the agreed version is 10, because of this logic, transport encryption is disabled.
+  let smpVRange =
+        if proxyServer && maxVersion smpVersionRange < proxyServerHandshakeSMPVersion
+          then vRange {maxVersion = max (minVersion vRange) deletedEventSMPVersion}
+          else vRange
+  case smpVersionRange `compatibleVRange` smpVRange of
+    Just (Compatible vr) -> do
+      ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
+        liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+          case cert of
+            [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
+            _ -> throwError "bad certificate"
+          serverKey <- getServerVerifyKey c
+          pubKey <- C.verifyX509 serverKey exact
+          (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
+      let v = maxVersion vr
+      sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer}
+      liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer
+    Nothing -> throwE TEVersion
 
-smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer)
-smpTHandleServer th v vr pk k_ = do
+smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> IO (THandleSMP c 'TServer)
+smpTHandleServer th v vr pk k_ proxyServer = do
   let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
-  be <- blockEncryption th v thAuth
+  be <- blockEncryption th v proxyServer thAuth
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
 
-smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> IO (THandleSMP c 'TClient)
-smpTHandleClient th v vr pk_ ck_ = do
+smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> Bool -> IO (THandleSMP c 'TClient)
+smpTHandleClient th v vr pk_ ck_ proxyServer = do
   let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
-  be <- blockEncryption th v thAuth
+  be <- blockEncryption th v proxyServer thAuth
   -- swap is needed to use client's sndKey as server's rcvKey and vice versa
   pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
 
-blockEncryption :: THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
-blockEncryption THandle {params = THandleParams {sessionId}} v = \case
-  Just thAuth | v >= encryptedBlockSMPVersion -> case thAuth of
+blockEncryption :: THandleSMP c p -> VersionSMP -> Bool -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
+blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \case
+  Just thAuth | not proxyServer && v >= encryptedBlockSMPVersion -> case thAuth of
     THAuthClient {sessSecret} -> be sessSecret
     THAuthServer {sessSecret'} -> be sessSecret'
   _ -> pure Nothing

src/Simplex/Messaging/Transport/Server.hs

@@ -12,7 +12,9 @@ module Simplex.Messaging.Transport.Server
     runTransportServerState,
     runTransportServerState_,
     SocketState,
+    SocketStats (..),
     newSocketState,
+    getSocketStats,
     runTransportServer,
     runTransportServerSocket,
     runLocalTCPServer,
@@ -157,15 +159,30 @@ safeAccept sock =
       | otherwise -> logError err >> E.throwIO e
       where
         retryAccept = maybe False ((`elem` again) . Errno) errno
-        again = [eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH]
+        again = [eCONNABORTED, eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH]
         err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno
         errno = ioe_errno e
 
 type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId)))
 
+data SocketStats = SocketStats
+  { socketsAccepted :: Int,
+    socketsClosed :: Int,
+    socketsActive :: Int,
+    socketsLeaked :: Int
+  }
+
 newSocketState :: IO SocketState
 newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO mempty
 
+getSocketStats :: SocketState -> IO SocketStats
+getSocketStats (accepted, closed, active) = do
+  socketsAccepted <- readTVarIO accepted
+  socketsClosed <- readTVarIO closed
+  socketsActive <- IM.size <$> readTVarIO active
+  let socketsLeaked = socketsAccepted - socketsClosed - socketsActive
+  pure SocketStats {socketsAccepted, socketsClosed, socketsActive, socketsLeaked}
+
 closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO ()
 closeServer started clients sock = do
   close sock

src/Simplex/Messaging/Util.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -8,21 +9,25 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.State.Strict (StateT (..))
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
 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.Int (Int64)
 import Data.IORef
+import Data.Int (Int64)
 import Data.List (groupBy, sortOn)
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
 import Data.Time (NominalDiffTime)
+import Data.Tuple (swap)
 import GHC.Conc (labelThread, myThreadId, threadDelay)
 import UnliftIO hiding (atomicModifyIORef')
 import qualified UnliftIO.Exception as UE
@@ -33,12 +38,16 @@ raceAny_ = r []
     r as (m : ms) = withAsync m $ \a -> r (a : as) ms
     r as [] = void $ waitAnyCancel as
 
-infixl 4 <$$>, <$?>
+infixl 4 <$$>, <$$, <$?>
 
 (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
 (<$$>) = fmap . fmap
 {-# INLINE (<$$>) #-}
 
+(<$$) :: (Functor f, Functor g) => b -> f (g a) -> f (g b)
+(<$$) = fmap . fmap . const
+{-# INLINE (<$$) #-}
+
 (<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b
 f <$?> m = either fail pure . f =<< m
 {-# INLINE (<$?>) #-}
@@ -94,6 +103,47 @@ forME :: (Monad m, Traversable t) => t (Either e a) -> (a -> m (Either e b)) ->
 forME = flip mapME
 {-# INLINE forME #-}
 
+
+-- | Monadic version of mapAccumL
+-- Copied from ghc-9.6.3 package: https://hackage.haskell.org/package/ghc-9.12.1/docs/GHC-Utils-Monad.html#v:mapAccumLM
+-- for backward compatibility with 8.10.7.
+mapAccumLM :: (Monad m, Traversable t)
+            => (acc -> x -> m (acc, y)) -- ^ combining function
+            -> acc                      -- ^ initial state
+            -> t x                      -- ^ inputs
+            -> m (acc, t y)             -- ^ final state, outputs
+{-# INLINE [1] mapAccumLM #-}
+-- INLINE pragma.  mapAccumLM is called in inner loops.  Like 'map',
+-- we inline it so that we can take advantage of knowing 'f'.
+-- This makes a few percent difference (in compiler allocations)
+-- when compiling perf/compiler/T9675
+mapAccumLM f s = fmap swap . flip runStateT s . traverse f'
+  where
+    f' = StateT . (fmap . fmap) swap . flip f
+{-# RULES "mapAccumLM/List" mapAccumLM = mapAccumLM_List #-}
+{-# RULES "mapAccumLM/NonEmpty" mapAccumLM = mapAccumLM_NonEmpty #-}
+
+mapAccumLM_List
+ :: Monad m
+ => (acc -> x -> m (acc, y))
+ -> acc -> [x] -> m (acc, [y])
+{-# INLINE mapAccumLM_List #-}
+mapAccumLM_List f = go
+  where
+    go s (x : xs) = do
+      (s1, x')  <- f s x
+      (s2, xs') <- go s1 xs
+      return    (s2, x' : xs')
+    go s [] = return (s, [])
+
+mapAccumLM_NonEmpty
+ :: Monad m
+ => (acc -> x -> m (acc, y))
+ -> acc -> NonEmpty x -> m (acc, NonEmpty y)
+{-# INLINE mapAccumLM_NonEmpty #-}
+mapAccumLM_NonEmpty f s (x :| xs) =
+  [(s2, x' :| xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs]
+
 catchAll :: IO a -> (E.SomeException -> IO a) -> IO a
 catchAll = E.catch
 {-# INLINE catchAll #-}
@@ -185,3 +235,7 @@ encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
 
 decodeJSON :: FromJSON a => Text -> Maybe a
 decodeJSON = J.decode . LB.fromStrict . encodeUtf8
+
+traverseWithKey_ :: Monad m => (k -> v -> m ()) -> Map k v -> m ()
+traverseWithKey_ f = M.foldrWithKey (\k v -> (f k v >>)) (pure ())
+{-# INLINE traverseWithKey_ #-}

src/Simplex/RemoteControl/Types.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}

tests/AgentTests.hs

@@ -1,12 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PostfixOperators #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 module AgentTests (agentTests) where
 
@@ -15,15 +13,29 @@ import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
 import AgentTests.MigrationTests (migrationTests)
 import AgentTests.NotificationTests (notificationTests)
-import AgentTests.SQLiteTests (storeTests)
+import AgentTests.ServerChoice (serverChoiceTests)
 import Simplex.Messaging.Transport (ATransport (..))
 import Test.Hspec
+#if defined(dbPostgres)
+import Fixtures
+import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
+#else
+import AgentTests.SQLiteTests (storeTests)
+#endif
 
 agentTests :: ATransport -> Spec
 agentTests (ATransport t) = do
+  describe "Migration tests" migrationTests
   describe "Connection request" connectionRequestTests
   describe "Double ratchet tests" doubleRatchetTests
-  describe "Functional API" $ functionalAPITests (ATransport t)
-  describe "Notification tests" $ notificationTests (ATransport t)
+#if defined(dbPostgres)
+  after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do
+#else
+  do
+#endif
+    describe "Functional API" $ functionalAPITests (ATransport t)
+    describe "Chosen servers" serverChoiceTests
+    describe "Notification tests" $ notificationTests (ATransport t)
+#if !defined(dbPostgres)
   describe "SQLite store" storeTests
-  describe "Migration tests" migrationTests
+#endif

tests/AgentTests/DoubleRatchetTests.hs

@@ -585,9 +585,13 @@ testRatchetVersions =
 encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
 encrypt_ pqEnc_ (_, rc, _) msg =
   -- print msg >>
-  runExceptT (rcEncrypt rc paddedMsgLen msg pqEnc_ currentE2EEncryptVersion)
+  runExceptT encrypt
     >>= either (pure . Left) checkLength
   where
+    encrypt = do
+      (mek, rc') <- rcEncryptHeader rc pqEnc_ currentE2EEncryptVersion
+      msg' <- rcEncryptMsg mek paddedMsgLen msg
+      pure (msg', rc')
     checkLength (msg', rc') = do
       B.length msg' `shouldBe` fullMsgLen rc'
       pure $ Right (msg', rc', SMDNoChange)

tests/AgentTests/FunctionalAPITests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -74,18 +75,19 @@ import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Type.Equality (testEquality, (:~:) (Refl))
 import Data.Word (Word16)
-import qualified Database.SQLite.Simple as SQL
 import GHC.Stack (withFrozenCallStack)
 import SMPAgentClient
-import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
 import qualified Simplex.Messaging.Agent.Protocol as A
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
-import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
+import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
+import Simplex.Messaging.Agent.Store.Interface
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -96,8 +98,9 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..))
 import Simplex.Messaging.Server.QueueStore.QueueInfo
-import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes)
+import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds)
 import Simplex.Messaging.Version (VersionRange (..))
 import qualified Simplex.Messaging.Version as V
@@ -107,6 +110,9 @@ import Test.Hspec
 import UnliftIO
 import Util
 import XFTPClient (testXFTPServer)
+#if defined(dbPostgres)
+import Fixtures
+#endif
 
 type AEntityTransmission e = (ACorrId, ConnId, AEvent e)
 
@@ -324,6 +330,8 @@ functionalAPITests t = do
       it "should expire multiple messages" $ testExpireManyMessages t
       it "should expire one message if quota is exceeded" $ testExpireMessageQuota t
       it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota t
+#if !defined(dbPostgres)
+    -- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite)
     describe "Ratchet synchronization" $ do
       it "should report ratchet de-synchronization, synchronize ratchets" $
         testRatchetSync t
@@ -335,6 +343,7 @@ functionalAPITests t = do
         testRatchetSyncSuspendForeground t
       it "should synchronize ratchets when clients start synchronization simultaneously" $
         testRatchetSyncSimultaneous t
+#endif
     describe "Subscription mode OnlyCreate" $ do
       it "messages delivered only when polled (v8 - slow handshake)" $
         withSmpServer t testOnlyCreatePullSlowHandshake
@@ -355,6 +364,7 @@ functionalAPITests t = do
     it "should suspend agent on timeout, even if pending messages not sent" $
       testSuspendingAgentTimeout t
   describe "Batching SMP commands" $ do
+    -- disable this and enable the following test to run tests with coverage
     it "should subscribe to multiple (200) subscriptions with batching" $
       testBatchedSubscriptions 200 10 t
     skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $
@@ -417,7 +427,6 @@ functionalAPITests t = do
     describe "should switch two connections simultaneously, abort one" $
       testServerMatrix2 t testSwitch2ConnectionsAbort1
   describe "SMP basic auth" $ do
-    let v4 = prevVersion basicAuthSMPVersion
     forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do
       let baseId = if v >= sndAuthKeySMPVersion then 1 else 3
           sqSecured = if v >= sndAuthKeySMPVersion then True else False
@@ -427,20 +436,12 @@ functionalAPITests t = do
         it "disabled               " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
         it "NEW fail, no auth      " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
         it "NEW fail, bad auth     " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
-        it "NEW fail, version      " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
         it "JOIN fail, no auth     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1
         it "JOIN fail, bad auth    " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1
-        it "JOIN fail, version     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) sqSecured baseId `shouldReturn` 1
       describe ("v" <> show v <> ": no server auth") $ do
         it "success     " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2
         it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0
-        it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) False 3 `shouldReturn` 2
-        it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) False baseId `shouldReturn` 2
-        it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) sqSecured 3 `shouldReturn` 2
-        it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2
-        it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2
         it "auth fst    " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2
-        it "auth fst 2  " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) False 3 `shouldReturn` 2
         it "auth snd    " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
         it "auth both   " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
         it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
@@ -473,7 +474,7 @@ functionalAPITests t = do
 
 testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
 testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do
-  let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion}
+  let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion}
       canCreate1 = canCreateQueue allowNewQueues srv clnt1
       canCreate2 = canCreateQueue allowNewQueues srv clnt2
       expected
@@ -485,9 +486,8 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured b
   pure created
 
 canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> Bool
-canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
-  let v = basicAuthSMPVersion
-   in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth))
+canCreateQueue allowNew (srvAuth, _) (clntAuth, _) =
+  allowNew && (isNothing srvAuth || srvAuth == clntAuth)
 
 testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2 t runTest = do
@@ -530,7 +530,7 @@ testRatchetMatrix2 t runTest = do
 testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 t runTest = do
   it "1 server" $ withSmpServer t $ runTest initAgentServers
-  it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
+  it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> runTest initAgentServers2
 
 testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
 testPQMatrix2 = pqMatrix2_ True
@@ -1041,7 +1041,7 @@ testAllowConnectionClientRestart t = do
   bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2
   withSmpServerStoreLogOn t testPort $ \_ -> do
     (aliceId, bobId, confId) <-
-      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
+      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
         runRight $ do
           (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
           (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -1063,8 +1063,7 @@ testAllowConnectionClientRestart t = do
     alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
     runRight_ $ subscribeConnection alice2 bobId
     threadDelay 500000
-
-    withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
+    withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
       runRight $ do
         ("", "", UP _ _) <- nGet bob
         get alice2 ##> ("", bobId, CON)
@@ -1282,7 +1281,7 @@ testSkippedMessages :: HasCallStack => ATransport -> IO ()
 testSkippedMessages t = do
   alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
   bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do
+  (aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ makeConnection alice bob
     runRight_ $ do
       2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
@@ -1310,7 +1309,7 @@ testSkippedMessages t = do
   alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
   bob2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
 
-  withSmpServerStoreLogOn t testPort $ \_ -> do
+  withSmpServerConfigOn t cfg' testPort $ \_ -> do
     runRight_ $ do
       subscribeConnection bob2 aliceId
       subscribeConnection alice2 bobId
@@ -1326,6 +1325,8 @@ testSkippedMessages t = do
       ackMessage bob2 aliceId 4 Nothing
   disposeAgentClient alice2
   disposeAgentClient bob2
+  where
+    cfg' = cfg {msgStoreType = AMSType SMSMemory, storeMsgsFile = Nothing}
 
 testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO ()
 testDeliveryAfterSubscriptionError t = do
@@ -1429,7 +1430,7 @@ withUP a bId p =
       ]
 
 testExpireMessageQuota :: HasCallStack => ATransport -> IO ()
-testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
+testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1455,7 +1456,7 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP
   disposeAgentClient a
 
 testExpireManyMessagesQuota :: ATransport -> IO ()
-testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do
+testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
   a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
   b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
   (aId, bId) <- runRight $ do
@@ -1944,7 +1945,7 @@ testBatchedSubscriptions nCreate nDel t =
     runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
       withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
+        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 ->
           runRight a `finally` killThread t2
         killThread t1
         pure res
@@ -1971,7 +1972,7 @@ testBatchedPendingMessages nCreate nMsgs =
 testSendMessagesB :: IO ()
 testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do
   (aId, bId) <- makeConnection a b
-  let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, body)
+  let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, vrValue body)
   [SentB 2, SentB 3, SentB 4] <- sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3"] :: [Either AgentErrorType MsgReq])
   get a ##> ("", bId, SENT 2)
   get a ##> ("", bId, SENT 3)
@@ -1984,7 +1985,7 @@ testSendMessagesB2 :: IO ()
 testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do
   (abId, bId) <- makeConnection a b
   (acId, cId) <- makeConnection a c
-  let msg connId body = Right (connId, PQEncOn, SMP.noMsgFlags, body)
+  let msg connId body = msgVR connId $ vrValue body
   [SentB 2, SentB 3, SentB 4, SentB 2, SentB 3] <-
     sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3", msg cId "msg 4", msg "" "msg 5"] :: [Either AgentErrorType MsgReq])
   liftIO $
@@ -2001,6 +2002,23 @@ testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do
   receiveMsg b abId 4 "msg 3"
   receiveMsg c acId 2 "msg 4"
   receiveMsg c acId 3 "msg 5"
+  let msg' connId i body = msgVR connId $ VRValue (Just i) body
+  [SentB 5, SentB 6, SentB 4, SentB 5] <-
+    sendMessagesB a ([msg' bId 0 "msg 5", msg' "" 1 "msg 6", msgVR cId (VRRef 0), msgVR "" (VRRef 1)] :: [Either AgentErrorType MsgReq])
+  liftIO $
+    getInAnyOrder
+      a
+      [ \case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == bId; _ -> False,
+        \case ("", cId', AEvt SAEConn (SENT 6)) -> cId' == bId; _ -> False,
+        \case ("", cId', AEvt SAEConn (SENT 4)) -> cId' == cId; _ -> False,
+        \case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == cId; _ -> False
+      ]
+  receiveMsg b abId 5 "msg 5"
+  receiveMsg b abId 6 "msg 6"
+  receiveMsg c acId 4 "msg 5"
+  receiveMsg c acId 5 "msg 6"
+  where
+    msgVR connId mbr = Right (connId, PQEncOn, SMP.noMsgFlags, mbr)
 
 pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption)
 pattern SentB msgId <- Right (msgId, PQEncOn)
@@ -2055,8 +2073,8 @@ testAsyncCommands sqSecured alice bob baseId =
     ackMessageAsync alice "7" bobId (baseId + 4) Nothing
     get alice =##> \case ("7", _, OK) -> True; _ -> False
     deleteConnectionAsync alice False bobId
-    get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False
-    get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False
+    get alice =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bobId; _ -> False
+    get alice =##> \case ("", "", DEL_CONNS [c]) -> c == bobId; _ -> False
     liftIO $ noMessages alice "nothing else should be delivered to alice"
   where
     msgId = subtract baseId
@@ -2123,12 +2141,9 @@ testDeleteConnectionAsync t =
     runRight_ $ do
       deleteConnectionsAsync a False connIds
       nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False
-      get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
-      get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
-      get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
-      get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
-      get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
-      get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
+      let delOk = \case (c, _, _, Just (BROKER _ e)) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
+      get a =##> \case ("", "", DEL_RCVQS rs) -> length rs == 3 && all delOk rs; _ -> False
+      get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False
       liftIO $ noMessages a "nothing else should be delivered to alice"
 
 testWaitDeliveryNoPending :: ATransport -> IO ()
@@ -2147,8 +2162,8 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob ->
     ackMessage alice bobId (baseId + 2) Nothing
 
     deleteConnectionsAsync alice True [bobId]
-    get alice =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == bobId; _ -> False
-    get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
+    get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == bobId; _ -> False
+    get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
 
     3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 3); _ -> False
@@ -2184,14 +2199,14 @@ testWaitDelivery t =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
       withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
         get alice ##> ("", bobId, SENT $ baseId + 3)
         get alice ##> ("", bobId, SENT $ baseId + 4)
-        get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
+        get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
 
         liftIO $
           getInAnyOrder
@@ -2231,8 +2246,8 @@ testWaitDeliveryAUTHErr t =
         ackMessage alice bobId (baseId + 2) Nothing
 
         deleteConnectionsAsync bob False [aliceId]
-        get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False
-        get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False
+        get bob =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == aliceId; _ -> False
+        get bob =##> \case ("", "", DEL_CONNS [cId]) -> cId == aliceId; _ -> False
 
         pure (aliceId, bobId)
 
@@ -2241,14 +2256,14 @@ testWaitDeliveryAUTHErr t =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
       withSmpServerStoreLogOn t testPort $ \_ -> do
         get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False
         get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False
-        get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
+        get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
 
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
@@ -2281,8 +2296,8 @@ testWaitDeliveryTimeout t =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
-        get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
@@ -2321,8 +2336,8 @@ testWaitDeliveryTimeout2 t =
         3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
         4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
         deleteConnectionsAsync alice True [bobId]
-        get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
-        get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
+        get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False
+        get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
         liftIO $ noMessages alice "nothing else should be delivered to alice"
         liftIO $ noMessages bob "nothing else should be delivered to bob"
 
@@ -2356,7 +2371,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do
         ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
         pure (aId, bId)
       nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-      withSmpServerOn t testPort2 $ do
+      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
         get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           pGet a >>= \case
@@ -2395,7 +2410,7 @@ testJoinConnectionAsyncReplyError t = do
         ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
         pure (aId, bId)
       nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
-      withSmpServerOn t testPort2 $ do
+      withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           -- both servers need to be online for connection to progress because of SKEY
           get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False
@@ -2430,8 +2445,8 @@ testUsers =
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetings a bId' b aId'
     deleteUser a auId True
-    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False
-    get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
+    get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bId'; _ -> False
+    get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False
     nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     exchangeGreetingsMsgId 4 a bId b aId
     liftIO $ noMessages a "nothing else should be delivered to alice"
@@ -2462,8 +2477,8 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
   nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
   runRight_ $ do
     deleteUser a auId True
-    get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
-    get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
+    get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Just (BROKER _ e))]) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False
     nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
@@ -2559,7 +2574,7 @@ testSwitchAsync servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent 2 agentCfg servers testDB2
 
-withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a
+withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> String -> (HasCallStack => AgentClient -> IO a) -> IO a
 withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) (\a -> disposeAgentClient a >> threadDelay 100000)
 
 sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
@@ -2581,9 +2596,8 @@ testSwitchDelete servers =
     liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
     phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
     deleteConnectionAsync a False bId
-    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
-    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
-    get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
+    get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing), (c', _, _, Nothing)]) -> c == bId && c' == bId; _ -> False
+    get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
 testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
@@ -2880,7 +2894,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
     getClient clientId (clntAuth, clntVersion) db =
       let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]}
           alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing
-          smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion
+          smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange minClientSMPRelayVersion clntVersion
           sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
        in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
 
@@ -2974,7 +2988,7 @@ testDeliveryReceiptsVersion t = do
 
 testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO ()
 testDeliveryReceiptsConcurrent t =
-  withSmpServerConfigOn t cfg {msgQueueQuota = 256} testPort $ \_ -> do
+  withSmpServerConfigOn t cfg {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do
     withAgentClients2 $ \a b -> do
       (aId, bId) <- runRight $ makeConnection a b
       t1 <- liftIO getCurrentTime
@@ -3074,8 +3088,9 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     ("", "", DOWN _ _) <- nGet a
     ("", "", DOWN _ _) <- nGet a
     ("", "", DOWN _ _) <- nGet a
-    ("", "", DOWN _ _) <- nGet a
-    ("", "", UP _ _) <- nGet a
+    -- to avoice race condition
+    nGet a =##> \case ("", "", DOWN _ _) -> True; ("", "", UP _ _) -> True; _ -> False
+    nGet a =##> \case ("", "", UP _ _) -> True; ("", "", DOWN _ _) -> True; _ -> False
     ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
     ("", "", UP _ _) <- nGet a
@@ -3088,13 +3103,27 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
     hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
 
-getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient
+getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> String -> IO AgentClient
 getSMPAgentClient' clientId cfg' initServers dbPath = do
-  Right st <- liftIO $ createAgentStore dbPath "" False MCError
+  Right st <- liftIO $ createStore dbPath
   c <- getSMPAgentClient_ clientId cfg' initServers st False
-  when (dbNew st) $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)")
+  when (dbNew st) $ insertUser st
   pure c
 
+#if defined(dbPostgres)
+createStore :: String -> IO (Either MigrationError DBStore)
+createStore schema = createAgentStore (DBOpts testDBConnstr schema) MCError
+
+insertUser :: DBStore -> IO ()
+insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
+#else
+createStore :: String -> IO (Either MigrationError DBStore)
+createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError
+
+insertUser :: DBStore -> IO ()
+insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")
+#endif
+
 testServerMultipleIdentities :: HasCallStack => IO ()
 testServerMultipleIdentities =
   withAgentClients2 $ \alice bob -> runRight_ $ do

tests/AgentTests/MigrationTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module AgentTests.MigrationTests (migrationTests) where
@@ -5,13 +6,22 @@ module AgentTests.MigrationTests (migrationTests) where
 import Control.Monad
 import Data.Maybe (fromJust)
 import Data.Word (Word32)
-import Database.SQLite.Simple (fromOnly)
-import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError (MEDowngrade, MEUpgrade, MigrationError), SQLiteStore, closeSQLiteStore, createSQLiteStore, upMigration, withTransaction)
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.SQLite.Migrations
-import System.Directory (removeFile)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import Simplex.Messaging.Agent.Store.Interface
+import Simplex.Messaging.Agent.Store.Migrations (migrationsToRun)
+import Simplex.Messaging.Agent.Store.Shared
 import System.Random (randomIO)
 import Test.Hspec
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (fromOnly)
+import Fixtures
+import Simplex.Messaging.Agent.Store.Postgres.Util (dropSchema)
+import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
+#else
+import Database.SQLite.Simple (fromOnly)
+import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import System.Directory (removeFile)
+#endif
 
 migrationTests :: Spec
 migrationTests = do
@@ -95,9 +105,6 @@ migrationTests = do
         ([m1, m2, m3, m4], [t1, t2, t3, t4])
         ([m1, m2, m4], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTREDifferent (name m4) (name m3))
 
-testDB :: FilePath
-testDB = "tests/tmp/test_migrations.db"
-
 m1 :: Migration
 m1 = Migration "20230301-migration1" "create table test1 (id1 integer primary key);" Nothing
 
@@ -177,21 +184,60 @@ testMigration ::
   IO ()
 testMigration (initMs, initTables) (finalMs, confirmModes, tablesOrError) = forM_ confirmModes $ \confirmMode -> do
   r <- randomIO :: IO Word32
-  let dpPath = testDB <> show r
-  Right st <- createSQLiteStore dpPath "" False initMs MCError
+  Right st <- createStore r initMs MCError
   st `shouldHaveTables` initTables
-  closeSQLiteStore st
+  closeDBStore st
   case tablesOrError of
     Right tables -> do
-      Right st' <- createSQLiteStore dpPath "" False finalMs confirmMode
+      Right st' <- createStore r finalMs confirmMode
       st' `shouldHaveTables` tables
-      closeSQLiteStore st'
+      closeDBStore st'
     Left e -> do
-      Left e' <- createSQLiteStore dpPath "" False finalMs confirmMode
+      Left e' <- createStore r finalMs confirmMode
       e `shouldBe` e'
-  removeFile dpPath
-  where
-    shouldHaveTables :: SQLiteStore -> [String] -> IO ()
-    st `shouldHaveTables` expected = do
-      tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1;")
-      tables `shouldBe` "migrations" : expected
+  cleanup r
+
+#if defined(dbPostgres)
+testSchema :: Word32 -> String
+testSchema randSuffix = "test_migrations_schema" <> show randSuffix
+
+createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore randSuffix migrations confirmMigrations = do
+  let dbOpts =
+        DBOpts {
+          connstr = testDBConnstr,
+          schema = testSchema randSuffix
+        }
+  createDBStore dbOpts migrations confirmMigrations
+
+cleanup :: Word32 -> IO ()
+cleanup randSuffix = dropSchema testDBConnectInfo (testSchema randSuffix)
+
+shouldHaveTables :: DBStore -> [String] -> IO ()
+st `shouldHaveTables` expected = do
+  tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT table_name FROM information_schema.tables WHERE table_schema = current_schema() AND table_type = 'BASE TABLE' ORDER BY 1")
+  tables `shouldBe` "migrations" : expected
+#else
+testDB :: Word32 -> FilePath
+testDB randSuffix = "tests/tmp/test_migrations.db" <> show randSuffix
+
+createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore randSuffix migrations confirmMigrations = do
+  let dbOpts =
+        DBOpts {
+          dbFilePath = testDB randSuffix,
+          dbKey = "",
+          keepKey = False,
+          vacuum = True,
+          track = DB.TQOff
+        }
+  createDBStore dbOpts migrations confirmMigrations
+
+cleanup :: Word32 -> IO ()
+cleanup randSuffix = removeFile (testDB randSuffix)
+
+shouldHaveTables :: DBStore -> [String] -> IO ()
+st `shouldHaveTables` expected = do
+  tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1")
+  tables `shouldBe` "migrations" : expected
+#endif