wip

.github/workflows/build.yml

@@ -11,51 +11,34 @@ on:
 
 jobs:
   build:
-    name: build-${{ matrix.os }}
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        include:
-          - os: ubuntu-18.04
-          - os: ubuntu-20.04
+    runs-on: ubuntu-20.04
     steps:
       - name: Clone project
         uses: actions/checkout@v2
 
-      - name: Setup Haskell
+      - name: Setup Stack
         uses: haskell/actions/setup@v1
         with:
-          ghc-version: "8.10.7"
-          cabal-version: "latest"
+          ghc-version: '8.10.7'
+          enable-stack: true
+          stack-version: 'latest'
 
       - name: Cache dependencies
         uses: actions/cache@v2
         with:
-          path: |
-            ~/.cabal/store
-            dist-newstyle
-          key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
+          path: ~/.stack
+          key: ${{ hashFiles('stack.yaml') }}
 
-      - name: Build
-        shell: bash
-        run: cabal build --enable-tests
-
-      - name: Test
-        if: matrix.os == 'ubuntu-18.04'
-        timeout-minutes: 30
-        shell: bash
-        run: cabal test --test-show-details=direct
-
-      - name: Prepare binaries
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+      - name: Build & test
+        id: build_test
         shell: bash
         run: |
-          mv $(cabal list-bin smp-server) smp-server-ubuntu-20_04-x86-64
-          mv $(cabal list-bin ntf-server) ntf-server-ubuntu-20_04-x86-64
+          stack build --test --force-dirty
+          install_root=$(stack path --local-install-root)
+          mv ${install_root}/bin/smp-server smp-server-ubuntu-20_04-x86-64
 
       - name: Build changelog
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+        if: startsWith(github.ref, 'refs/tags/v')
         id: build_changelog
         uses: mikepenz/release-changelog-builder-action@v1
         with:
@@ -66,8 +49,19 @@ jobs:
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
+      - name: Extract release candidate
+        if: startsWith(github.ref, 'refs/tags/v')
+        id: extract_release_candidate
+        shell: bash
+        run: |
+          if [[ ${GITHUB_REF} == *rc* ]]; then
+            echo "::set-output name=release_candidate::true"
+          else
+            echo "::set-output name=release_candidate::false"
+          fi
+
       - name: Create release
-        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
+        if: startsWith(github.ref, 'refs/tags/v')
         uses: softprops/action-gh-release@v1
         with:
           body: |
@@ -75,11 +69,10 @@ jobs:
 
             Commits:
             ${{ steps.build_changelog.outputs.changelog }}
-          prerelease: true
+          prerelease: ${{ steps.extract_release_candidate.outputs.release_candidate }}
           files: |
             LICENSE
             smp-server-ubuntu-20_04-x86-64
-            ntf-server-ubuntu-20_04-x86-64
           fail_on_unmatched_files: true
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

.gitignore

@@ -4,6 +4,3 @@
 *.session.sql
 tests/tmp
 dist-newstyle/
-
-cabal.project.local
-cabal.project.local~

CHANGELOG.md

@@ -1,188 +1,24 @@
-# 4.0.0
-
-SMP server:
-
-- Basic authentication. The server address can now include an optional password that is required to create messaging queues, so the contacts who message you will not be able to receive messages via your server, unless you share with them the address with the password. It is recommended to enable basic authentication on all private servers by adding `create_password` parameter into AUTH section of server INI file (the previously deployed servers do not have this section, you need to add it).
-- Disable creating new queues completely with `new_queues: off` parameter in AUTH section of INI file - it can be used to simplify migrating the exising connections to another server.
-- Updated server CLI with changed defaults:
-  - interactive server initialization, use -y flag to initalize the server non-interactively.
-  - store log is now enabled by default, so messaging queues and messages are restored when the server is restarted (to restore undelivered messages the server needs to be stopped with SIGINT signal).
-  - a random password is now generated by default during the server initialization.
-
-SMP agent:
-
-- API to test SMP servers. It connects to the server, creates and deletes a messaging queue. The new SimpleX Chat client uses this API to allow you to test that you have the correct server address, with the valid certificate fingerprint and pasword, before enabling the new server.
-
-# 3.4.0
-
-SMP agent:
-
-- increase concurrency with connection-level locks
-- fix issues identified in security assessment (see the announcement: https://github.com/simplex-chat/simplex-chat/blob/stable/blog/20221108-simplex-chat-v4.2-security-audit-new-website.md)
-- manual connection queue rotation
-- optional client data in connection requests links
-
-SMP server:
-
-- specialize monad stack to improve performance
-- log slow commands
-
-# 3.3.0
-
-SMP server:
-
-- allow repeated KEY command with the same key (to avoid failures on retries)
-
-SMP agent:
-
-- enable/disable connection notifications
-- asynchronous commands that retry on network error
-- use SQLCipher
-
-# 3.2.0
-
-SMP agent:
-
-- Support multiple server hostnames (including onion hostnames) in server addresses.
-- Network configuration options.
-- Options to define rules to choose server hostname.
-
-# 3.1.0
-
-SMP server and agent:
-
-- SMP protocol v4: batching multiple server commands/responses in a transport block.
-
-# 3.0.0
-
-SMP server:
-
-- restore undeliverd messages when the server is restarted.
-- SMP protocol v3 to support push notification:
-  - updated SEND and MSG to add message flags (for notification flag that contros whether the notification is sent and for any future extensions) and to move message meta-data sent to the recipient into the encrypted envelope.
-  - update NKEY and NID to add e2e encryption keys (for the notification meta-data encryption between SMP server and the client), and update NMSG to include this meta-data.
-  - update ACK command to include message ID (to avoid acknowledging unprocessed message).
-  - add NDEL commands to remove notification subscription credentials from SMP queue.
-  - add GET command to receive messages without subscription - to be used in iOS notification service extension to receive messages without terminating app subscriptions.
-
-SMP agent:
-
-- new protocol for duplex connection handshake reducing traffic and connection time.
-- support for SMP notifications server and managing device token.
-- remove redundant FQDN validation from TLS handshake to prepare for access via Tor.
-- support for fully stopping agent and for termporary suspending agent operations.
-- improve management of duplicate message delivery.
-
-SMP notifications server v1.0:
-
-- SMP notifications protocol with version negotiation during handshake.
-- device token registration and verification (via background notification).
-- SMP notification subscriptions and push notifications via APNS.
-- restoring notification subscriptions when the server is restarted.
-
-# 2.3.0
-
-SMP server:
-
-- Save and restore undelivered messages, to avoid losing them. To save messages the server has to be stopped with SIGINT signal, if it is stopped with SIGTERM undelivered messages would not be saved.
-
-# 2.2.0
-
-SMP server:
-
-- Fix sockets/threads/memory leak
-
-SMP agent:
-
-- Support stopping and resuming agent with `disconnectAgentClient` / `resumeAgentClient`
-
-# 2.1.1
-
-SMP server:
-
-- gracefully close sockets on client disconnection
-- CLI warning when deleting server configuration
-
-# 2.1.0
-
-SMP server:
-
-- configuration to expire inactive clients in ini file, increased TTL and check interval for client expiration
-
-# 2.0.0
-
-Push notifications server (beta):
-
-- supports APNS
-- manage device tokens verification via notification delivery
-- sending periodic background notification to check messages (not more frequent than every 20 min)
-
-SMP server:
-
-- disconnect inactive clients after some period
-- remove undelivered messages after 30 days
-- log aggregate usage daily stats: only the number of queues created/secured/deleted/used and messages sent/delivered is logged, as one line per day, so we can plan server capacity and diagnose any problems.
-
-SMP agent:
-
-- manage device tokens and notification server connection
-- DOWN/UP events to the agent user about server disconnections/reconnections are now sent once per server
-
-# 1.1.0
-
-SMP server:
-
-- message TTL and periodic deletion of old messages
-- configuration to prevent creation of the new queues
-
-SMP agent:
-
-- asynchronous connection handshake
-- configurable SMP servers at run-time
-- use TCP keep-alive for connection stability
-- improve stability of connection subscriptions
-- auto-vacuum DB to remove deleted records
-
-# 1.0.3
-
-SMP server:
-
-- Reduce server message queue quota to 128 messages.
-
-SMP agent:
-
-- Add "yes to migrations" option.
-- Make new SMP client attempt to reconnect on network error.
-- Reduce connection handshake expiration to 2 days.
-
-JSON encoding of types used in simplex-chat, some other minor adjustments.
-
 # 1.0.2
 
 General:
-
 - Enable TLS 1.3 parameters for TLS handshake (server and client).
 - Switch from hs-tls fork to original repo now that it supports getFinished and getPeerFinished APIs for both TLS 1.2 and TLS 1.3.
 
 SMP server:
-
 - Perform TLS handshake in a separate thread per-connection.
 
 SMP agent:
-
 - Cease attempts to send HELLO after one week timeout.
 - Coalesce requests to connect to SMP servers, to have 1 connection per server.
 
 # 1.0.1
 
 SMP server:
-
 - Explicitly set line buffering in stdout/stderr to log each line when output is redirected to files.
 
 # 1.0.0
 
 Security and privacy improvements:
-
 - Faster and more secure 2-layer E2E encryption with additional encryption layer between servers and recipients:
   - application messages in each duplex connection (managed by SMP agents - see [overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md)) are encrypted using [double-ratchet algorithm](https://www.signal.org/docs/specifications/doubleratchet/), providing forward secrecy and break-in recovery. This layer uses two Curve448 keys per client for [X3DH key agreement](https://www.signal.org/docs/specifications/x3dh/), SHA512 based HKDFs and AES-GCM AEAD encryption.
   - SMP client messages are additionally E2E encrypted in each SMP queue to avoid cipher-text correlation of messages sent via multiple redundant queues (that will be supported soon). This and the next layer use [NaCl crypto_box algorithm](https://nacl.cr.yp.to/index.html) with XSalsa20Poly1305 cipher and Curve25519 keys for DH key agreement.
@@ -195,16 +31,13 @@ Security and privacy improvements:
 - Server identity verification via server offline certificate fingerprints included in SMP server addresses.
 
 New functionality:
-
 - Support for notification servers with new SMP commands: `NKEY`/`NID`, `NSUB`/`NMSG`.
 
 Efficiency improvements:
-
 - Binary protocol encodings to reduce overhead from circa 15% to approximately 3.7% of transmitted application message size, with only 2.2% overhead for SMP protocol messages.
 - More performant cryptographic algorithms.
 
 For more information about SimpleX:
-
 - [SimpleX overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md).
 - [SimpleX chat v1 announcement](https://github.com/simplex-chat/simplex-chat/blob/master/blog/20220112-simplex-chat-v1-released.md).
 

README.md

@@ -11,7 +11,7 @@ If you have a server deployed please deploy a new server to a new host and retir
 
 ## Message broker for unidirectional (simplex) queues
 
-SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
+SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
 
 SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
 
@@ -27,19 +27,17 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
 
 ### SMP server
 
-[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
+[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies, including low power/low memory devices.
 
-To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
+To initialize the server use `smp-server init` command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
 
 SMP server uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues.
 
 To enable store log, initialize server using `smp-server -l` command, or modify `smp-server.ini` created during initialization (uncomment `enable: on` option in the store log section). Use `smp-server --help` for other usage tips.
 
-Starting from version 2.3.0, when store log is enabled, the server would also enable saving undelivered messages on exit and restoring them on start. This can be disabled via a separate setting `restore_messages` in `smp-server.ini` file. Saving messages would only work if the server is stopped with SIGINT signal (keyboard interrupt), if it is stopped with SIGTERM signal the messages would not be saved.
-
 > **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
 
-SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
+SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
 
 #### Running SMP server on MacOS
 
@@ -62,21 +60,20 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP client library
 
-[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
-
+[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
 - execute commands with a functional API.
 - receive messages and other notifications via STM queue.
 - automatically send keep-alive commands.
 
 ### SMP agent
 
-[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
+[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
 
-Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
+Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
 
 See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
 
-[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
+[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
 
 ## Using SMP server and SMP agent
 
@@ -90,106 +87,7 @@ You can either run your own SMP server locally or deploy using [Linode StackScri
 
 It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
 
-## Deploy SMP server on Linux
-
-You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
-
-Notice that `smp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
-
-```sh
-# For Ubuntu
-apt update && apt install openssl
-```
-
-### Install binaries
-
-#### Using Docker
-
-On Linux, you can deploy smp server using Docker.
-
-1. Build your `smp-server` image:
-
-   ```sh
-   git clone https://github.com/simplex-chat/simplexmq
-   cd simplexmq
-   git checkout stable
-   DOCKER_BUILDKIT=1 docker build -t smp-server -f ./download.Dockerfile .
-   ```
-2. Run your Docker container:
-   ```sh
-   docker run -d \
-	     --name smp-server \
-	     -e addr="your_ip_or_domain" \
-	     -p 5223:5223 \
-	     -v ${PWD}/scripts/docker/config:/etc/opt/simplex \
-	     -v ${PWD}/scripts/docker/logs:/var/opt/simplex \
-	     smp-server
-   ```
-
-#### Ubuntu
-
-For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
-
-### Build from source
-
-#### Using Docker
-
-> **Please note:** to build the app use source code from [stable branch](https://github.com/simplex-chat/simplexmq/tree/stable).
-
-On Linux, you can build smp server using Docker.
-
-1. Build your `smp-server` image:
-
-   ```sh
-   git clone https://github.com/simplex-chat/simplexmq
-   cd simplexmq
-   git checkout stable
-   DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
-   ```
-2. Run your Docker container:
-   ```sh
-   docker run -d \
-	     --name smp-server \
-	     -e addr="your_ip_or_domain" \
-	     -p 5223:5223 \
-	     -v ${PWD}/scripts/docker/config:/etc/opt/simplex \
-	     -v ${PWD}/scripts/docker/logs:/var/opt/simplex \
-	     smp-server
-   ```
-
-#### Using your distribution
-
-1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal:
-
-   ```sh
-   curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
-   ghcup install ghc 8.10.7
-   ghcup install cabal
-   ghcup set ghc 8.10.7
-   ghcup set cabal
-   ```
-
-2. Build the project:
-
-   ```sh
-   git clone https://github.com/simplex-chat/simplexmq
-   cd simplexmq
-   git checkout stable
-   # On Ubuntu. Depending on your distribution, use your package manager to determine package names.
-   apt-get update && apt-get install -y build-essential libgmp3-dev zlib1g-dev
-   cabal update
-   cabal install
-   ```
-
-- Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
-
-- Run `smp-server start` to start SMP server, or you can configure a service manager to run it as a service.
-
-- Optionally, `smp-server` can be setup for having an onion address in `tor` network. See: [`scripts/tor`](./scripts/tor/). In this case, the server address can have both public and onion hostname pointing to the same server, to allow two people connect when only one of them is using Tor. The server address would be: `smp://<fingerprint>@<public_hostname>,<onion_hostname>`
-
-See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
-
-[<img alt="Linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
+[<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
 
 ## Deploy SMP server on Linode
 
@@ -200,11 +98,11 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 - Create a Linode account or login with an already existing one.
 - Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode".
 - You can optionally configure the following parameters:
-  - SMP Server store log flag for queue persistence on server restart, recommended.
-  - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
-    - read/write for "linodes"
-    - read/write for "domains"
-  - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
+    - SMP Server store log flag for queue persistence on server restart, recommended.
+    - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
+      - read/write for "linodes"
+      - read/write for "domains"
+    - Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
 - Choose the region and plan, Shared CPU Nanode with 1Gb is sufficient.
 - Provide ssh key to be able to connect to your Linode via ssh. If you haven't provided a Linode API token this step is required to login to your Linode and get the server's fingerprint either from the welcome message or from the file `/etc/opt/simplex/fingerprint` after server starts. See [Linode's guide on ssh](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) .
 - Deploy your Linode. After it starts wait for SMP server to start and for tags to appear (if a Linode API token was provided). It may take up to 5 minutes depending on the connection speed on the Linode. Connecting Linode IP address to provided domain name may take some additional time.
@@ -213,7 +111,7 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
-[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
+[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
 
 ## Deploy SMP server on DigitalOcean
 
@@ -241,12 +139,12 @@ smp-server init [-l] -n <fqdn>
 
 ## SMP server design
 
-![SMP server design](./design/server.svg)
+![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
 
 ## SMP agent design
 
-![SMP agent design](./design/agent2.svg)
+![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
 
 ## License
 
-[AGPL v3](./LICENSE)
+[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)

apps/ntf-server/Main.hs

@@ -1,18 +0,0 @@
-module Main where
-
-import Control.Logger.Simple
-import Simplex.Messaging.Notifications.Server.Main
-
-cfgPath :: FilePath
-cfgPath = "/etc/opt/simplex-notifications"
-
-logPath :: FilePath
-logPath = "/var/opt/simplex-notifications"
-
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
-
-main :: IO ()
-main = do
-  setLogLevel LogDebug -- change to LogError in production
-  withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath

apps/smp-agent/Main.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -7,21 +6,12 @@ module Main where
 
 import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Server (runSMPAgent)
-import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
-cfg = defaultAgentConfig
-
-servers :: InitialAgentServers
-servers =
-  InitialAgentServers
-    { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = [],
-      netCfg = defaultNetworkConfig
-    }
+cfg = defaultAgentConfig {smpServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -30,4 +20,4 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
+  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg

apps/smp-server/Main.hs

@@ -1,18 +1,319 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Main where
 
-import Control.Logger.Simple
-import Simplex.Messaging.Server.Main
+import Control.Monad.Except
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Ini (Ini, lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.X509.Validation (Fingerprint (..))
+import Network.Socket (HostName, ServiceName)
+import Options.Applicative
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Server (runSMPServer)
+import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath)
+import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), simplexMQVersion)
+import Simplex.Messaging.Transport.Server (loadFingerprint)
+import Simplex.Messaging.Transport.WebSockets (WS)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
+import System.Exit (exitFailure)
+import System.FilePath (combine)
+import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile)
+import System.Process (readCreateProcess, shell)
+import Text.Read (readMaybe)
 
-cfgPath :: FilePath
-cfgPath = "/etc/opt/simplex"
+cfgDir :: FilePath
+cfgDir = "/etc/opt/simplex"
 
-logPath :: FilePath
-logPath = "/var/opt/simplex"
+logDir :: FilePath
+logDir = "/var/opt/simplex"
 
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+iniFile :: FilePath
+iniFile = combine cfgDir "smp-server.ini"
+
+storeLogFile :: FilePath
+storeLogFile = combine logDir "smp-server-store.log"
+
+caKeyFile :: FilePath
+caKeyFile = combine cfgDir "ca.key"
+
+caCrtFile :: FilePath
+caCrtFile = combine cfgDir "ca.crt"
+
+serverKeyFile :: FilePath
+serverKeyFile = combine cfgDir "server.key"
+
+serverCrtFile :: FilePath
+serverCrtFile = combine cfgDir "server.crt"
+
+fingerprintFile :: FilePath
+fingerprintFile = combine cfgDir "fingerprint"
 
 main :: IO ()
 main = do
-  setLogLevel LogDebug
-  withGlobalLogging logCfg $ smpServerCLI cfgPath logPath
+  getCliCommand >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`."
+        _ -> initializeServer opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions)
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`."
+    Delete -> cleanup >> putStrLn "Deleted configuration and log files"
+
+exitError :: String -> IO ()
+exitError msg = putStrLn msg >> exitFailure
+
+data CliCommand
+  = Init InitOptions
+  | Start
+  | Delete
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName
+  }
+  deriving (Show)
+
+data SignAlgorithm = ED448 | ED25519
+  deriving (Read, Show)
+
+getCliCommand :: IO CliCommand
+getCliCommand =
+  customExecParser
+    (prefs showHelpOnEmpty)
+    ( info
+        (helper <*> versionOption <*> cliCommandP)
+        (header version <> fullDesc)
+    )
+  where
+    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
+
+cliCommandP :: Parser CliCommand
+cliCommandP =
+  hsubparser
+    ( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
+        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+    )
+  where
+    initP :: Parser CliCommand
+    initP =
+      Init
+        <$> ( InitOptions
+                <$> switch
+                  ( long "store-log"
+                      <> short 'l'
+                      <> help "Enable store log for SMP queues persistence"
+                  )
+                <*> option
+                  (maybeReader readMaybe)
+                  ( long "sign-algorithm"
+                      <> short 'a'
+                      <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
+                      <> value ED448
+                      <> showDefault
+                      <> metavar "ALG"
+                  )
+                <*> strOption
+                  ( long "ip"
+                      <> help
+                        "Server IP address used as Subject Alternative Name for TLS online certificate, \
+                        \also used as Common Name if FQDN is not supplied"
+                      <> value "127.0.0.1"
+                      <> showDefault
+                      <> metavar "IP"
+                  )
+                <*> (optional . strOption)
+                  ( long "fqdn"
+                      <> short 'n'
+                      <> help "Server FQDN used as Common Name and Subject Alternative Name for TLS online certificate"
+                      <> showDefault
+                      <> metavar "FQDN"
+                  )
+            )
+
+initializeServer :: InitOptions -> IO ()
+initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+  cleanup
+  createDirectoryIfMissing True cfgDir
+  createDirectoryIfMissing True logDir
+  createX509
+  fp <- saveFingerprint
+  createIni
+  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server."
+  printServiceInfo fp
+  warnCAPrivateKeyFile
+  where
+    createX509 = do
+      createOpensslCaConf
+      createOpensslServerConf
+      -- CA certificate (identity/offline)
+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
+      run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
+      -- server certificate (online)
+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
+      run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
+      run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
+      where
+        run cmd = void $ readCreateProcess (shell cmd) ""
+        opensslCaConfFile = combine cfgDir "openssl_ca.conf"
+        opensslServerConfFile = combine cfgDir "openssl_server.conf"
+        serverCsrFile = combine cfgDir "server.csr"
+        createOpensslCaConf =
+          writeFile
+            opensslCaConfFile
+            "[req]\n\
+            \distinguished_name = req_distinguished_name\n\
+            \prompt = no\n\n\
+            \[req_distinguished_name]\n\
+            \CN = SMP server CA\n\
+            \O = SimpleX\n\n\
+            \[v3]\n\
+            \subjectKeyIdentifier = hash\n\
+            \authorityKeyIdentifier = keyid:always\n\
+            \basicConstraints = critical,CA:true\n"
+        -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
+        -- IP and FQDN can't both be used as server address interchangeably even if IP is added
+        -- as Subject Alternative Name, unless the following validation hook is disabled:
+        -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
+        createOpensslServerConf =
+          writeFile
+            opensslServerConfFile
+            ( "[req]\n\
+              \distinguished_name = req_distinguished_name\n\
+              \prompt = no\n\n\
+              \[req_distinguished_name]\n"
+                <> ("CN = " <> cn <> "\n\n")
+                <> "[v3]\n\
+                   \basicConstraints = CA:FALSE\n\
+                   \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
+                   \extendedKeyUsage = serverAuth\n"
+            )
+          where
+            cn = fromMaybe ip fqdn
+
+    saveFingerprint = do
+      Fingerprint fp <- loadFingerprint caCrtFile
+      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
+      pure fp
+
+    createIni = do
+      writeFile iniFile $
+        "[STORE_LOG]\n\
+        \# The server uses STM memory to store SMP queues and messages,\n\
+        \# that will be lost on restart (e.g., as with redis).\n\
+        \# This option enables saving SMP queues to append only log,\n\
+        \# and restoring them when the server is started.\n\
+        \# Log is compacted on start (deleted queues are removed).\n\
+        \# The messages in the queues are not logged.\n"
+          <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+          <> "[TRANSPORT]\n\
+             \port: 5223\n\
+             \websockets: off\n"
+
+    warnCAPrivateKeyFile =
+      putStrLn $
+        "----------\n\
+        \You should store CA private key securely and delete it from the server.\n\
+        \If server TLS credential is compromised this key can be used to sign a new one, \
+        \keeping the same server identity and established connections.\n\
+        \CA private key location:\n"
+          <> caKeyFile
+          <> "\n----------"
+
+data IniOptions = IniOptions
+  { enableStoreLog :: Bool,
+    port :: ServiceName,
+    enableWebsockets :: Bool
+  }
+
+-- TODO ? properly parse ini as a whole
+mkIniOptions :: Ini -> IniOptions
+mkIniOptions ini =
+  IniOptions
+    { enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",
+      port = T.unpack $ strict "TRANSPORT" "port",
+      enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"
+    }
+  where
+    strict :: String -> String -> T.Text
+    strict section key =
+      fromRight (error ("no key " <> key <> " in section " <> section)) $
+        lookupValue (T.pack section) (T.pack key) ini
+
+runServer :: IniOptions -> IO ()
+runServer IniOptions {enableStoreLog, port, enableWebsockets} = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  fp <- checkSavedFingerprint
+  printServiceInfo fp
+  storeLog <- openStoreLog
+  let cfg = mkServerConfig storeLog
+  printServerConfig cfg
+  runSMPServer cfg
+  where
+    checkSavedFingerprint = do
+      savedFingerprint <- loadSavedFingerprint
+      Fingerprint fp <- loadFingerprint caCrtFile
+      when (B.pack savedFingerprint /= strEncode fp) $
+        exitError "Stored fingerprint is invalid."
+      pure fp
+
+    mkServerConfig storeLog =
+      ServerConfig
+        { transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],
+          tbqSize = 16,
+          serverTbqSize = 128,
+          msgQueueQuota = 256,
+          queueIdBytes = 24,
+          msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
+          caCertificateFile = caCrtFile,
+          privateKeyFile = serverKeyFile,
+          certificateFile = serverCrtFile,
+          storeLog
+        }
+
+    openStoreLog :: IO (Maybe (StoreLog 'ReadMode))
+    openStoreLog =
+      if enableStoreLog
+        then Just <$> openReadStoreLog storeLogFile
+        else pure Nothing
+
+    printServerConfig ServerConfig {storeLog, transports} = do
+      putStrLn $ case storeLog of
+        Just s -> "Store log: " <> storeLogFilePath s
+        Nothing -> "Store log disabled."
+      forM_ transports $ \(p, ATransport t) ->
+        putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
+
+cleanup :: IO ()
+cleanup = do
+  deleteDirIfExists cfgDir
+  deleteDirIfExists logDir
+  where
+    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
+
+printServiceInfo :: ByteString -> IO ()
+printServiceInfo fpStr = do
+  putStrLn version
+  B.putStrLn $ "Fingerprint: " <> strEncode fpStr
+
+version :: String
+version = "SMP server v" <> simplexMQVersion
+
+loadSavedFingerprint :: IO String
+loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine

build.Dockerfile

@@ -1,51 +0,0 @@
-FROM ubuntu:focal AS final
-FROM ubuntu:focal AS build
-
-### Build stage
-
-# Install curl and git and smp-related dependencies
-RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev
-
-# Install ghcup
-RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghcup && \
-    chmod +x /usr/bin/ghcup
-
-# Install ghc
-RUN ghcup install ghc 8.10.7
-# Install cabal
-RUN ghcup install cabal
-# Set both as default
-RUN ghcup set ghc 8.10.7 && \
-    ghcup set cabal
-
-COPY . /project
-WORKDIR /project
-
-# Adjust PATH
-ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
-
-# Compile smp-server
-RUN cabal update
-RUN cabal install
-
-### Final stage
-
-FROM final
-
-# Install OpenSSL dependency
-RUN apt-get update && apt-get install -y openssl
-
-# Copy compiled smp-server from build stage
-COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
-
-# Copy our helper script
-COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
-
-# Open smp-server listening port
-EXPOSE 5223
-
-# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
-STOPSIGNAL SIGINT
-
-# Finally, execute helper script
-ENTRYPOINT [ "/usr/bin/entrypoint" ]

cabal.project

@@ -1,17 +1,6 @@
 packages: .
--- packages: . ../direct-sqlcipher ../sqlcipher-simple
 
 source-repository-package
     type: git
-    location: https://github.com/simplex-chat/aeson.git
+    location: git://github.com/simplex-chat/aeson.git
     tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
-
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/direct-sqlcipher.git
-    tag: 34309410eb2069b029b8fc1872deb1e0db123294
-
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/sqlcipher-simple.git
-    tag: 5e154a2aeccc33ead6c243ec07195ab673137221

download.Dockerfile

@@ -1,20 +0,0 @@
-FROM ubuntu:focal
-
-# Install curl
-RUN apt-get update && apt-get install -y curl
-
-# Download latest smp-server release and assign executable permission
-RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64 -o /usr/bin/smp-server && \
-	chmod +x /usr/bin/smp-server
-
-# Copy our helper script
-COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
-
-# Open smp-server listening port
-EXPOSE 5223
-
-# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
-STOPSIGNAL SIGINT
-
-# Finally, execute helper script
-ENTRYPOINT [ "/usr/bin/entrypoint" ]

img/linode.svg

@@ -1 +1 @@
-<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>

package.yaml

@@ -1,7 +1,7 @@
 name: simplexmq
-version: 4.0.0
+version: 1.0.2
 synopsis: SimpleXMQ message broker
-description: |
+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:
@@ -28,42 +28,35 @@ dependencies:
   - asn1-types == 0.3.*
   - async == 2.2.*
   - attoparsec == 0.14.*
-  - base >= 4.14 && < 5
+  - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
   - bytestring == 0.10.*
-  - case-insensitive == 1.2.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
   - containers == 0.6.*
   - cryptonite >= 0.27 && < 0.30
   - cryptostore == 0.2.*
   - data-default == 0.7.*
-  - direct-sqlcipher == 2.3.*
+  - direct-sqlite == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 3.0.*
   - generic-random >= 1.3 && < 1.5
-  - ini == 0.4.1
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
-  - network >= 3.1.2.7 && < 3.2
-  - network-transport == 0.5.4
-  - optparse-applicative >= 0.15 && < 0.17
+  - network == 3.1.*
+  - network-transport == 0.5.*
+  - postgresql-simple == 0.6.*
   - QuickCheck == 2.14.*
-  - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
-  - socks == 0.6.*
-  - sqlcipher-simple == 0.4.*
+  - sqlite-simple == 0.4.*
   - stm == 2.5.*
   - template-haskell == 2.16.*
   - text == 1.2.*
   - time == 1.9.*
-  - time-compat == 1.9.*
-  - time-manager == 0.0.*
-  - tls >= 1.6.0 && < 1.7
+  - tls >= 1.5.7 && < 1.6
   - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
@@ -72,17 +65,6 @@ dependencies:
   - x509-store == 1.6.*
   - x509-validation == 1.6.*
 
-flags:
-  swift:
-    description: Enable swift JSON format
-    manual: True
-    default: False
-
-when:
-  - condition: flag(swift)
-    cpp-options:
-      - -DswiftJSON
-
 library:
   source-dirs: src
 
@@ -91,14 +73,9 @@ executables:
     source-dirs: apps/smp-server
     main: Main.hs
     dependencies:
-      - simplexmq
-    ghc-options:
-      - -threaded
-
-  ntf-server:
-    source-dirs: apps/ntf-server
-    main: Main.hs
-    dependencies:
+      - ini == 0.4.*
+      - optparse-applicative >= 0.15 && < 0.17
+      - process == 1.6.*
       - simplexmq
     ghc-options:
       - -threaded
@@ -121,8 +98,6 @@ tests:
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
       - QuickCheck == 2.14.*
-      - silently == 1.2.*
-      - main-tester == 0.2.*
       - timeit == 2.0.*
 
 ghc-options:

protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd

@@ -1,71 +0,0 @@
-sequenceDiagram
-  participant A as Alice
-  participant AA as Alice's<br>agent
-  participant AS as Alice's<br>server
-  participant BS as Bob's<br>server
-  participant BA as Bob's<br>agent
-  participant B as Bob
-
-  note over AA, BA: status (receive/send): NONE/NONE
-
-  note over A, AA: 1. request connection<br>from agent
-  A ->> AA: NEW: create<br>duplex connection
- 
-  note over AA, AS: 2. create Alice's SMP queue
-  AA ->> AS: NEW: create SMP queue
-  AS ->> AA: IDS: SMP queue IDs
-  note over AA: status: NEW/NONE
-
-  AA ->> A: INV: invitation<br>to connect
-
-  note over A, B: 3. out-of-band invitation
-  A ->> B: OOB: invitation to connect
-
-  note over BA, B: 4. accept connection
-  B ->> BA: JOIN:<br>via invitation info
-  note over BA: status: NONE/NEW
-
-  note over BA, BS: 5. create Bob's SMP queue
-  BA ->> BS: NEW: create SMP queue
-  BS ->> BA: IDS: SMP queue IDs
-  note over BA: status: NEW/NEW
-
-  note over BA, AA: 6. establish Alice's SMP queue
-  BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
-  note over BA: status: NEW/CONFIRMED
-
-  AS ->> AA: MSG: Bob's info and<br>sender server key
-  note over AA: status: CONFIRMED/NONE
-  AA ->> AS: ACK: confirm message
-  AA ->> A: CONF: connection request ID<br>and Bob's info
-  A ->> AA: LET: accept connection request,<br>send Alice's info
-  AA ->> AS: KEY: secure queue
-  note over AA: status: SECURED/NONE
-
-  AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
-  note over AA: status: SECURED/CONFIRMED
-
-  BS ->> BA: MSG: Alice's info and<br>sender's server key
-  note over BA: status: CONFIRMED/CONFIRMED
-  BA ->> B: INFO: Alice's info
-  BA ->> BS: ACK: confirm message
-  BA ->> BS: KEY: secure queue
-  note over BA: status: SECURED/CONFIRMED
-
-  BA ->> AS: SEND: HELLO: only needs to be sent once in v2
-
-  note over BA: status: SECURED/ACTIVE
-  note over BA, B: 7a. notify Bob<br>about connection success
-  BA ->> B: CON: connected
-
-  AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
-  note over AA: status: SECURED/ACTIVE
-  AA ->> AS: ACK: confirm message
-  note over A, AA: 7a. notify Alice<br>about connection success
-  AA ->> A: CON: connected
-
-  AA ->> BS: SEND: HELLO: only needs to be sent once in v2
-  note over AA: status: ACTIVE/ACTIVE
-  BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
-  note over BA: status: ACTIVE/ACTIVE
-  BA ->> BS: ACK: confirm message

protocol/diagrams/duplex-messaging/duplex-creating.mmd

@@ -33,8 +33,8 @@ sequenceDiagram
   AS ->> AA: MSG: Bob's info and<br>sender server key
   note over AA: status: CONFIRMED/NONE
   AA ->> AS: ACK: confirm message
-  AA ->> A: CONF: connection request ID<br>and Bob's info
-  A ->> AA: LET: accept connection request,<br>send Alice's info
+  AA ->> A: REQ: connection request ID<br>and Bob's info
+  A ->> AA: ACPT: accept connection request,<br>send Alice's info
   AA ->> AS: KEY: secure queue
   note over AA: status: SECURED/NONE
 

protocol/diagrams/notifications/register-token.mmd

@@ -1,30 +0,0 @@
-sequenceDiagram
-  participant M as mobile app
-  participant C as chat core
-  participant A as agent
-  participant P as push server
-  participant APN as APN
-
-  note over M, APN: get device token
-  M ->> APN: registerForRemoteNotifications()
-  APN ->> M: device token
-
-  note over M, P: register device token with push server
-  M ->> C: /_ntf register <token>
-  C ->> A: registerNtfToken(<token>)
-  A ->> P: TNEW
-  P ->> A: ID (tokenId)
-  A ->> C: registered
-  C ->> M: registered
-
-  note over M, APN: verify device token
-  P ->> APN: E2E encrypted code<br>in background<br>notification
-  APN ->> M: deliver background notification with e2ee verification token
-  M ->> C: /_ntf verify <e2ee code>
-  C ->> A: verifyNtfToken(<e2ee code>)
-  A ->> P: TVFY code
-  P ->> A: OK / ERR
-  A ->> C: verified
-  C ->> M: verified
-
-  note over M, APN: now token ID can be used

protocol/diagrams/notifications/subscription.mmd

@@ -1,40 +0,0 @@
-sequenceDiagram
-  participant M as mobile app
-  participant C as chat core
-  participant A as agent
-  participant S as SMP server
-  participant N as NTF server
-  participant APN as APN
-
-  note over M, APN: register subscription
-
-  alt register existing
-    M -->> A: on /_ntf register, for subscribed queues
-  else create new connection
-    A -->> S: NEW / JOIN
-    note over A, S: ...<br>Connection handshake<br>...
-    S -->> A: CON
-  end
-  A ->> S: NKEY nKey
-  S ->> A: NID nId
-  A ->> N: SNEW tknId dhKey (smpServer, nId, nKey)
-  N ->> A: ID subId dhKey
-  N ->> S: NSUB nId
-  S ->> N: OK [/ NMSG]
-
-  note over M, APN: notify about message
-
-  S ->> N: NMSG
-  N ->> APN: APNSMutableContent<br>ntfQueue, nonce
-  APN ->> M: UNMutableNotificationContent
-  note over M, S: ...<br>Client awaken, message is received<br>...
-  S ->> M: message
-  note over M: mutate notification
-
-  note over M, APN: change APN token
-
-  APN ->> M: new device token
-  M -->> C: /_ntf_sub update tkn
-  C -->> A: updateNtfToken()
-  A -->> N: TUPD tknId newDeviceToken
-  note over M, N: ...<br>Verify token<br>...

protocol/simplex-messaging.md

@@ -24,7 +24,6 @@
     - [Subscribe to queue](#subscribe-to-queue)
     - [Secure queue command](#secure-queue-command)
     - [Enable notifications command](#enable-notifications-command)
-    - [Disable notifications command](#disable-notifications-command)
     - [Acknowledge message delivery](#acknowledge-message-delivery)
     - [Suspend queue](#suspend-queue)
     - [Delete queue](#delete-queue)
@@ -51,8 +50,6 @@ It's designed with the focus on communication security and integrity, under the
 
 It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
 
-This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
-
 ## Introduction
 
 The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
@@ -149,61 +146,61 @@ To create and start using a simplex queue Alice and Bob follow these steps:
 
 1. Alice creates a simplex queue on the server:
 
-   1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
+    1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
 
-   2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
+    2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
 
-   3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
+    3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
 
-   4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
+    4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
 
-   5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
+    5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
 
-   6. The server sends `"IDS"` response with queue IDs (`queueIds`):
+    6. The server sends `"IDS"` response with queue IDs (`queueIds`):
 
-      - Recipient ID `RID` for Alice to manage the queue and to receive the messages.
+        - Recipient ID `RID` for Alice to manage the queue and to receive the messages.
 
-      - Sender ID `SID` for Bob to send messages to the queue.
+        - Sender ID `SID` for Bob to send messages to the queue.
 
-      - Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
+        - Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
 
 2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include:
 
-   - Unique "public" key (`EK`) that Bob must use for E2E key agreement.
+    - Unique "public" key (`EK`) that Bob must use for E2E key agreement.
 
-   - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
+    - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
 
-   - Sender queue ID `SID` for Bob to use.
+    - Sender queue ID `SID` for Bob to use.
 
 3. Bob, having received the out-of-band message from Alice, connects to the queue:
 
-   1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
+    1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
 
-   2. Prepares the confirmation message for Alice to secure the queue. This message includes:
+    2. Prepares the confirmation message for Alice to secure the queue. This message includes:
 
-      - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
+        - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
 
-      - Optionally, any additional information (application specific, e.g. Bob's profile name and details).
+        - Optionally, any additional information (application specific, e.g. Bob's profile name and details).
 
-   3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
+    3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
 
-   4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
+    4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
 
 4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)):
 
-   1. She decrypts received message body using the secret `SS`.
+    1. She decrypts received message body using the secret `SS`.
 
-   2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
+    2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
 
-   3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
+    3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
 
 5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
 
-   1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
+    1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
 
-   2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
+    2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
 
-   3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
+    3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
 
 6. The simplex queue `RID` is now ready to be used.
 
@@ -217,21 +214,21 @@ Bob now can securely send messages to Alice:
 
 1. Bob sends the message:
 
-   1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
+    1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
 
-   2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
+    2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
 
-   3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
+    3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
 
 2. Alice receives the message(s):
 
-   1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
+    1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
 
-   2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
+    2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
 
-   3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
+    3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
 
-   4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
+    4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
 
 This flow is show on sequence diagram below.
 
@@ -358,22 +355,18 @@ To protect the privacy of the recipients, there are several commands in SMP prot
 The clients can optionally instruct a dedicated push notification server to subscribe to notifications and deliver push notifications to the device, which can then retrieve the messages in the background and send local notifications to the user - this is out of scope of SMP protocol. The commands that SMP protocol provides to allow it:
 
 - `enableNotifications` (`"NKEY"`) with `notifierId` (`"NID"`) response - see [Enable notifications command](#enable-notifications-command).
-- `disableNotifications` (`"NDEL"`) - see [Disable notifications command](#disable-notifications-command).
 - `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
 - `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
 
-[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
-
-## SMP Transmission andtransport block structure
+## SMP Transmission structure
 
 Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
 
-From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
 Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
 
 In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
 
-```abnf
+```
 paddedString = originalLength string pad
 originalLength = 2*2 OCTET
 pad = N*N"#" ; where N = paddedLength - originalLength - 2
@@ -383,9 +376,9 @@ paddedNotation = <padded(string, paddedLength)>
 ; paddedLength - required length after padding, including 2 bytes for originalLength
 ```
 
-Each transmission/block for SMP v3 between the client and the server must have this format/syntax:
+Each transmission between the client and the server must have this format/syntax:
 
-```abnf
+```
 paddedTransmission = <padded(transmission), 16384>
 transmission = [signature] SP signed
 signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
@@ -402,23 +395,13 @@ encoded = <base64 encoded binary>
 
 `base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
 
-Transport block for SMP v4 has this syntax:
-
-```abnf
-paddedTransportBlock = <padded(transportBlock), 16384>
-transportBlock = transmissionCount transmissions
-transmissionCount = 1*1 OCTET ; equal or greater than 1
-transmissions = transmissionLength transmission [transmissions]
-transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
-```
-
 ## SMP commands
 
 Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
 
 ```abnf
 smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg
-recipientCmd = create / subscribe / secure / enableNotifications / disableNotifications /
+recipientCmd = create / subscribe / secure / enableNotifications /
                acknowledge / suspend / delete
 serverMsg = queueIds / message / notifierId / messageNotification /
             unsubscribed / ok / error
@@ -519,42 +502,22 @@ Once the queue is secured only signed messages can be sent to it.
 This command is sent by the recipient to the server to add notifier's key to the queue, to allow push notifications server to receive notifications when the message arrives, via a separate queue ID, without receiving message content.
 
 ```abnf
-enableNotifications = %s"NKEY " notifierKey recipientNotificationDhPublicKey
+enableNotifications = %s"NKEY " notifierKey
 notifierKey = length x509encoded
 ; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue
-
-recipientNotificationDhPublicKey = length x509encoded
-; the recipient's Curve25519 key for DH exchange to derive the secret
-; that the server will use to encrypt notification metadata (encryptedNMsgMeta in NMSG)
-; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
 ```
 
 The server will respond with `notifierId` response if notifications were enabled and the notifier's key was successfully added to the queue:
 
 ```abnf
-notifierId = %s"NID " notifierId srvNotificationDhPublicKey
+notifierId = %s"NID " notifierId
 notifierId = length *OCTET ; 16-24 bytes
-srvNotificationDhPublicKey = length x509encoded
-; the server's Curve25519 key for DH exchange to derive the secret
-; that the server will use to encrypt notification metadata to the recipient (encryptedNMsgMeta in NMSG)
 ```
 
 This response is sent with the recipient's queue ID (the third part of the transmission).
 
 To receive the message notifications, `subscribeNotifications` command ("NSUB") must be sent signed with the notifier's key.
 
-#### Disable notifications command
-
-This command is sent by the recipient to the server to remove notifier's credentials from the queue:
-
-```abnf
-disableNotifications = %s"NDEL"
-```
-
-The server must respond `ok` to this command if it was successful.
-
-Once notifier's credentials are removed server will no longer send "NMSG" for this queue to notifier.
-
 #### Acknowledge message delivery
 
 The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted:
@@ -602,9 +565,7 @@ Currently SMP defines only one command that can be used by senders - `send` mess
 This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured:
 
 ```abnf
-send = %s"SEND " msgFlags SP smpEncMessage
-msgFlags = notificationFlag reserved
-notificationFlag = %s"T" / %s"F"
+send = %s"SEND " smpEncMessage
 smpEncMessage = smpPubHeader sentMsgBody ; message up to 16088 bytes
 smpPubHeader = smpClientVersion ("1" senderPublicDhKey / "0")
 smpClientVersion = word16
@@ -746,11 +707,9 @@ See its syntax in [Create queue command](#create-queue-command)
 The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is:
 
 ```abnf
-message = %s"MSG " msgId encryptedRcvMsgBody
+message = %s"MSG " msgId SP timestamp SP encryptedMsgBody
 encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
 paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 16088
-encryptedRcvMsgBody = <encrypt rcvMsgBody> ; server-encrypted meta-data and padded sent msgBody
-rcvMsgBody = timestamp msgFlags SP paddedSentMsgBody
 msgId = length 24*24OCTET
 timestamp = 8*8OCTET
 ```
@@ -776,19 +735,10 @@ See its syntax in [Enable notifications command](#enable-notifications-command)
 The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command ("NSUB") on the currently open transport connection. The syntax for the message notification delivery is:
 
 ```abnf
-messageNotification = %s"NMSG " nmsgNonce encryptedNMsgMeta
-
-encryptedNMsgMeta = <encrypted message metadata passed in notification>
-; metadata E2E encrypted between server and recipient containing server's message ID and timestamp (allows extension),
-; to be passed to the recipient by the notifier for them to decrypt
-; with key negotiated in NKEY and NID commands using nmsgNonce
-
-nmsgNonce = <nonce used in NaCl crypto_box encryption scheme>
-; nonce used by the server for encryption of message metadata, to be passed to the recipient by the notifier
-; for them to use in decryption of E2E encrypted metadata
+messageNotification = %s"NMSG"
 ```
 
-Message notification does not contain any message data or non E2E encrypted metadata.
+Message notification does not contain any message data or meta-data, it only notifies that the message is available.
 
 #### Subscription END notification
 
@@ -820,7 +770,7 @@ The syntax for error responses:
 ```abnf
 error = %s"ERR " errorType
 errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
-cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY"
+cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
 ```
 
 Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
@@ -842,7 +792,6 @@ ok = %s"OK"
 Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223.
 
 For scenarios when meta-data privacy is critical, it is recommended that clients:
-
 - communicating over Tor network,
 - establish a separate connection for each SMP queue,
 - send noise traffic (using PING command).
@@ -850,14 +799,12 @@ For scenarios when meta-data privacy is critical, it is recommended that clients
 In addition to that, the servers can be deployed as Tor onion services.
 
 The transport protocol should provide the following:
-
 - server authentication (by matching server certificate hash with `serverIdentity`),
 - forward secrecy (by encrypting the traffic using ephemeral keys agreed during transport handshake),
 - integrity (preventing data modification by the attacker without detection),
 - unique channel binding (`sessionIdentifier`) to include in the signed part of SMP transmissions.
 
 By default, the client and server communicate using [TLS 1.3 protocol][13] restricted to:
-
 - TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices),
 - ed25519 and ed448 EdDSA algorithms for signatures,
 - x25519 and x448 ECDHE groups for key exchange.

protocol/simplex-uri-request.txt

@@ -13,6 +13,6 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
 
 References:
 The syntax for connection requests in the latest version of SimpleX Agent Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#connection-request
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/agent-protocol.md#connection-request
 SimpleX Messaging Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md

protocol/smp-uri-request.txt

@@ -13,4 +13,4 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
 
 References:
 The syntax for message queue URIs in the latest version of SimpleX Messaging Protocol:
-https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#smp-queue-uri
+https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md#smp-queue-uri

rfcs/2022-04-20-smp-conf-timeout-recovery.md

@@ -1,21 +0,0 @@
-# SMP confirmation timeout recovery
-
-## Problem
-
-When sending an SMP confirmation a network timeout can lead to the following race condition:
-- server receives the confirmation while the joining party fails to receive the server's response;
-- joining party deletes the connection together with credentials sent in the confirmation for securing the queue;
-- initiating party will receive the confirmation from the server and secure the queue;
-- on subsequent attempt to join via the same invitation link initiating party will generate new credentials and fail authorization.
-
-This renders the joining party permanently unable to join via that invitation link and complete the connection.
-
-## Solution
-
-A possible solution is to keep and try to reuse same credentials on subsequent attempts:
-- joining party has to remember invitation link when saving the connection;
-- if SMP confirmation fails due to network timeout joining party doesn't delete the connection and keeps the credentials;
-- when joining, joining party checks whether such invitation link was already used for a connection, if yes:
-  - joining party tries to send SMP confirmation with the same credentials;
-  - if this SMP confirmation fails with authorization error (for example it can happen due to race condition explained above) joining party tries to send HELLO message;
-  - if HELLO message fails with authorization error (it can happen if connection was deleted or secured with different credentials), the recovery is no longer possible and connection can be deleted.

rfcs/2022-07-22-access-via-tor.md

@@ -1,26 +0,0 @@
-# Accessing SMP servers via Tor
-
-## Problem
-
-While SMP protocol is focussed on minimizing application-level meta-data by using pair-wise identifiers instead of user profile identifiers, it is important for many users to protect their IP addresses.
-
-Further, even if IP addresses are hidden by onion routing, clients should be able to choose to use a separate TCP connection to subscribe to each queue, even though it increases traffic and battery consumption, as otherwise the servers can observe multiple queues accessed by the same client.
-
-## Solution and requirements
-
-While some users may want to access SMP servers via tor, some other users (even their contacts) may want the opposite - e.g., if they use the network when accessing Tor would be suspicious (or blocked).
-
-Therefore we need to support the connections when one of the user accesses the same server via Tor (and, possibly, via onion address), while another user accesses this server without Tor.
-
-At the same time the user accessing the server via Tor may not want that their contacts access this server without Tor, and it also may be possible that the server is not available under a normal (not .onion) address.
-
-The proposed options for connecting via Tor are:
-
-1. Access servers via Socks proxy: no/yes (specify port?)
-2. Use .onion addresses: no/when available/warn/always
-3. Require senders to use .onion addresses: yes/no
-4. Use separate TCP connection for each queue
-
-While it should be possible for SMP servers to have two addresses (with and without Tor), the queues should only use one server address - if the queue started being accessed via .onion address it should not be possible to access it via a normal address. Queue addresses in connection invitations should support dual server addresses (when senders are not required ot use .onion address).
-
-At the same time, the queue with the normal addresses can be accessed with and without Tor, depending on the current device settings.

rfcs/2022-08-14-queue-rotation.md

@@ -1,53 +0,0 @@
-# SMP queue rotation and redundancy
-
-## Problem
-
-1. Long term usage of the queue allows the servers to analyze long term traffic patterns.
-
-2. If the user changes the configured SMP server(s), the previously created contacts do not migrate to the new server(s).
-
-3. Server can lose messages.
-
-## Solution
-
-Additional messages exchanged by SMP agents to negotiate addition and removal of queues to the connection.
-
-This approach allows for both rotation and redundancy, as changing queue will be done be adding a queue and then removing the existing queue.
-
-The reason for this approach is that otherwise it's non-trivial to switch from one queue to another without losing messages or delivering them out of order, it's easier to have messages delivered via both queues during the switch, however short or long time it is.
-
-### Messages
-
-Additional agent messages required for the protocol:
-
-    QADD_ -> "QA"
-    QKEY_ -> "QK"
-    QUSE_ -> "QU"
-    QTEST_ -> "QT"
-
-`QADD`: add the new queue address(es), the same format as `REPLY` message, encoded as `QA`.
-
-`QKEY`: pass sender's key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker), encoded as `QK`.
-
-`QUSE`: instruct the sender to use the new queue with sender's queue ID as parameter, encoded as `QU`.
-
-`QTEST`: send test message to the new connection, encoded as `QT`. Any other message can be sent if available to continue rotation, the absence of this message is not an error. Once this message is successfully sent the sender will stop using the old queue. Once this message (or any other message in the new queue) is received, the recipient will stop using the old queue and delete it.
-
-### Protocol
-
-```
-participant A as Alice
-participant B as Bob
-participant R as Server that has A's receive queue
-participant S as Server that has A's send queue (B's receive queue)
-participant R' as Server that hosts the new A's receive queue
-
-A ->> R': create new queue
-A ->> S ->> B: QADD (R'): snd address of the new queue(s)
-B ->> S(R) ->> A: QKEY (R'): sender's key for the new queue(s) (to avoid the race of SMP confirmation for the initial exchange)
-A ->> S(R'): secure new queue
-A ->> S ->> B: QUSE (R'): instruction to use new queue(s)
-B ->> S(R') ->> A: QTEST
-A ->> S(R): DEL: delete the old queue
-B ->> S(R') ->> A: send all new messages to the new queue
-```

rfcs/2022-11-11-smp-basic-auth.md

@@ -1,27 +0,0 @@
-# SMP Basic Auth
-
-## Problem
-
-Users who host their own servers do not want unknown people to be able to create messaging queues on their servers after discovering server address in groups or after making a connection. As the number of self-hosted servers is growing it became more important than it was when we excluded it from the original design.
-
-## Solution
-
-Single access password that can be optionally included in server address that is passed to app configuration. It will not be allowed in the existing contexts (and parsing will fail), to avoid accidentally leaking it. Server address with password will look this way: `smp://fingerprint:password@hosts`
-
-## Implementation plan
-
-1. A separate type to include server and password, so it can only be used where allowed.
-
-2. Server password to create queues will be configured in TRANSPORT section of INI file, as `create_password` parameter.
-
-3. The password will only be required in server configuration/address to create queues only, it won't be required for other receiving queue operations on already existing queues.
-
-4. If new command is attempted in the session that does not allow creating queues, the server will send `ERR AUTH` response
-
-5. Passing password to the server can be done in one of the several ways, we need to decide:
-
-  - as a parameter of NEW command. Pros: a local change, that only needs checking when queue is created. Cons: protocol version change.
-  - as a separate command AUTH. Pros: allows to include additional parameters and potentially be extended beyond basic auth. Cons: more complex to manage server state, can be more difficult syntax in the future, if extended.
-  - as part of handshake (we currently ignore the unparsed part of handshake block, so it can be extended). Pros: probably, the simplest, and independent of the commands protocol – establishes create permission for the current session. Cons: the client won't know about whether it is able to create the queue until it tries (same as in case 1).
-
-  My preference is the last option. As a variant of the last option, we can add a server response/message that includes permission to create queues - it will only be sent to the clients who pass credential in handshake - that might simplify testing server connection (we currently do not do it). It might be unnecessary, as we could simply create and delete queue in case credential is passed as part of testing connection (and even sending a message to it).

rfcs/done/2022-03-22-nofication-server.md

@@ -1,91 +0,0 @@
-# Notification server
-
-## Background and motivation
-
-SimpleX Chat clients should receive message notifications when not being online and/or subscribed to SMP servers.
-
-To avoid revealing identities of clients directly to SMP servers via any kind of push notification tokens, a new party called SimpleX Notification Server is introduced to act as a service for subscribing to SMP server queue notifications on behalf of clients and sending push notifications to them.
-
-## Proposal
-
-TCP service using the same TLS transport as SMP server, with the fixed size blocks (256 bytes?) and the following set of commands:
-
-### Protocol
-
-#### Create subscription
-
-Command:
-
-`%s"CREATE " ntfSmpQueueURI ntfPrivateKey token subPublicKey`
-
-Response:
-
-`s%"OK"`
-
-#### Check subscription status
-
-Command:
-
-`%s"CHECK " ntfSmpQueueURI`
-
-Response:
-
-```abnf
-statusResp = %s"STAT " status
-status = %s"ERR AUTH" / "ERR SMP AUTH" / %s"ERR SMP TIMEOUT" / %s"ACTIVE" / %s"PENDING"
-```
-
-#### Update subscription device token
-
-Command:
-
-`%s"TOKEN " ntfSmpQueueURI token`
-
-Response:
-
-`s%"OK" / %s"ERR"`
-
-#### Delete subscription (e.g. when deleting the queue or moving to another notification server)
-
-Command:
-
-`%s"DELETE " SP ntfSmpQueueURI`
-
-Response:
-
-`s%"OK" / %s"ERR"`
-
-### Agent schema changes
-
-See [migration](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220322_notifications.hs)
-
-### Agent code
-
-```haskell
-data NtfOptions = NtfOptions
-  { ntfServer :: Server, -- same type as for SMP servers, probably will be renamed
-    ntfToken :: ByteString,
-    ntfInitialCheckDelay :: Int, -- initial check delay after subscription is created, seconds
-    ntfPeriodicCheckInterval :: Int -- subscription check interval, seconds
-  }
-
-data AgentConfig = AgentConfig {
-  -- ...
-  initialNtfOpts :: Maybe NtfOptions
-  -- ...
-  }
-
-data AgentClient = AgentClient {
-  -- ...
-  ntfOpts :: TVar (Maybe NtfOptions)
-  -- ...
-  }
-```
-
-A configuration parameter `initialNtfOpts :: Maybe NtfOptions` - if it is set or changes the agent would automatically manage subscriptions as SMP queues are subscribed/created/deleted and as the token or server changes.
-
-There will be a method to update notifications configuration in case token or server changes.
-
-All subscriptions will be managed in a separate subscription management loop, that would always take the earliest un-updated subscription that requires some action (ntf_sub_action column) and perform this action - the table of subscription would serve both as the table of existing subscriptions and required actions.
-
-E.g. if the queue is subscribed and there is no notification subscription, it will be created in the table with "create" action, and the loop would create it and schedule "check" action on it.

rfcs/done/2022-06-05-smp-notifications.md

@@ -1,34 +0,0 @@
-# SMP protocol changes to support push notifications on iOS
-
-## Problem
-
-There are already commands/responses to allow subscriptions to message notifications - NKEY/NID, NSUB/NMSG. These commands will be used by SMP agent (NKEY/NID) and by notification server (NSUB/NMSG) to have message notifications delivered to notification server, so it can forward them to APNS server using device token.
-
-There are two remaining problems that these commands do not solve.
-
-1. Receiving the message when notification arrives.
-
-iOS requires creating a bundled notification service extension (NSE) that runs in isolated container and, if we were to use the existing commands, would have SMP subscription to the same SMP servers as the main app, triggering resubscriptions every time the message reception switches between the app and NSE. That would cause a substantial increase in traffic and battery consumption to the users.
-
-2. Showing notifications for service messages.
-
-Users do not expect to see notifications for every single SMP messages - e.g., we currently do not show notifications when messages are edited and deleted, and users do not expect them. NSE requires that for every received push notification there should be some notification shown to the users. So only we would have to show a notification for message deletes and updates, we would have to show it for all service messages - e.g. user accepted file invitation, or file transmission has started, contact profile updates and so on.
-
-We considered differentiating whether notifications are sent per queue, from the recipient side, so we do not send notifications for file queues. But it seems insufficient, particularly if we add such features as message receipts, status updates, etc.
-
-## Proposal
-
-1. To retrieve messages when push notifications arrive, we will add 2 SMP commands:
-
-- GET: retrieve one message from the connection. Resonse could be either MSG (the same as when MSG is delivered, but with the correlation id) or GMSG (to simplify processing) – TBC during implementation. If message is not available, the response could be ERR NO_MSG
-- ACK or GACK: acknowledge that the message was processed by the client and can be removed - TBC which one is better. The response is OK or ERR NO_MSG if there was nothing to acknowledge (same as with ACK now)
-
-This would allow receiving a single message from the queue without subscription, this way avoiding that the main app is unsubscribed from the queue.
-
-2. The only way to avoid showing unnecessary notifications (status updates, service messages, etc.) is to avoid sending them. That requires instructing SMP server whether notification should be sent both per queue, from the recipient side, and per message - from the sender side. So the notification would only be sent if the queue has them enabled (via NKEY command) and the sender includes an additional flag in SEND command. The same flag should be included into MSG, so when the message is retrieved with GET command, the client knows, on the agent or chat level (or both), whether this message should have notification shown to the user, and if not - retrieve the next one(s) as well.
-
-This is a substantial change to SMP protocol, that would require client and server upgrade for notifications to be supported.
-
-We should consider whether to increase the SMP protocol version number to 2, so that the new clients can connect to the old clients but without notifications, or we could keep the old commands in the protocol and instead of adding flags to the existing commands, create new commands.
-
-We can also consider making commands extensible so that the new flags can be added (and ignored by parsers if not supported) to at least some existing commands.

rfcs/done/2022-06-13-db-sync.md

@@ -1,75 +0,0 @@
-# DB access and processing messages for iOS notification service extension
-
-## Problem
-
-The only way to receive/process notificaitons is via a separate NSE process that requires a concurrent DB and network access.
-
-SQLite concurenncy does not work, so we need to sync database access.
-
-The problem is complex, as we do not directly control db access from the app, it can be triggered by the message arriving and it may fail to complete in case the app is suspended in the background.
-
-So we need to prevent db access from starting when we know the app is about to be suspended.
-
-The last problem is how to receive and process messages in NSE - should it use recently added GET command or should it subscribe to the connections that receive messages and process messages normally.
-
-To summarize, 2 problems need to be solved:
-
-1. sync db access between 2 (or more, if we add share extension) processes
-
-2. prevent access from starting when the process is due to suspend, only complete operations.
-
-3. Receiveing and processing agent messages in NSE
-
-## Proposed solution
-
-For problem 1, we can use Posix semaphores from our core code, in the same bracket that manages database connection - it would wait for semaphore to be free and unlock it once the db operation is complete.
-
-For problem 2, we need to communicate from the app when it goes to the background to prevent database access starting and completing before the suspension. This would set some `aboutToSuspend` STM flag (or the opposite) that would prevent operations from progressing (using STM retry, that would block until the flag has the value allowing operation to progress).
-
-Several possibilities can be considered:
-
-- use this flag in the bracket that provides DB connections. While simple, it may lock some operations in the middle and may also lead to the situation when network operation succeeds but database access was blocked, and the database is not updated.
-- use this flag to stop network operations that would require database updates - like sending messages, subscriptions and ACK - all these operations would require database access once they succeed.
-- use two flags, for both cases above, but set them at different times since going to background - block new network operations as soon as the app goes to the background and block database access once the app is about to be suspended.
-
-The last option seems more robust. To do it, there will be an api allowing the app to communicat its phase:
-
-- app going to the background would trigger blocking new network operations and start a new background task - `background` phase.
-- background task receiving completion warning, or, maybe, some time after it is started - probably 20 seconds - or whatever happens earlier - would trigger call blocking db access - `suspended` phase.
-- app becoming active would trigger unblocking both flags - `active` phase.
-
-`/_app phase <phase>` where `phase` can be one of the above values.
-
-NSE would also use the same phases:
-
-- sending `active` when it is started (the process starts as active, but it is possible that the new notification arrives to the same process, after the previous one sent background/suspension)
-- sending `background + suspended` (or `suspended` should set both flags) once it is finished processing the notification, provided no new notification arrived and started processing - this should be tracked in NSE.
-
-For problem 3, NSE can do one of the following:
-
-- use SUB and process messages normally - the downside is that the app will have to resubscribe and it has to be tracked.
-- use GET and process messages by pushing them through the processing function - the downside it that a rewiring of message processing is needed.
-- use GET but deliver messages through the same queue as when they arrive normally (in which case getMessage agent function should not return the message, but will return a flag showing whether the message was received, or, possibly, or, possibly will return a message but the message would also be sent to the queue?).
-- process messages in agent manually and in chat via the queue.
-
-One of the downside of GET is that it requires calling GET again after ACK. We could have two variants of ACK (or additional ACK parameter) - one that never delivers a new message, and another one that does. In this case, if get needs to process the next message (when the current one has no notification flag), it can call ACK that delivers the next message. But, it is probably a premature optimization, and having general support of batched commands would add more value.
-
-Additional problem is concurrency in NSE - if the new notification from the same queue arrives before the current one finishes processing in the same process one of the following can happen:
-
-- the 2nd notification naively call GET and receives the same message.
-- the 2nd notification waits until the first finished processing, in which case it can run out of time.
-
-The problem is that the app won't know it's the same queue, as nId is encrypted, so the agent should handle this scenario when the new call to getMessage is made before the previous one finished processing, and differentiate between calls made for additional messages (possibly, getMessage should include previous message ID, if it is available) and the first call.
-
-EDIT: GETs have to be sent from UI to chat and from chat to agent as function calls, but the agent will have to queue get calls to make sure they return different messages. GET call would return message flags (incl. notification flag), so that the UI can send the next GET if needed without waiting.
-
-Considered alternative: include notification content in the message and have NSE only perform decryption, without any network IO. In this case notification content would be in SEND and in NMSG, e2e encrypted.
-
-While promising, as it solves network coordination issues and makes GET unnecessary, it creates mutliple other problems, so it was rejected:
-
-- message content is exposed to centralized ntf and apns servers, creating additional attack vector.
-- it adds complexity in security critical parts of the stack - double ratchet encryption, as it requires either storing message keys and using different IVs for notifications, or initializing completely separate ratchet for notifications content.
-- it reduces the size of the message.
-- it makes user experience worse, as:
-  - it would not accelerate handshake for new contacts and for file delivery - this approach only works for content messages.
-  - it would open the app without the new messages - the users would have to wait until the messages are received. It is also bad for "security optics" - the users might think that the message content was exposed to notifications.

rfcs/done/2022-06-13-db-sync.mmd

@@ -1,61 +0,0 @@
-sequenceDiagram
-  participant M as iOS message<br>notification
-  participant S as iOS system
-  participant N as iOS NSE
-  participant U as iOS UI
-  participant C as Core chat
-  participant A as Core agent
-
-  M ->> N: notification
-  S ->> N: get app pref
-  note over N: ignore,<br>app is active
-
-  note over M, A: app going to background
-  S ->> U: phase: background<br>(possibly, "will" method)
-  U ->> S: set app pref "pausing"
-  U ->> C: /_app phase paused, result CRCmdOk
-  C ->> A: pauseAgent<br>(no new network IO)
-  M ->> N: notification
-  S ->> N: get app pref
-  note over N: wait/poll for<br>"paused"/"suspending"/"suspended"<br>event/pref
-  A ->> C: event "IO paused"<br>(after in-flight op completed)<br>PHASE PAUSED
-  C ->> U: event "IO paused" (CRAppPaused)
-  U ->> S: set shared pref "paused"
-
-  note over M, A: process notification
-  M ->> N: notification
-  S ->> N: get app pref<br>continue if<br>"paused"/"suspending"/"suspended"
-  N ->> S: set NSE pref "active"
-  N ->> C: /_get message
-  C ->> A: getMessage
-  A ->> C: msg flags
-  C ->> N: msg flags
-  note over N: get messages<br>until notification flag set
-  A ->> C: MSG/CONF/INFO
-  C ->> N: some event
-  N ->> S: set NSE pref "completed"
-  N ->> S: show notification
-
-  note over M, A: app about to be suspended<br>(or 15-20 sec after background)
-  S ->> U: background task notice
-  U ->> S: set app pref "suspending"
-  U ->> C: /_app phase suspended, response ok
-  C ->> A: suspendAgent<br>(no new DB)
-  A ->> C: event "DB paused"<br>(after in-flight op completed)<br>PHASE SUSPENDED
-  C ->> U: event "DB paused" (CRAppSuspended)
-  U ->> S: set app pref "suspended"
-
-  note over M, A: app about to be activated
-  S ->> U: phase: active<br>(or inactive?)<br><br>(possibly, "will" method)
-  S ->> U: get NSE pref
-  U ->> S: set app pref "activating"
-  alt nse active?
-    U ->> C: /_app phase inactive
-    note over U: poll/wait till NSE pref is "completed"
-  end
-
-  U ->> C: /_app phase active (response result)
-  C ->> A: activateAgent<br>(allow IO/DB)
-  A ->> C: result ()
-  C ->> U: CRCmdOk
-  U ->> S: set app pref "active"

scripts/docker/entrypoint

@@ -1,23 +0,0 @@
-#!/usr/bin/env sh
-confd="/etc/opt/simplex"
-logd="/var/opt/simplex/"
-
-# Check if server has been initialized
-if [ ! -f "$confd/smp-server.ini" ]; then
-	# If not, determine ip or domain
-	case $addr in
-		'') printf "Please specify \$addr environment variable.\n"; exit 1 ;;
-		*[a-zA-Z]*) smp-server init -y -l -n "$addr" ;;
-		*) smp-server init -y -l --ip "$addr" ;;
-	esac
-
-fi
-
-# backup store log
-[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log.bak
-# rotate server log
-[ -f "$logd/smp-server.log" ] && mv "$logd"/smp-server.log "$logd"/smp-server-"$(date +'%FT%T')".log
-
-# Finally, run smp-sever. Notice that "exec" here is important:
-# smp-server replaces our helper script, so that it can catch INT signal
-exec smp-server start > "$logd"/smp-server.log 2>&1

scripts/ntf-server-linode.sh

@@ -1,178 +0,0 @@
-#!/bin/bash
-
-# <UDF name="enable_store_log" label="Store log - persist notification subscriptions to append only log and restore them upon server restart." default="on" oneof="on, off" />
-# <UDF name="api_token" label="Linode API token - enable Linode to create tags with server address, fingerprint and version. Note: minimal permissions token should have are read/write access to `linodes` (to create tags) and `domains` (to add A record for the third level domain if FQDN is provided)." default="" />
-# <UDF name="fqdn" label="FQDN (Fully Qualified Domain Name) - provide third level domain name (e.g. ntf.example.com). If provided use `ntf://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `ntf://fingerprint@IP` instead." default="" />
-# <UDF name="apns_key_id" label="APNS key ID." default="" />
-
-# Log all stdout output to stackscript.log
-exec &> >(tee -i /var/log/stackscript.log)
-
-# Uncomment next line to enable debugging features
-# set -xeo pipefail
-
-cd $HOME
-
-# https://superuser.com/questions/1638779/automatic-yess-to-linux-update-upgrade
-# https://superuser.com/questions/1412054/non-interactive-apt-upgrade
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  update
-
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  dist-upgrade
-
-# TODO install unattended-upgrades
-sudo DEBIAN_FRONTEND=noninteractive \
-  apt-get \
-  -o Dpkg::Options::=--force-confold \
-  -o Dpkg::Options::=--force-confdef \
-  -y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
-  install jq
-
-# Add firewall
-echo "y" | ufw enable
-
-# Open ports
-ufw allow ssh
-ufw allow https
-ufw allow 5223
-
-# Increase file descriptors limit
-echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
-echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
-echo 'root soft nofile unlimited' >> /etc/security/limits.conf
-echo 'root hard nofile unlimited' >> /etc/security/limits.conf
-
-# Download latest release
-bin_dir="/opt/simplex-notifications/bin"
-binary="$bin_dir/ntf-server"
-mkdir -p $bin_dir
-curl -L -o $binary https://github.com/simplex-chat/simplexmq/releases/latest/download/ntf-server-ubuntu-20_04-x86-64
-chmod +x $binary
-
-# / Add to PATH
-cat > /etc/profile.d/simplex.sh << EOF
-#!/bin/bash
-
-export PATH="$PATH:$bin_dir"
-
-EOF
-# Add to PATH /
-
-# Source and test PATH
-source /etc/profile.d/simplex.sh
-ntf-server --version
-
-# Initialize server
-init_opts=()
-
-[[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
-
-ip_address=$(curl ifconfig.me)
-init_opts+=(--ip $ip_address)
-
-[[ -n "$FQDN" ]] && init_opts+=(-n $FQDN)
-
-ntf-server init "${init_opts[@]}"
-
-# Server fingerprint
-fingerprint=$(cat /etc/opt/simplex-notifications/fingerprint)
-
-# Determine server address to specify in welcome script and Linode tag
-if [[ -n "$FQDN" ]]; then
-  server_address=$FQDN
-else
-  server_address=$ip_address
-fi
-
-# Set up welcome script
-on_login_script="/opt/simplex-notifications/on_login.sh"
-
-# / Welcome script
-cat > $on_login_script << EOF
-#!/bin/bash
-
-fingerprint=\$1
-server_address=\$2
-
-cat << EOF2
-********************************************************************************
-
-SimpleX notifications server address: ntf://\$fingerprint@\$server_address
-Check server status with: systemctl status ntf-server
-
-To keep this server secure, the UFW firewall is enabled.
-All ports are BLOCKED except 22 (SSH), 443 (HTTPS), 5223 (notifications server).
-
-********************************************************************************
-To stop seeing this message delete line - bash /opt/simplex-notifications/on_login.sh - from /root/.bashrc
-EOF2
-
-EOF
-# Welcome script /
-
-chmod +x $on_login_script
-echo "bash $on_login_script $fingerprint $server_address" >> /root/.bashrc
-
-# Create A record and update Linode's tags
-if [[ -n "$API_TOKEN" ]]; then
-  if [[ -n "$FQDN" ]]; then
-    domain_address=$(echo $FQDN | rev | cut -d "." -f 1,2 | rev)
-    domain_id=$(curl -H "Authorization: Bearer $API_TOKEN" https://api.linode.com/v4/domains \
-    | jq --arg da "$domain_address" '.data[] | select( .domain == $da ) | .id')
-    if [[ -n $domain_id ]]; then
-      curl \
-        -s -H "Content-Type: application/json" \
-        -H "Authorization: Bearer $API_TOKEN" \
-        -X POST -d "{\"type\":\"A\",\"name\":\"$FQDN\",\"target\":\"$ip_address\"}" \
-        https://api.linode.com/v4/domains/${domain_id}/records
-    fi
-  fi
-
-  version=$(ntf-server --version | cut -d ' ' -f 3-)
-
-  curl \
-    -s -H "Content-Type: application/json" \
-    -H "Authorization: Bearer $API_TOKEN" \
-    -X PUT -d "{\"tags\":[\"$server_address\",\"$fingerprint\",\"$version\"]}" \
-    https://api.linode.com/v4/linode/instances/$LINODE_ID
-fi
-
-# / Create systemd service
-cat > /etc/systemd/system/ntf-server.service << EOF
-[Unit]
-Description=SimpleX notifications server
-
-[Service]
-Environment="APNS_KEY_FILE=/etc/opt/simplex-notifications/AuthKey.p8"
-Environment="APNS_KEY_ID=$APNS_KEY_ID"
-Type=simple
-ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex-notifications/ntf-server.log 2>&1"
-KillSignal=SIGINT
-Restart=always
-RestartSec=10
-LimitNOFILE=1000000
-LimitNOFILESoft=1000000
-
-[Install]
-WantedBy=multi-user.target
-
-EOF
-# Create systemd service /
-
-# Start systemd service
-chmod 644 /etc/systemd/system/ntf-server.service
-sudo systemctl enable ntf-server
-# ! APNS key file and certificate have to be copied manually
-# sudo systemctl start ntf-server
-
-# Reboot Linode to apply upgrades
-# sudo reboot

scripts/smp-server-digitalocean-droplet/README.md

@@ -16,8 +16,3 @@ brew install hashicorp/tap/packer
 cd ./scripts/smp-server-digitalocean-droplet
 DIGITALOCEAN_TOKEN=$YOUR_TOKEN packer build -on-error=ask -color=false ./marketplace-image.json
 ```
-
-**TODO** (see Linode script)
-
-- Increase file descriptors limit
-- Configure Restart for systemd service

scripts/smp-server-linode.sh

@@ -44,12 +44,6 @@ ufw allow ssh
 ufw allow https
 ufw allow 5223
 
-# Increase file descriptors limit
-echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
-echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
-echo 'root soft nofile unlimited' >> /etc/security/limits.conf
-echo 'root hard nofile unlimited' >> /etc/security/limits.conf
-
 # Download latest release
 bin_dir="/opt/simplex/bin"
 binary="$bin_dir/smp-server"
@@ -86,6 +80,10 @@ smp-server init "${init_opts[@]}"
 fingerprint=$(cat /etc/opt/simplex/fingerprint)
 
 # Determine server address to specify in welcome script and Linode tag
+# ! If FQDN was provided and used as part of server initialization, server's certificate will not pass validation at client
+# ! if client tries to connect by server's IP address, so we have to specify FQDN as server address in Linode tag and
+# ! in welcome script regardless of creation of A record in Linode
+# ! https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
 if [[ -n "$FQDN" ]]; then
   server_address=$FQDN
 else
@@ -153,12 +151,6 @@ Description=SMP server
 [Service]
 Type=simple
 ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
-KillSignal=SIGINT
-TimeoutStopSec=infinity
-Restart=always
-RestartSec=10
-LimitNOFILE=1000000
-LimitNOFILESoft=1000000
 
 [Install]
 WantedBy=multi-user.target

scripts/tor/README.md

@@ -1,37 +0,0 @@
-1. Install `tor` following [official guide](https://community.torproject.org/onion-services/setup/install/).
-
-2. Modify `/etc/tor/torrc` configuration file:
-
-```sh
-...
-# Disable anonymous mode for better connectivity
-## Needed for HiddenServiceNonAnonymousMode
-SOCKSPort 0
-## Needed for HiddenServiceSingleHopMode
-HiddenServiceNonAnonymousMode 1
-## Flag to disable anonymous mode
-## This option reduces the latency of server connection, but it makes server itself not anonymous,
-## it only protects the anonymity of the users connecting to the server.
-## In case your server address has both public and onion hostnames it is not anonymous anyway,
-## so this is what you want.
-HiddenServiceSingleHopMode 1
-
-# Specify folder for smp-tor
-## Folder for keys, address, etc.
-HiddenServiceDir /var/lib/tor/simplex-smp/
-## Map smp port (5223) to tor
-HiddenServicePort 5223 localhost:5223
-...
-```
-
-3. Restart `tor` system service:
-
-```
-sudo systemctl restart tor
-```
-
-4. Onion address can be obtained from following file:
-
-```sh
-sudo cat /var/lib/tor/simplex-smp/hostname
-```

scripts/update-smp-server.sh

@@ -1,12 +0,0 @@
-#!/bin/bash
-
-# systemd has to be configured to use SIGINT to save and restore undelivered messages after restart.
-# Add this to [Service] section:
-# KillSignal=SIGINT
-curl -L -o /opt/simplex/bin/smp-server-new https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64
-systemctl stop smp-server
-cp /var/opt/simplex/smp-server-store.log /var/opt/simplex/smp-server-store.log.bak
-mv /opt/simplex/bin/smp-server /opt/simplex/bin/smp-server-old
-mv /opt/simplex/bin/smp-server-new /opt/simplex/bin/smp-server
-chmod +x /opt/simplex/bin/smp-server
-systemctl start smp-server

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        4.0.0
+version:        1.0.2
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -27,72 +27,39 @@ extra-source-files:
     README.md
     CHANGELOG.md
 
-flag swift
-  description: Enable swift JSON format
-  manual: True
-  default: False
-
 library
   exposed-modules:
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
+      Simplex.Messaging.Agent.Env.Postgres
       Simplex.Messaging.Agent.Env.SQLite
-      Simplex.Messaging.Agent.Lock
-      Simplex.Messaging.Agent.NtfSubSupervisor
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
       Simplex.Messaging.Agent.RetryInterval
       Simplex.Messaging.Agent.Server
       Simplex.Messaging.Agent.Store
+      Simplex.Messaging.Agent.Store.Postgres
+      Simplex.Messaging.Agent.Store.Postgres.Migrations
+      Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial
       Simplex.Messaging.Agent.Store.SQLite
       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.TRcvQueues
       Simplex.Messaging.Client
-      Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
       Simplex.Messaging.Crypto.Ratchet
       Simplex.Messaging.Encoding
       Simplex.Messaging.Encoding.String
-      Simplex.Messaging.Notifications.Client
-      Simplex.Messaging.Notifications.Protocol
-      Simplex.Messaging.Notifications.Server
-      Simplex.Messaging.Notifications.Server.Env
-      Simplex.Messaging.Notifications.Server.Main
-      Simplex.Messaging.Notifications.Server.Push.APNS
-      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.Env.STM
-      Simplex.Messaging.Server.Expiration
-      Simplex.Messaging.Server.Main
       Simplex.Messaging.Server.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.STM
-      Simplex.Messaging.Server.Stats
       Simplex.Messaging.Server.StoreLog
-      Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Client
-      Simplex.Messaging.Transport.HTTP2
-      Simplex.Messaging.Transport.HTTP2.Client
-      Simplex.Messaging.Transport.HTTP2.Server
-      Simplex.Messaging.Transport.KeepAlive
       Simplex.Messaging.Transport.Server
       Simplex.Messaging.Transport.WebSockets
       Simplex.Messaging.Util
@@ -110,41 +77,34 @@ library
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , network ==3.1.*
+    , network-transport ==0.5.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -152,70 +112,6 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
-  default-language: Haskell2010
-
-executable ntf-server
-  main-is: Main.hs
-  other-modules:
-      Paths_simplexmq
-  hs-source-dirs:
-      apps/ntf-server
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
-  build-depends:
-      QuickCheck ==2.14.*
-    , aeson ==2.0.*
-    , 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
-    , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
-    , composition ==1.0.*
-    , constraints >=0.12 && <0.14
-    , containers ==0.6.*
-    , cryptonite >=0.27 && <0.30
-    , cryptostore ==0.2.*
-    , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
-    , directory ==1.3.*
-    , filepath ==1.4.*
-    , generic-random >=1.3 && <1.5
-    , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.1
-    , iso8601-time ==0.1.*
-    , memory ==0.15.*
-    , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
-    , random >=1.1 && <1.3
-    , simple-logger ==0.1.*
-    , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
-    , stm ==2.5.*
-    , template-haskell ==2.16.*
-    , text ==1.2.*
-    , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
-    , transformers ==0.5.*
-    , unliftio ==0.2.*
-    , unliftio-core ==0.2.*
-    , websockets ==0.12.*
-    , x509 ==1.7.*
-    , x509-store ==1.6.*
-    , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 executable smp-agent
@@ -233,42 +129,35 @@ executable smp-agent
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , network ==3.1.*
+    , network-transport ==0.5.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -276,8 +165,6 @@ executable smp-agent
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 executable smp-server
@@ -295,42 +182,38 @@ executable smp-server
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.1
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
+    , network ==3.1.*
+    , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
+    , postgresql-simple ==0.6.*
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -338,8 +221,6 @@ executable smp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010
 
 test-suite smp-server-test
@@ -350,16 +231,10 @@ test-suite smp-server-test
       AgentTests.ConnectionRequestTests
       AgentTests.DoubleRatchetTests
       AgentTests.FunctionalAPITests
-      AgentTests.NotificationTests
-      AgentTests.SchemaDump
       AgentTests.SQLiteTests
-      CLITests
-      CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
       CoreTests.VersionRangeTests
-      NtfClient
-      NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
@@ -376,47 +251,38 @@ test-suite smp-server-test
     , asn1-types ==0.3.*
     , async ==2.2.*
     , attoparsec ==0.14.*
-    , base >=4.14 && <5
+    , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
     , bytestring ==0.10.*
-    , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlcipher ==2.3.*
+    , direct-sqlite ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.1
     , iso8601-time ==0.1.*
-    , main-tester ==0.2.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.4
-    , optparse-applicative >=0.15 && <0.17
-    , process ==1.6.*
+    , network ==3.1.*
+    , network-transport ==0.5.*
+    , postgresql-simple ==0.6.*
     , random >=1.1 && <1.3
-    , silently ==1.2.*
     , simple-logger ==0.1.*
     , simplexmq
-    , socks ==0.6.*
-    , sqlcipher-simple ==0.4.*
+    , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
     , time ==1.9.*
-    , time-compat ==1.9.*
-    , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.6.0 && <1.7
+    , tls >=1.5.7 && <1.6
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -424,6 +290,4 @@ test-suite smp-server-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
-  if flag(swift)
-    cpp-options: -DswiftJSON
   default-language: Haskell2010

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

@@ -0,0 +1,88 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+module Simplex.Messaging.Agent.Env.Postgres
+  ( AgentConfig (..),
+    defaultAgentConfig,
+    Env (..),
+    newSMPAgentEnv,
+  )
+where
+
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.List.NonEmpty (NonEmpty)
+import Data.Time.Clock (NominalDiffTime, nominalDay)
+import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
+import Network.Socket
+import Numeric.Natural
+import Simplex.Messaging.Agent.Protocol (SMPServer)
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store.Postgres
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import Simplex.Messaging.Client
+import qualified Simplex.Messaging.Crypto as C
+import System.Random (StdGen, newStdGen)
+import UnliftIO.STM
+
+data AgentConfig = AgentConfig
+  { tcpPort :: ServiceName,
+    smpServers :: NonEmpty SMPServer,
+    cmdSignAlg :: C.SignAlg,
+    connIdBytes :: Int,
+    tbqSize :: Natural,
+    dbConnInfo :: ConnectInfo,
+    dbPoolSize :: Int,
+    smpCfg :: SMPClientConfig,
+    reconnectInterval :: RetryInterval,
+    helloTimeout :: NominalDiffTime,
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: FilePath
+  }
+
+defaultAgentConfig :: AgentConfig
+defaultAgentConfig =
+  AgentConfig
+    { tcpPort = "5224",
+      smpServers = undefined, -- TODO move it elsewhere?
+      cmdSignAlg = C.SignAlg C.SEd448,
+      connIdBytes = 12,
+      tbqSize = 16,
+      dbConnInfo = defaultConnectInfo {connectDatabase = "agent_poc_1"},
+      dbPoolSize = 4,
+      smpCfg = smpDefaultConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = second,
+            increaseAfter = 10 * second,
+            maxInterval = 10 * second
+          },
+      helloTimeout = 7 * nominalDay,
+      -- CA certificate private key is not needed for initialization
+      -- ! we do not generate these
+      caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
+      privateKeyFile = "/etc/opt/simplex-agent/agent.key",
+      certificateFile = "/etc/opt/simplex-agent/agent.crt"
+    }
+  where
+    second = 1_000_000
+
+data Env = Env
+  { config :: AgentConfig,
+    store :: PostgresStore,
+    idsDrg :: TVar ChaChaDRG,
+    clientCounter :: TVar Int,
+    randomServer :: TVar StdGen
+  }
+
+newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
+newSMPAgentEnv cfg@AgentConfig {dbConnInfo, dbPoolSize} = do
+  idsDrg <- newTVarIO =<< drgNew
+  store <- liftIO $ createPostgresStore dbConnInfo dbPoolSize Migrations.app
+  clientCounter <- newTVarIO 0
+  randomServer <- newTVarIO =<< liftIO newStdGen
+  return Env {config = cfg, store, idsDrg, clientCounter, randomServer}

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

@@ -1,189 +1,87 @@
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Env.SQLite
-  ( AgentMonad,
-    AgentConfig (..),
-    AgentDatabase (..),
-    databaseFile,
-    InitialAgentServers (..),
-    NetworkConfig (..),
+  ( AgentConfig (..),
     defaultAgentConfig,
-    defaultReconnectInterval,
     Env (..),
     newSMPAgentEnv,
-    createAgentStore,
-    NtfSupervisor (..),
-    NtfSupervisorCommand (..),
   )
 where
 
-import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
-import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
-import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Protocol (SMPServer)
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
-import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
-import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (TLS, Transport (..))
-import Simplex.Messaging.Transport.Client (defaultSMPPort)
-import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
-import UnliftIO (Async)
 import UnliftIO.STM
 
--- | Agent monad with MonadReader Env and MonadError AgentErrorType
-type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
-
-data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServerWithAuth,
-    ntf :: [NtfServer],
-    netCfg :: NetworkConfig
-  }
-
-data AgentDatabase
-  = AgentDB SQLiteStore
-  | AgentDBFile {dbFile :: FilePath, dbKey :: String}
-
-databaseFile :: AgentDatabase -> FilePath
-databaseFile = \case
-  AgentDB SQLiteStore {dbFilePath} -> dbFilePath
-  AgentDBFile {dbFile} -> dbFile
-
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
+    smpServers :: NonEmpty SMPServer,
     cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
-    database :: AgentDatabase,
-    yesToMigrations :: Bool,
-    smpCfg :: ProtocolClientConfig,
-    ntfCfg :: ProtocolClientConfig,
+    dbFile :: FilePath,
+    dbPoolSize :: Int,
+    smpCfg :: SMPClientConfig,
     reconnectInterval :: RetryInterval,
-    messageRetryInterval :: RetryInterval,
-    messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    ntfCron :: Word16,
-    ntfWorkerDelay :: Int,
-    ntfSMPWorkerDelay :: Int,
-    ntfSubCheckInterval :: NominalDiffTime,
-    ntfMaxMessages :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath,
-    e2eEncryptVRange :: VersionRange,
-    smpAgentVRange :: VersionRange,
-    smpClientVRange :: VersionRange,
-    initialClientId :: Int
+    certificateFile :: FilePath
   }
 
-defaultReconnectInterval :: RetryInterval
-defaultReconnectInterval =
-  RetryInterval
-    { initialInterval = 2_000000,
-      increaseAfter = 10_000000,
-      maxInterval = 180_000000
-    }
-
-defaultMessageRetryInterval :: RetryInterval
-defaultMessageRetryInterval =
-  RetryInterval
-    { initialInterval = 1_000000,
-      increaseAfter = 10_000000,
-      maxInterval = 60_000000
-    }
-
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
   AgentConfig
     { tcpPort = "5224",
+      smpServers = undefined, -- TODO move it elsewhere?
       cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
-      tbqSize = 64,
-      database = AgentDBFile {dbFile = "smp-agent.db", dbKey = ""},
-      yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
-      ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
-      reconnectInterval = defaultReconnectInterval,
-      messageRetryInterval = defaultMessageRetryInterval,
-      messageTimeout = 2 * nominalDay,
-      helloTimeout = 2 * nominalDay,
-      ntfCron = 20, -- minutes
-      ntfWorkerDelay = 100000, -- microseconds
-      ntfSMPWorkerDelay = 500000, -- microseconds
-      ntfSubCheckInterval = nominalDay,
-      ntfMaxMessages = 4,
+      tbqSize = 16,
+      dbFile = "smp-agent.db",
+      dbPoolSize = 4,
+      smpCfg = smpDefaultConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = second,
+            increaseAfter = 10 * second,
+            maxInterval = 10 * second
+          },
+      helloTimeout = 7 * nominalDay,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
       privateKeyFile = "/etc/opt/simplex-agent/agent.key",
-      certificateFile = "/etc/opt/simplex-agent/agent.crt",
-      e2eEncryptVRange = supportedE2EEncryptVRange,
-      smpAgentVRange = supportedSMPAgentVRange,
-      smpClientVRange = supportedSMPClientVRange,
-      initialClientId = 0
+      certificateFile = "/etc/opt/simplex-agent/agent.crt"
     }
+  where
+    second = 1_000_000
 
 data Env = Env
   { config :: AgentConfig,
     store :: SQLiteStore,
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
-    randomServer :: TVar StdGen,
-    ntfSupervisor :: NtfSupervisor
+    randomServer :: TVar StdGen
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} = do
+newSMPAgentEnv cfg = do
   idsDrg <- newTVarIO =<< drgNew
-  store <- case database of
-    AgentDB st -> pure st
-    AgentDBFile {dbFile, dbKey} -> liftIO $ createAgentStore dbFile dbKey yesToMigrations
-  clientCounter <- newTVarIO initialClientId
+  store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
+  clientCounter <- newTVarIO 0
   randomServer <- newTVarIO =<< liftIO newStdGen
-  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
-  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
-
-createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
-createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
-
-data NtfSupervisor = NtfSupervisor
-  { ntfTkn :: TVar (Maybe NtfToken),
-    ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
-    ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
-    ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
-  }
-
-data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
-  deriving (Show)
-
-newNtfSubSupervisor :: Natural -> STM NtfSupervisor
-newNtfSubSupervisor qSize = do
-  ntfTkn <- newTVar Nothing
-  ntfSubQ <- newTBQueue qSize
-  ntfWorkers <- TM.empty
-  ntfSMPWorkers <- TM.empty
-  pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
+  return Env {config = cfg, store, idsDrg, clientCounter, randomServer}

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,24 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Agent.Lock where
-
-import Control.Monad (void)
-import Control.Monad.IO.Unlift
-import Data.Functor (($>))
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-
-type Lock = TMVar String
-
-withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
-withLock lock name =
-  E.bracket_
-    (atomically $ putTMVar lock name)
-    (void . atomically $ takeTMVar lock)
-
-withGetLock :: MonadUnliftIO m => STM Lock -> String -> m a -> m a
-withGetLock getLock name a =
-  E.bracket
-    (atomically $ getLock >>= \l -> putTMVar l name $> l)
-    (atomically . takeTMVar)
-    (const a)

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -1,371 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Simplex.Messaging.Agent.NtfSubSupervisor
-  ( runNtfSupervisor,
-    nsUpdateToken,
-    nsRemoveNtfToken,
-    sendNtfSubCommand,
-    instantNotifications,
-    closeNtfSupervisor,
-    getNtfServer,
-  )
-where
-
-import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (stateTVar)
-import Control.Logger.Simple (logError, logInfo)
-import Control.Monad
-import Control.Monad.Except
-import Control.Monad.IO.Unlift (MonadUnliftIO)
-import Control.Monad.Reader
-import Data.Bifunctor (first)
-import Data.Fixed (Fixed (MkFixed), Pico)
-import qualified Data.Map.Strict as M
-import Data.Text (Text)
-import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
-import Simplex.Messaging.Agent.Client
-import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
-import qualified Simplex.Messaging.Agent.Protocol as AP
-import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Agent.Store
-import Simplex.Messaging.Agent.Store.SQLite
-import Simplex.Messaging.Client.Agent ()
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
-import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tshow, unlessM)
-import System.Random (randomR)
-import UnliftIO (async)
-import UnliftIO.Concurrent (forkIO, threadDelay)
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-
-runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
-runNtfSupervisor c = do
-  ns <- asks ntfSupervisor
-  forever $ do
-    cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
-    handleError connId . agentOperationBracket c AONtfNetwork waitUntilActive $
-      runExceptT (processNtfSub c cmd) >>= \case
-        Left e -> notifyErr connId e
-        Right _ -> return ()
-  where
-    handleError :: ConnId -> m () -> m ()
-    handleError connId = E.handle $ \(e :: E.SomeException) -> do
-      logError $ "runNtfSupervisor error " <> tshow e
-      notifyErr connId e
-    notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
-
-processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
-processNtfSub c (connId, cmd) = do
-  logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
-  case cmd of
-    NSCCreate -> do
-      (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
-        a <- liftIO $ getNtfSubscription db connId
-        q <- ExceptT $ getPrimaryRcvQueue db connId
-        pure (a, q)
-      logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
-      case a of
-        Nothing -> do
-          withNtfServer c $ \ntfServer -> do
-            case clientNtfCreds of
-              Just ClientNtfCreds {notifierId} -> do
-                let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
-                addNtfNTFWorker ntfServer
-              Nothing -> do
-                let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
-                addNtfSMPWorker smpServer
-        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
-          case (clientNtfCreds, ntfQueueId) of
-            (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
-              | sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
-              | otherwise -> rotate
-            (Nothing, Nothing) -> create
-            _ -> rotate
-          where
-            create :: m ()
-            create = case action_ of
-              -- action was set to NULL after worker internal error
-              Nothing -> resetSubscription
-              Just (action, _)
-                -- subscription was marked for deletion / is being deleted
-                | isDeleteNtfSubAction action -> do
-                  if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
-                    then resetSubscription
-                    else withNtfServer c $ \ntfServer -> do
-                      withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
-                      addNtfNTFWorker ntfServer
-                | otherwise -> case action of
-                  NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
-                  NtfSubSMPAction _ -> addNtfSMPWorker smpServer
-            rotate :: m ()
-            rotate = do
-              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
-              addNtfNTFWorker subNtfServer
-            resetSubscription :: m ()
-            resetSubscription =
-              withNtfServer c $ \ntfServer -> do
-                let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
-                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
-                addNtfSMPWorker smpServer
-    NSCDelete -> do
-      sub_ <- withStore' c $ \db -> do
-        supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
-        getNtfSubscription db connId
-      logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
-      case sub_ of
-        (Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
-        _ -> pure () -- err "NSCDelete - no subscription"
-    NSCSmpDelete -> do
-      withStore' c (`getPrimaryRcvQueue` connId) >>= \case
-        Right rq@RcvQueue {server = smpServer} -> do
-          logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
-          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
-          addNtfSMPWorker smpServer
-        _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer -> addNtfNTFWorker ntfServer
-    NSCNtfSMPWorker smpServer -> addNtfSMPWorker smpServer
-  where
-    addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
-    addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
-    addWorker ::
-      (NtfSupervisor -> TMap (ProtocolServer s) (TMVar (), Async ())) ->
-      (AgentClient -> ProtocolServer s -> TMVar () -> m ()) ->
-      ProtocolServer s ->
-      m ()
-    addWorker wsSel runWorker srv = do
-      ws <- asks $ wsSel . ntfSupervisor
-      atomically (TM.lookup srv ws) >>= \case
-        Nothing -> do
-          doWork <- newTMVarIO ()
-          worker <- async $ runWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
-          atomically $ TM.insert srv (doWork, worker) ws
-        Just (doWork, _) ->
-          void . atomically $ tryPutTMVar doWork ()
-
-withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
-withNtfServer c action = getNtfServer c >>= mapM_ action
-
-runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
-runNtfWorker c srv doWork = do
-  delay <- asks $ ntfWorkerDelay . config
-  forever $ do
-    void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
-    threadDelay delay
-  where
-    runNtfOperation :: m ()
-    runNtfOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
-      logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
-      case nextSub_ of
-        Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
-            processAction a
-              `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
-      ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
-        case action of
-          NSACreate ->
-            getNtfToken >>= \case
-              Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
-                case clientNtfCreds of
-                  Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
-                    nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
-                    -- TODO smaller retry until Active, less frequently (daily?) once Active
-                    let actionTs' = addUTCTime 30 ts
-                    withStore' c $ \db ->
-                      updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
-                  _ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
-              _ -> workerInternalError c connId "NSACreate - no active token"
-          NSACheck ->
-            getNtfToken >>= \case
-              Just tkn ->
-                case ntfSubId of
-                  Just nSubId ->
-                    agentNtfCheckSubscription c nSubId tkn >>= \case
-                      NSAuth -> do
-                        getNtfServer c >>= \case
-                          Just ntfServer -> do
-                            withStore' c $ \db ->
-                              updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
-                            ns <- asks ntfSupervisor
-                            atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
-                          _ -> workerInternalError c connId "NSACheck - failed to reset subscription, notification server not configured"
-                      status -> updateSubNextCheck ts status
-                  Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
-              _ -> workerInternalError c connId "NSACheck - no active token"
-          NSADelete -> case ntfSubId of
-            Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` continueDeletion
-            _ -> continueDeletion
-            where
-              continueDeletion = do
-                let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
-                withStore' c $ \db -> updateNtfSubscription db sub' (NtfSubSMPAction NSASmpDelete) ts
-                ns <- asks ntfSupervisor
-                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
-          NSARotate -> case ntfSubId of
-            Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
-                `E.finally` deleteCreate
-            _ -> deleteCreate
-            where
-              deleteCreate = do
-                withStore' c $ \db -> deleteNtfSubscription db connId
-                ns <- asks ntfSupervisor
-                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
-      where
-        updateSubNextCheck ts toStatus = do
-          checkInterval <- asks $ ntfSubCheckInterval . config
-          let nextCheckTs = addUTCTime checkInterval ts
-          updateSub (NASCreated toStatus) (NtfSubNTFAction NSACheck) nextCheckTs
-        updateSub toStatus toAction actionTs' =
-          withStore' c $ \db ->
-            updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
-
-runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
-runNtfSMPWorker c srv doWork = do
-  delay <- asks $ ntfSMPWorkerDelay . config
-  forever $ do
-    void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
-    threadDelay delay
-  where
-    runNtfSMPOperation = do
-      nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
-      logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
-      case nextSub_ of
-        Nothing -> noWorkToDo
-        Just a@(NtfSubscription {connId}, _, _) -> do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
-            processAction a
-              `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
-    processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
-      ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
-        case smpAction of
-          NSASmpKey ->
-            getNtfToken >>= \case
-              Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                rq <- withStore c (`getPrimaryRcvQueue` connId)
-                C.SignAlg a <- asks (cmdSignAlg . config)
-                (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
-                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
-                (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
-                let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
-                withStore' c $ \db -> do
-                  setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NtfSubNTFAction NSACreate) ts
-                ns <- asks ntfSupervisor
-                atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
-              _ -> workerInternalError c connId "NSASmpKey - no active token"
-          NSASmpDelete -> do
-            rq_ <- withStore' c $ \db -> do
-              setRcvQueueNtfCreds db connId Nothing
-              getPrimaryRcvQueue db connId
-            mapM_ (disableQueueNotifications c) rq_
-            withStore' c $ \db -> deleteNtfSubscription db connId
-
-rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
-rescheduleAction doWork ts actionTs
-  | actionTs <= ts = pure False
-  | otherwise = do
-    void . atomically $ tryTakeTMVar doWork
-    void . forkIO $ do
-      threadDelay $ diffInMicros actionTs ts
-      void . atomically $ tryPutTMVar doWork ()
-    pure True
-
-fromPico :: Pico -> Integer
-fromPico (MkFixed i) = i
-
-diffInMicros :: UTCTime -> UTCTime -> Int
-diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
-
-retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
-retryOnError c name loop done e = do
-  logError $ name <> " error: " <> tshow e
-  case e of
-    BROKER NETWORK -> retryLoop
-    BROKER TIMEOUT -> retryLoop
-    _ -> done e
-  where
-    retryLoop = do
-      atomically $ endAgentOperation c AONtfNetwork
-      atomically $ throwWhenInactive c
-      atomically $ beginAgentOperation c AONtfNetwork
-      loop
-
-workerInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
-workerInternalError c connId internalErrStr = do
-  withStore' c $ \db -> setNullNtfSubscriptionAction db connId
-  notifyInternalError c connId internalErrStr
-
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
-
-getNtfToken :: AgentMonad m => m (Maybe NtfToken)
-getNtfToken = do
-  tkn <- asks $ ntfTkn . ntfSupervisor
-  readTVarIO tkn
-
-nsUpdateToken :: NtfSupervisor -> NtfToken -> STM ()
-nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
-
-nsRemoveNtfToken :: NtfSupervisor -> STM ()
-nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
-
-sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
-sendNtfSubCommand ns cmd = do
-  tkn <- readTVar (ntfTkn ns)
-  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
-
-instantNotifications :: Maybe NtfToken -> Bool
-instantNotifications = \case
-  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
-  _ -> False
-
-closeNtfSupervisor :: NtfSupervisor -> IO ()
-closeNtfSupervisor ns = do
-  cancelNtfWorkers_ $ ntfWorkers ns
-  cancelNtfWorkers_ $ ntfSMPWorkers ns
-
-cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
-cancelNtfWorkers_ wsVar = do
-  ws <- atomically $ stateTVar wsVar (,M.empty)
-  mapM_ (uninterruptibleCancel . snd) ws
-
-getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
-getNtfServer c = do
-  ntfServers <- readTVarIO $ ntfServers c
-  case ntfServers of
-    [] -> pure Nothing
-    [srv] -> pure $ Just srv
-    servers -> do
-      gen <- asks randomServer
-      atomically . stateTVar gen $
-        first (Just . (servers !!)) . randomR (0, length servers - 1)

src/Simplex/Messaging/Agent/QueryString.hs

@@ -24,16 +24,7 @@ instance StrEncoding QueryStringParams where
   strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
 
 queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a
-queryParam name q =
-  case queryParamStr name q of
-    Just p -> either fail pure $ parseAll strP p
+queryParam name (QSP _ q) =
+  case find ((== name) . fst) q of
+    Just (_, p) -> either fail pure $ parseAll strP p
     _ -> fail $ "no qs param " <> B.unpack name
-
-queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
-queryParam_ name q =
-  case queryParamStr name q of
-    Just p -> either fail pure $ parseAll strP p
-    _ -> pure Nothing
-
-queryParamStr :: ByteString -> QueryStringParams -> Maybe ByteString
-queryParamStr name (QSP _ q) = snd <$> find ((== name) . fst) q

src/Simplex/Messaging/Agent/Server.hs

@@ -19,7 +19,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Text.Encoding (decodeUtf8)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Env.Postgres
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
@@ -31,17 +31,17 @@ import UnliftIO.STM
 -- | Runs an SMP agent as a TCP service using passed configuration.
 --
 -- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
-runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgent t cfg initServers = do
+runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
+runSMPAgent t cfg = do
   started <- newEmptyTMVarIO
-  runSMPAgentBlocking t started cfg initServers
+  runSMPAgentBlocking t started cfg
 
 -- | Runs an SMP agent as a TCP service using passed configuration with signalling.
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
-runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
+runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} = do
   runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
   where
     smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
@@ -50,7 +50,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
       runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
-        c <- getAgentClient initServers
+        c <- getAgentClient
         logConnection c True
         race_ (connectClient h c) (runAgentClient c)
           `E.finally` disconnectAgentClient c

src/Simplex/Messaging/Agent/Store.hs

@@ -3,52 +3,83 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Store where
 
+import Control.Concurrent.STM (TVar)
 import Control.Exception (Exception)
-import qualified Data.Attoparsec.ByteString.Char8 as A
+import Crypto.Random (ChaChaDRG)
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Kind (Type)
-import Data.List (find)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as L
 import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
-import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys)
 import Simplex.Messaging.Protocol
   ( MsgBody,
-    MsgFlags,
     MsgId,
-    NotifierId,
-    NtfPrivateSignKey,
-    NtfPublicVerifyKey,
     RcvDhSecret,
-    RcvNtfDhSecret,
     RcvPrivateSignKey,
     SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util ((<$?>))
-import Simplex.Messaging.Version
+
+-- * Store management
+
+-- | Store class type. Defines store access methods for implementations.
+class Monad m => MonadAgentStore s m where
+  -- Queue and Connection management
+  createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
+  createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
+  getConn :: s -> ConnId -> m SomeConn
+  getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn
+  deleteConn :: s -> ConnId -> m ()
+  upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()
+  upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()
+  setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
+  setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
+  setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
+
+  -- Confirmations
+  createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
+  acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
+  getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
+  removeConfirmations :: s -> ConnId -> m ()
+
+  -- Invitations - sent via Contact connections
+  createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
+  getInvitation :: s -> InvitationId -> m Invitation
+  acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()
+  deleteInvitation :: s -> ConnId -> InvitationId -> m ()
+
+  -- Msg management
+  updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
+  updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  createSndMsg :: s -> ConnId -> SndMsgData -> m ()
+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
+  getPendingMsgs :: s -> ConnId -> m [InternalId]
+  checkRcvMsg :: s -> ConnId -> InternalId -> m ()
+  deleteMsg :: s -> ConnId -> InternalId -> m ()
+
+  -- Double ratchet persistence
+  createRatchetX3dhKeys :: s -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
+  getRatchetX3dhKeys :: s -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
+  createRatchet :: s -> ConnId -> RatchetX448 -> m ()
+  getRatchet :: s -> ConnId -> m RatchetX448
+  getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys
+  updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
 
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
 data RcvQueue = RcvQueue
-  { connId :: ConnId,
-    server :: SMPServer,
+  { server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
     -- | key used by the recipient to sign transmissions
@@ -60,100 +91,30 @@ data RcvQueue = RcvQueue
     -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
     e2eDhSecret :: Maybe C.DhSecretX25519,
     -- | sender queue ID
-    sndId :: SMP.SenderId,
+    sndId :: Maybe SMP.SenderId,
     -- | queue status
-    status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
-    dbQueueId :: Int64,
-    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
-    primary :: Bool,
-    -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
-    dbReplaceQueueId :: Maybe Int64,
-    -- | SMP client version
-    smpClientVersion :: Version,
-    -- | credentials used in context of notifications
-    clientNtfCreds :: Maybe ClientNtfCreds
-  }
-  deriving (Eq, Show)
-
-data ClientNtfCreds = ClientNtfCreds
-  { -- | key pair to be used by the notification server to sign transmissions
-    ntfPublicKey :: NtfPublicVerifyKey,
-    ntfPrivateKey :: NtfPrivateSignKey,
-    -- | queue ID to be used by the notification server for NSUB command
-    notifierId :: NotifierId,
-    -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
-    rcvNtfDhSecret :: RcvNtfDhSecret
+    status :: QueueStatus
   }
   deriving (Eq, Show)
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
-  { connId :: ConnId,
-    server :: SMPServer,
+  { server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
-    -- | key pair used by the sender to sign transmissions
-    sndPublicKey :: Maybe C.APublicVerifyKey,
+    -- | key used by the sender to sign transmissions
     sndPrivateKey :: SndPrivateSignKey,
-    -- | DH public key used to negotiate per-queue e2e encryption
-    e2ePubKey :: Maybe C.PublicKeyX25519,
     -- | shared DH secret agreed for simple per-queue e2e encryption
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
-    status :: QueueStatus,
-    -- | database queue ID (within connection), can be Nothing for old queues
-    dbQueueId :: Int64,
-    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
-    primary :: Bool,
-    -- | ID of the queue this one is replacing
-    dbReplaceQueueId :: Maybe Int64,
-    -- | SMP client version
-    smpClientVersion :: Version
+    status :: QueueStatus
   }
   deriving (Eq, Show)
 
-instance SMPQueue RcvQueue where
-  qServer RcvQueue {server} = server
-  {-# INLINE qServer #-}
-  qAddress RcvQueue {server, rcvId} = (server, rcvId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
-
-instance SMPQueue SndQueue where
-  qServer SndQueue {server} = server
-  {-# INLINE qServer #-}
-  qAddress SndQueue {server, sndId} = (server, sndId)
-  {-# INLINE qAddress #-}
-  sameQueue addr q = sameQAddress addr (qAddress q)
-  {-# INLINE sameQueue #-}
-
-findQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe q
-findQ = find . sameQueue
-{-# INLINE findQ #-}
-
-removeQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe (q, [q])
-removeQ = removeQP . sameQueue
-{-# INLINE removeQ #-}
-
-removeQP :: (q -> Bool) -> NonEmpty q -> Maybe (q, [q])
-removeQP p qs = case L.break p qs of
-  (_, []) -> Nothing
-  (qs1, q : qs2) -> Just (q, qs1 <> qs2)
-
-sndAddress :: RcvQueue -> (SMPServer, SMP.SenderId)
-sndAddress RcvQueue {server, sndId} = (server, sndId)
-{-# INLINE sndAddress #-}
-
-findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
-findRQ sAddr = find $ sameQAddress sAddr . sndAddress
-{-# INLINE findRQ #-}
-
 -- * Connection types
 
 -- | Type of a connection.
-data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
+data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 
 -- | Connection of a specific type.
 --
@@ -166,33 +127,22 @@ data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
 data Connection (d :: ConnType) where
-  NewConnection :: ConnData -> Connection CNew
   RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
   SndConnection :: ConnData -> SndQueue -> Connection CSnd
-  DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
+  DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
   ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
 deriving instance Eq (Connection d)
 
 deriving instance Show (Connection d)
 
-connData :: Connection d -> ConnData
-connData = \case
-  NewConnection cData -> cData
-  RcvConnection cData _ -> cData
-  SndConnection cData _ -> cData
-  DuplexConnection cData _ _ -> cData
-  ContactConnection cData _ -> cData
-
 data SConnType :: ConnType -> Type where
-  SCNew :: SConnType CNew
   SCRcv :: SConnType CRcv
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
   SCContact :: SConnType CContact
 
 connType :: SConnType c -> ConnType
-connType SCNew = CNew
 connType SCRcv = CRcv
 connType SCSnd = CSnd
 connType SCDuplex = CDuplex
@@ -220,127 +170,9 @@ instance Eq SomeConn where
 
 deriving instance Show SomeConn
 
-data ConnData = ConnData
-  { connId :: ConnId,
-    connAgentVersion :: Version,
-    enableNtfs :: Bool,
-    duplexHandshake :: Maybe Bool, -- added in agent protocol v2
-    deleted :: Bool
-  }
+newtype ConnData = ConnData {connId :: ConnId}
   deriving (Eq, Show)
 
-data AgentCmdType = ACClient | ACInternal
-
-instance StrEncoding AgentCmdType where
-  strEncode = \case
-    ACClient -> "CLIENT"
-    ACInternal -> "INTERNAL"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "CLIENT" -> pure ACClient
-      "INTERNAL" -> pure ACInternal
-      _ -> fail "bad AgentCmdType"
-
-data AgentCommand
-  = AClientCommand (ACommand 'Client)
-  | AInternalCommand InternalCommand
-
-instance StrEncoding AgentCommand where
-  strEncode = \case
-    AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
-    AInternalCommand cmd -> strEncode (ACInternal, cmd)
-  strP =
-    strP_ >>= \case
-      ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
-      ACInternal -> AInternalCommand <$> strP
-
-data AgentCommandTag
-  = AClientCommandTag (ACommandTag 'Client)
-  | AInternalCommandTag InternalCommandTag
-  deriving (Show)
-
-instance StrEncoding AgentCommandTag where
-  strEncode = \case
-    AClientCommandTag t -> strEncode (ACClient, t)
-    AInternalCommandTag t -> strEncode (ACInternal, t)
-  strP =
-    strP_ >>= \case
-      ACClient -> AClientCommandTag <$> strP
-      ACInternal -> AInternalCommandTag <$> strP
-
-data InternalCommand
-  = ICAck SMP.RecipientId MsgId
-  | ICAckDel SMP.RecipientId MsgId InternalId
-  | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICDeleteConn
-  | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICQDelete SMP.RecipientId
-
-data InternalCommandTag
-  = ICAck_
-  | ICAckDel_
-  | ICAllowSecure_
-  | ICDuplexSecure_
-  | ICDeleteConn_
-  | ICQSecure_
-  | ICQDelete_
-  deriving (Show)
-
-instance StrEncoding InternalCommand where
-  strEncode = \case
-    ICAck rId srvMsgId -> strEncode (ICAck_, rId, srvMsgId)
-    ICAckDel rId srvMsgId mId -> strEncode (ICAckDel_, rId, srvMsgId, mId)
-    ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
-    ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
-    ICDeleteConn -> strEncode ICDeleteConn_
-    ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
-    ICQDelete rId -> strEncode (ICQDelete_, rId)
-  strP =
-    strP >>= \case
-      ICAck_ -> ICAck <$> _strP <*> _strP
-      ICAckDel_ -> ICAckDel <$> _strP <*> _strP <*> _strP
-      ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
-      ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
-      ICDeleteConn_ -> pure ICDeleteConn
-      ICQSecure_ -> ICQSecure <$> _strP <*> _strP
-      ICQDelete_ -> ICQDelete <$> _strP
-
-instance StrEncoding InternalCommandTag where
-  strEncode = \case
-    ICAck_ -> "ACK"
-    ICAckDel_ -> "ACK_DEL"
-    ICAllowSecure_ -> "ALLOW_SECURE"
-    ICDuplexSecure_ -> "DUPLEX_SECURE"
-    ICDeleteConn_ -> "DELETE_CONN"
-    ICQSecure_ -> "QSECURE"
-    ICQDelete_ -> "QDELETE"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "ACK" -> pure ICAck_
-      "ACK_DEL" -> pure ICAckDel_
-      "ALLOW_SECURE" -> pure ICAllowSecure_
-      "DUPLEX_SECURE" -> pure ICDuplexSecure_
-      "DELETE_CONN" -> pure ICDeleteConn_
-      "QSECURE" -> pure ICQSecure_
-      "QDELETE" -> pure ICQDelete_
-      _ -> fail "bad InternalCommandTag"
-
-agentCommandTag :: AgentCommand -> AgentCommandTag
-agentCommandTag = \case
-  AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
-  AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
-
-internalCmdTag :: InternalCommand -> InternalCommandTag
-internalCmdTag = \case
-  ICAck {} -> ICAck_
-  ICAckDel {} -> ICAckDel_
-  ICAllowSecure {} -> ICAllowSecure_
-  ICDuplexSecure {} -> ICDuplexSecure_
-  ICDeleteConn -> ICDeleteConn_
-  ICQSecure {} -> ICQSecure_
-  ICQDelete _ -> ICQDelete_
-
 -- * Confirmation types
 
 data NewConfirmation = NewConfirmation
@@ -385,42 +217,30 @@ type PrevRcvMsgHash = MsgHash
 -- | Corresponds to `last_snd_msg_hash` in `connections` table
 type PrevSndMsgHash = MsgHash
 
--- * Message data containers
+-- * Message data containers - used on Msg creation to reduce number of parameters
 
 data RcvMsgData = RcvMsgData
   { msgMeta :: MsgMeta,
-    msgType :: AgentMessageType,
-    msgFlags :: MsgFlags,
+    msgType :: AMsgType,
     msgBody :: MsgBody,
     internalRcvId :: InternalRcvId,
     internalHash :: MsgHash,
     externalPrevSndHash :: MsgHash
   }
 
-data RcvMsg = RcvMsg
-  { internalId :: InternalId,
-    msgMeta :: MsgMeta,
-    msgBody :: MsgBody,
-    userAck :: Bool
-  }
-
 data SndMsgData = SndMsgData
   { internalId :: InternalId,
     internalSndId :: InternalSndId,
     internalTs :: InternalTs,
-    msgType :: AgentMessageType,
-    msgFlags :: MsgFlags,
+    msgType :: AMsgType,
     msgBody :: MsgBody,
     internalHash :: MsgHash,
     prevMsgHash :: MsgHash
   }
 
-data PendingMsgData = PendingMsgData
-  { msgId :: InternalId,
-    msgType :: AgentMessageType,
-    msgFlags :: MsgFlags,
-    msgBody :: MsgBody,
-    internalTs :: InternalTs
+data PendingMsg = PendingMsg
+  { connId :: ConnId,
+    msgId :: InternalId
   }
   deriving (Show)
 
@@ -455,14 +275,8 @@ data MsgBase = MsgBase
 
 newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show)
 
-instance StrEncoding InternalId where
-  strEncode = strEncode . unId
-  strP = InternalId <$> strP
-
 type InternalTs = UTCTime
 
-type AsyncCmdId = Int64
-
 -- * Store errors
 
 -- | Agent store error.
@@ -484,8 +298,6 @@ data StoreError
     SEInvitationNotFound
   | -- | Message not found
     SEMsgNotFound
-  | -- | Command not found
-    SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
     -- as we always know what it should be at any stage of the protocol,
     -- and in case it does not match use this error.
@@ -496,6 +308,4 @@ data StoreError
     SEX3dhKeysNotFound
   | -- | Used in `getMsg` that is not implemented/used. TODO remove.
     SENotImplemented
-  | -- | Used to wrap agent errors inside store operations to avoid race conditions
-    SEAgentError AgentErrorType
   deriving (Eq, Show, Exception)

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

@@ -0,0 +1,957 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Simplex.Messaging.Agent.Store.Postgres
+  ( PostgresStore (..),
+    createPostgresStore,
+    connectPostgresStore,
+    withConnection,
+    withTransaction,
+    fromTextField_,
+    firstRow,
+  )
+where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Control.Monad (void)
+import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Crypto.Random (ChaChaDRG, randomBytesGenerate)
+import Data.Bifunctor (second)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
+import Data.Char (toLower)
+import Data.Functor (($>))
+import Data.List (find, foldl')
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Database.PostgreSQL.Simple (FromRow, Only (..), Query, SqlError, ToRow, withSavepoint)
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.Errors (constraintViolation)
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.Internal (Conversion (..), Field (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import qualified Database.PostgreSQL.Simple.TypeInfo
+import Database.PostgreSQL.Simple.TypeInfo.Static (bytea, text)
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static
+import GHC.Word (Word32)
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.Postgres.Migrations (Migration)
+import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (blobFieldParser, parseAll)
+import Simplex.Messaging.Protocol (MsgBody)
+import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util (bshow, liftIOEither)
+import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
+import System.Exit (exitFailure)
+import System.FilePath (takeDirectory)
+import System.IO (hFlush, stdout)
+import qualified UnliftIO.Exception as E
+import Network.Socket (HostName, ServiceName)
+import Simplex.Messaging.Crypto (KeyHash)
+
+-- * Postgres Store implementation
+
+data PostgresStore = PostgresStore
+  { dbConnInfo :: DB.ConnectInfo,
+    dbConnPool :: TBQueue DB.Connection,
+    dbNew :: Bool
+  }
+
+createPostgresStore :: DB.ConnectInfo -> Int -> [Migration] -> IO PostgresStore
+createPostgresStore dbConnInfo poolSize migrations = do
+  st <- connectPostgresStore dbConnInfo poolSize
+  migrateSchema st migrations
+  pure st
+
+migrateSchema :: PostgresStore -> [Migration] -> IO ()
+migrateSchema st migrations = withConnection st $ \db -> do
+  Migrations.initialize db
+  Migrations.get db migrations >>= \case
+    Left e -> confirmOrExit $ "Database error: " <> e
+    Right [] -> pure ()
+    Right ms -> do
+      unless (dbNew st) $ do
+        confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
+      -- TODO backup
+      -- let f = dbFilePath st
+      -- copyFile f (f <> ".bak")
+      Migrations.run db ms
+
+confirmOrExit :: String -> IO ()
+confirmOrExit s = do
+  putStrLn s
+  putStr "Continue (y/N): "
+  hFlush stdout
+  ok <- getLine
+  when (map toLower ok /= "y") exitFailure
+
+connectPostgresStore :: DB.ConnectInfo -> Int -> IO PostgresStore
+connectPostgresStore dbConnInfo poolSize = do
+  let dbNew = True -- TODO scan migrations
+  dbConnPool <- newTBQueueIO $ toEnum poolSize
+  replicateM_ poolSize $
+    connectDB dbConnInfo >>= atomically . writeTBQueue dbConnPool
+  pure PostgresStore {dbConnInfo, dbConnPool, dbNew}
+
+connectDB :: DB.ConnectInfo -> IO DB.Connection
+connectDB = DB.connect
+
+checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
+checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
+
+handleSQLError :: StoreError -> SqlError -> StoreError
+handleSQLError err e = case constraintViolation e of
+  Just _ -> err
+  Nothing -> SEInternal $ bshow e
+
+withConnection :: PostgresStore -> (DB.Connection -> IO a) -> IO a
+withConnection PostgresStore {dbConnPool} =
+  bracket
+    (atomically $ readTBQueue dbConnPool)
+    (atomically . writeTBQueue dbConnPool)
+
+execute :: ToRow q => DB.Connection -> Query -> q -> IO ()
+execute db query q = void $ DB.execute db query q
+
+-- TODO not sure this logic is needed with Postgres, also no such error
+-- withTransaction :: forall a. PostgresStore -> (DB.Connection -> IO a) -> IO a
+-- withTransaction st action = withConnection st $ loop 100 100_000
+--   where
+--     loop :: Int -> Int -> DB.Connection -> IO a
+--     loop t tLim db =
+--       DB.withTransaction db (action db) `E.catch` \(e :: SQLError) ->
+--         if tLim > t && DB.sqlError e == DB.ErrorBusy
+--           then do
+--             threadDelay t
+--             loop (t * 9 `div` 8) (tLim - t) db
+--           else E.throwIO e
+
+withTransaction :: forall a. PostgresStore -> (DB.Connection -> IO a) -> IO a
+withTransaction st action = withConnection st inTransaction
+  where
+    inTransaction :: DB.Connection -> IO a
+    inTransaction db = DB.withTransaction db (action db)
+
+createConn_ ::
+  (MonadUnliftIO m, MonadError StoreError m) =>
+  PostgresStore ->
+  TVar ChaChaDRG ->
+  ConnData ->
+  (DB.Connection -> ByteString -> IO ()) ->
+  m ByteString
+createConn_ st gVar cData create = do
+  connId <- liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->
+    case cData of
+      ConnData {connId = ""} -> createWithRandomId gVar $ create db
+      ConnData {connId} -> create db connId $> Right connId
+  liftIO $ print "before: getConn_ db connId"
+  conn <- liftIO $ withTransaction st $ \db -> getConn_ db connId
+  liftIO $ print conn
+  pure connId
+
+instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore PostgresStore m where
+  createRcvConn :: PostgresStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
+  createRcvConn st gVar cData q@RcvQueue {server} cMode =
+    createConn_ st gVar cData $ \db connId -> do
+      upsertServer_ db server
+      execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, cMode)
+      insertRcvQueue_ db connId q
+
+  createSndConn :: PostgresStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
+  createSndConn st gVar cData q@SndQueue {server} =
+    createConn_ st gVar cData $ \db connId -> do
+      upsertServer_ db server
+      execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, SCMInvitation)
+      insertSndQueue_ db connId q
+
+  getConn :: PostgresStore -> ConnId -> m SomeConn
+  getConn st connId =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId
+
+  getRcvConn :: PostgresStore -> SMPServer -> SMP.RecipientId -> m SomeConn
+  getRcvConn st SMPServer {host, port} rcvId =
+    liftIOEither . withTransaction st $ \db ->
+      DB.query
+        db
+        [sql|
+          SELECT q.conn_id
+          FROM rcv_queues q
+          WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?;
+        |]
+        (host, port, rcvId)
+        >>= \case
+          [Only connId] -> getConn_ db connId
+          _ -> pure $ Left SEConnNotFound
+
+  deleteConn :: PostgresStore -> ConnId -> m ()
+  deleteConn st connId =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        "DELETE FROM connections WHERE conn_id = ?;"
+        (Only connId)
+
+  upgradeRcvConnToDuplex :: PostgresStore -> ConnId -> SndQueue -> m ()
+  upgradeRcvConnToDuplex st connId sq@SndQueue {server} =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId >>= \case
+        Right (SomeConn _ RcvConnection {}) -> do
+          upsertServer_ db server
+          insertSndQueue_ db connId sq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
+
+  upgradeSndConnToDuplex :: PostgresStore -> ConnId -> RcvQueue -> m ()
+  upgradeSndConnToDuplex st connId rq@RcvQueue {server} =
+    liftIOEither . withTransaction st $ \db ->
+      getConn_ db connId >>= \case
+        Right (SomeConn _ SndConnection {}) -> do
+          upsertServer_ db server
+          insertRcvQueue_ db connId rq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
+
+  setRcvQueueStatus :: PostgresStore -> RcvQueue -> QueueStatus -> m ()
+  setRcvQueueStatus st RcvQueue {rcvId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue does not exist?
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET status = ?
+          WHERE host = ? AND port = ? AND rcv_id = ?;
+        |]
+        (status, host, port, rcvId)
+
+  setRcvQueueConfirmedE2E :: PostgresStore -> RcvQueue -> C.DhSecretX25519 -> m ()
+  setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eDhSecret =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE rcv_queues
+          SET e2e_dh_secret = ?,
+              status = ?
+          WHERE host = ? AND port = ? AND rcv_id = ?
+        |]
+        (Confirmed, e2eDhSecret, host, port, rcvId)
+
+  setSndQueueStatus :: PostgresStore -> SndQueue -> QueueStatus -> m ()
+  setSndQueueStatus st SndQueue {sndId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue does not exist?
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          UPDATE snd_queues
+          SET status = ?
+          WHERE host = ? AND port = ? AND snd_id = ?;
+        |]
+        (status, host, port, sndId)
+
+  createConfirmation :: PostgresStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
+  createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}, ratchetState} =
+    liftIOEither . withTransaction st $ \db ->
+      createWithRandomId gVar $ \confirmationId ->
+        execute
+          db
+          [sql|
+            INSERT INTO conn_confirmations
+            (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, ?, 0);
+          |]
+          (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo)
+
+  acceptConfirmation :: PostgresStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
+  acceptConfirmation st confirmationId ownConnInfo =
+    liftIOEither . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          UPDATE conn_confirmations
+          SET accepted = 1,
+              own_conn_info = ?
+          WHERE confirmation_id = ?;
+        |]
+        (ownConnInfo, confirmationId)
+      firstRow confirmation SEConfirmationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info
+            FROM conn_confirmations
+            WHERE confirmation_id = ?;
+          |]
+          (Only confirmationId)
+    where
+      confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo) =
+        AcceptedConfirmation
+          { confirmationId,
+            connId,
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            ratchetState,
+            ownConnInfo
+          }
+
+  getAcceptedConfirmation :: PostgresStore -> ConnId -> m AcceptedConfirmation
+  getAcceptedConfirmation st connId =
+    liftIOEither . withTransaction st $ \db ->
+      firstRow confirmation SEConfirmationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, own_conn_info
+            FROM conn_confirmations
+            WHERE conn_id = ? AND accepted = 1;
+          |]
+          (Only connId)
+    where
+      confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, ownConnInfo) =
+        AcceptedConfirmation
+          { confirmationId,
+            connId,
+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
+            ratchetState,
+            ownConnInfo
+          }
+
+  removeConfirmations :: PostgresStore -> ConnId -> m ()
+  removeConfirmations st connId =
+    liftIO . withTransaction st $ \db ->
+      execute
+        db
+        [sql|
+          DELETE FROM conn_confirmations
+          WHERE conn_id = ?;
+        |]
+        (Only connId)
+
+  createInvitation :: PostgresStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
+  createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =
+    liftIOEither . withTransaction st $ \db ->
+      createWithRandomId gVar $ \invitationId ->
+        execute
+          db
+          [sql|
+            INSERT INTO conn_invitations
+            (invitation_id,  contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
+          |]
+          (invitationId, contactConnId, connReq, recipientConnInfo)
+
+  getInvitation :: PostgresStore -> InvitationId -> m Invitation
+  getInvitation st invitationId =
+    liftIOEither . withTransaction st $ \db ->
+      firstRow invitation SEInvitationNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted
+            FROM conn_invitations
+            WHERE invitation_id = ?
+              AND accepted = 0
+          |]
+          (Only invitationId)
+    where
+      invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) =
+        Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}
+
+  acceptInvitation :: PostgresStore -> InvitationId -> ConnInfo -> m ()
+  acceptInvitation st invitationId ownConnInfo =
+    liftIO . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          UPDATE conn_invitations
+          SET accepted = 1,
+              own_conn_info = ?
+          WHERE invitation_id = ?
+        |]
+        (ownConnInfo, invitationId)
+
+  deleteInvitation :: PostgresStore -> ConnId -> InvitationId -> m ()
+  deleteInvitation st contactConnId invId =
+    liftIOEither . withTransaction st $ \db ->
+      runExceptT $
+        ExceptT (getConn_ db contactConnId) >>= \case
+          SomeConn SCContact _ ->
+            liftIO $ execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId)
+          _ -> throwError SEConnNotFound
+
+  updateRcvIds :: PostgresStore -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  updateRcvIds st connId =
+    liftIO . withTransaction st $ \db -> do
+      (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1
+      updateLastIdsRcv_ db connId internalId internalRcvId
+      pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
+
+  createRcvMsg :: PostgresStore -> ConnId -> RcvMsgData -> m ()
+  createRcvMsg st connId rcvMsgData =
+    liftIO . withTransaction st $ \db -> do
+      insertRcvMsgBase_ db connId rcvMsgData
+      insertRcvMsgDetails_ db connId rcvMsgData
+      updateHashRcv_ db connId rcvMsgData
+
+  updateSndIds :: PostgresStore -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  updateSndIds st connId =
+    liftIO . withTransaction st $ \db -> do
+      (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
+      updateLastIdsSnd_ db connId internalId internalSndId
+      pure (internalId, internalSndId, prevSndHash)
+
+  createSndMsg :: PostgresStore -> ConnId -> SndMsgData -> m ()
+  createSndMsg st connId sndMsgData =
+    liftIO . withTransaction st $ \db -> do
+      insertSndMsgBase_ db connId sndMsgData
+      insertSndMsgDetails_ db connId sndMsgData
+      updateHashSnd_ db connId sndMsgData
+
+  getPendingMsgData :: PostgresStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
+  getPendingMsgData st connId msgId =
+    liftIOEither . withTransaction st $ \db -> runExceptT $ do
+      rq_ <- liftIO $ getRcvQueueByConnId_ db connId
+      msgData <-
+        ExceptT . firstRow id SEMsgNotFound $
+          DB.query
+            db
+            [sql|
+                SELECT m.msg_type, m.msg_body, m.internal_ts
+                FROM messages m
+                JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
+                WHERE m.conn_id = ? AND m.internal_id = ?
+              |]
+            (connId, msgId)
+      pure (rq_, msgData)
+
+  getPendingMsgs :: PostgresStore -> ConnId -> m [InternalId]
+  getPendingMsgs st connId =
+    liftIO . withTransaction st $ \db ->
+      map fromOnly
+        <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)
+
+  checkRcvMsg :: PostgresStore -> ConnId -> InternalId -> m ()
+  checkRcvMsg st connId msgId =
+    liftIOEither . withTransaction st $ \db ->
+      hasMsg
+        <$> DB.query
+          db
+          [sql|
+            SELECT conn_id, internal_id
+            FROM rcv_messages
+            WHERE conn_id = ? AND internal_id = ?
+          |]
+          (connId, msgId)
+    where
+      hasMsg :: [(ConnId, InternalId)] -> Either StoreError ()
+      hasMsg r = if null r then Left SEMsgNotFound else Right ()
+
+  deleteMsg :: PostgresStore -> ConnId -> InternalId -> m ()
+  deleteMsg st connId msgId =
+    liftIO . withTransaction st $ \db ->
+      execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
+
+  createRatchetX3dhKeys :: PostgresStore -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
+  createRatchetX3dhKeys st connId x3dhPrivKey1 x3dhPrivKey2 =
+    liftIO . withTransaction st $ \db ->
+      execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
+
+  getRatchetX3dhKeys :: PostgresStore -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
+  getRatchetX3dhKeys st connId =
+    liftIOEither . withTransaction st $ \db ->
+      fmap hasKeys $
+        firstRow id SEX3dhKeysNotFound $
+          DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
+    where
+      hasKeys = \case
+        Right (Just k1, Just k2) -> Right (k1, k2)
+        _ -> Left SEX3dhKeysNotFound
+
+  createRatchet :: PostgresStore -> ConnId -> RatchetX448 -> m ()
+  createRatchet st connId rc =
+    liftIO . withTransaction st $ \db -> do
+      execute
+        db
+        [sql|
+          INSERT INTO ratchets (conn_id, ratchet_state)
+          VALUES (?, ?)
+          ON CONFLICT (conn_id) DO UPDATE SET
+            ratchet_state = ?,
+            x3dh_priv_key_1 = NULL,
+            x3dh_priv_key_2 = NULL
+        |]
+        (connId, rc, rc)
+
+  getRatchet :: PostgresStore -> ConnId -> m RatchetX448
+  getRatchet st connId =
+    liftIOEither . withTransaction st $ \db ->
+      ratchet
+        <$> DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId)
+    where
+      ratchet (Only (Just rc) : _) = Right rc
+      ratchet _ = Left SERatchetNotFound
+
+  getSkippedMsgKeys :: PostgresStore -> ConnId -> m SkippedMsgKeys
+  getSkippedMsgKeys st connId =
+    liftIO . withTransaction st $ \db ->
+      skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)
+    where
+      skipped ms = foldl' addSkippedKey M.empty ms
+      addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
+        where
+          addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk)
+
+  updateRatchet :: PostgresStore -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
+  updateRatchet st connId rc skipped =
+    liftIO . withTransaction st $ \db -> do
+      execute db "UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?" (rc, connId)
+      case skipped of
+        SMDNoChange -> pure ()
+        SMDRemove hk msgN ->
+          execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND header_key = ? AND msg_n = ?" (connId, hk, msgN)
+        SMDAdd smks ->
+          forM_ (M.assocs smks) $ \(hk, mks) ->
+            forM_ (M.assocs mks) $ \(msgN, mk) ->
+              execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
+
+-- -- * Auxiliary helpers
+
+instance ToField QueueStatus where toField = toField . serializeQueueStatus
+
+instance FromField QueueStatus where fromField = fromTextField_ queueStatusT
+
+instance ToField InternalRcvId where toField (InternalRcvId x) = toField x
+
+instance FromField InternalRcvId where fromField x = fromField x
+
+instance ToField InternalSndId where toField (InternalSndId x) = toField x
+
+instance FromField InternalSndId where fromField x = fromField x
+
+instance ToField InternalId where toField (InternalId x) = toField x
+
+instance FromField InternalId where fromField x = fromField x
+
+instance ToField AMsgType where toField = toField . smpEncode
+
+instance FromField AMsgType where fromField = fromByteStringField $ parseAll smpP
+
+instance ToField MsgIntegrity where toField = toField . strEncode
+
+instance FromField MsgIntegrity where fromField = fromByteStringField $ parseAll strP
+
+instance ToField SMPQueueUri where toField = toField . strEncode
+
+instance FromField SMPQueueUri where fromField = fromByteStringField $ parseAll strP
+
+instance ToField AConnectionRequestUri where toField = toField . strEncode
+
+instance FromField AConnectionRequestUri where fromField = fromByteStringField $ parseAll strP
+
+instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode
+
+instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = fromByteStringField $ parseAll strP
+
+instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode
+
+instance FromField ConnectionMode where fromField = fromTextField_ connModeT
+
+instance ToField (SConnectionMode c) where toField = toField . connMode
+
+instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT
+
+instance FromField Word32 where fromField x = fromField x
+
+fromTextField_ :: E.Typeable a => (Text -> Maybe a) -> Field -> Maybe ByteString -> Conversion a
+fromTextField_ fromText f mdata =
+  if typeOid f /= typoid text
+    then returnError Incompatible f ""
+    else case mdata of
+      Nothing -> returnError UnexpectedNull f ""
+      Just dat ->
+        case fromText ((T.pack . B.unpack) dat) of
+          Just x -> return x
+          _ -> returnError ConversionFailed f (B.unpack dat)
+
+-- TODO same as in Crypto
+fromByteStringField :: E.Typeable a => (ByteString -> Either String a) -> Field -> Maybe ByteString -> Conversion a
+fromByteStringField dec f mdata =
+  if typeOid f /= typoid bytea
+    then returnError Incompatible f ""
+    else case mdata of
+      Nothing -> returnError UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> returnError ConversionFailed f (B.unpack dat)
+
+listToEither :: e -> [a] -> Either e a
+listToEither _ (x : _) = Right x
+listToEither e _ = Left e
+
+firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
+firstRow f e a = second f . listToEither e <$> a
+
+-- {- ORMOLU_DISABLE -}
+-- -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
+-- instance (FromField a, FromField b, FromField c, FromField d, FromField e,
+--           FromField f, FromField g, FromField h, FromField i, FromField j,
+--           FromField k) =>
+--   FromRow (a,b,c,d,e,f,g,h,i,j,k) where
+--   fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
+--                          <*> field <*> field <*> field <*> field <*> field
+--                          <*> field
+
+-- instance (FromField a, FromField b, FromField c, FromField d, FromField e,
+--           FromField f, FromField g, FromField h, FromField i, FromField j,
+--           FromField k, FromField l) =>
+--   FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where
+--   fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
+--                           <*> field <*> field <*> field <*> field <*> field
+--                           <*> field <*> field
+
+-- instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
+--           ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) =>
+--   ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where
+--   toRow (a,b,c,d,e,f,g,h,i,j,k,l) =
+--     [ toField a, toField b, toField c, toField d, toField e, toField f,
+--       toField g, toField h, toField i, toField j, toField k, toField l
+--     ]
+
+-- {- ORMOLU_ENABLE -}
+
+-- * Server upsert helper
+
+upsertServer_ :: DB.Connection -> SMPServer -> IO ()
+upsertServer_ dbConn SMPServer {host, port, keyHash} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO servers (host, port, key_hash) VALUES (?,?,?)
+      ON CONFLICT (host, port) DO UPDATE SET
+        host=excluded.host,
+        port=excluded.port,
+        key_hash=excluded.key_hash;
+    |]
+    (host, port, keyHash)
+
+-- * createRcvConn helpers
+
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
+insertRcvQueue_ dbConn connId RcvQueue {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO rcv_queues
+        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status)
+      VALUES
+        (?,?,?,?,?,?,?,?,?,?);
+    |]
+    (host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
+
+-- * createSndConn helpers
+
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
+insertSndQueue_ dbConn connId SndQueue {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO snd_queues
+        ( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)
+      VALUES
+        (?,?,?,?,?,?,?);
+    |]
+    (host server, port server, DB.Binary sndId, connId, sndPrivateKey, e2eDhSecret, status)
+
+-- * getConn helpers
+
+getConn_ :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
+getConn_ dbConn connId =
+  getConnData_ dbConn connId >>= \case
+    Nothing -> pure $ Left SEConnNotFound
+    Just (connData, cMode) -> do
+      liftIO $ print "before: getRcvQueueByConnId_ dbConn connId"
+      rQ <- getRcvQueueByConnId_ dbConn connId
+      liftIO $ print $ "rQ: " <> show rQ
+      liftIO $ print "before: getSndQueueByConnId_ dbConn connId"
+      sQ <- getSndQueueByConnId_ dbConn connId
+      liftIO $ print $ "sQ: " <> show sQ
+      liftIO $ print "after: getSndQueueByConnId_ dbConn connId"
+      pure $ case (rQ, sQ, cMode) of
+        (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)
+        (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)
+        (Nothing, Just sndQ, CMInvitation) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)
+        (Just rcvQ, Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection connData rcvQ)
+        _ -> Left SEConnNotFound
+
+getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData_ dbConn connId' =
+  connData
+    <$> DB.query dbConn "SELECT conn_id, conn_mode FROM connections WHERE conn_id = ?;" (Only connId')
+  where
+    connData [(connId, cMode)] = Just (ConnData {connId}, cMode)
+    connData _ = Nothing
+
+getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
+getRcvQueueByConnId_ dbConn connId =
+  rcvQueue
+    <$> DB.query
+      dbConn
+      [sql|
+        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
+          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status
+        FROM rcv_queues q
+        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+        WHERE q.conn_id = ?;
+      |]
+      (Only connId)
+  where
+    rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)] =
+      let server = SMPServer host port keyHash
+       in Just RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status}
+    rcvQueue _ = Nothing
+
+getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
+getSndQueueByConnId_ dbConn connId = do
+  -- sndQueue
+  --   <$> DB.query
+  --     dbConn
+  --     -- [sql|
+  --     --   SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
+  --     --   FROM snd_queues q
+  --     --   INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+  --     --   WHERE q.conn_id = ?;
+  --     -- |]
+  --     [sql|
+  --       SELECT s.key_hash, q.host, q.port, q.snd_private_key, q.status
+  --       FROM snd_queues q
+  --       INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+  --       WHERE q.conn_id = ?;
+  --     |]
+  --     (Only connId)
+  print "inside: getSndQueueByConnId_"
+  -- r1 <- (DB.query
+  --     dbConn
+  --     [sql|
+  --       SELECT host, port, key_hash
+  --       FROM servers
+  --       WHERE host = ?
+  --     |]
+  --     (DB.Only ("localhost" :: HostName))) :: (IO [(HostName, ServiceName, KeyHash)])
+  -- putStrLn $ show r1
+  r <- DB.query
+      dbConn
+      [sql|
+        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
+        FROM snd_queues q
+        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+        WHERE q.conn_id = ?;
+      |]
+      -- [sql|
+      --   SELECT q.host, q.port, q.status
+      --   FROM snd_queues q
+      --   INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+      --   WHERE q.conn_id = ?;
+      -- |]
+      (DB.Only connId)
+  print $ "r: " <> show r
+  let q = sndQueue r
+  print $ "q: " <> show q
+  pure q
+  where
+    sndQueue [(keyHash, host, port, DB.Binary sndId, sndPrivateKey, e2eDhSecret, status)] =
+      let server = SMPServer host port keyHash
+       in Just SndQueue {server, sndId, sndPrivateKey, e2eDhSecret, status}
+    sndQueue _ = Nothing
+    -- sndQueue [(host, port, status)] = do
+    --   let server = SMPServer host port "abcd"
+    --    in Just SndQueue {server, sndId="3456", sndPrivateKey=(C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"), e2eDhSecret="MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=", status}
+    -- sndQueue _ = Nothing
+
+-- * updateRcvIds helpers
+
+retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+retrieveLastIdsAndHashRcv_ dbConn connId = do
+  [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <-
+    DB.query
+      dbConn
+      [sql|
+        SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash
+        FROM connections
+        WHERE conn_id = ?;
+      |]
+      (Only connId)
+  return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)
+
+updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO ()
+updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId =
+  execute
+    dbConn
+    [sql|
+      UPDATE connections
+      SET last_internal_msg_id = :last_internal_msg_id,
+          last_internal_rcv_msg_id = :last_internal_rcv_msg_id
+      WHERE conn_id = :conn_id;
+    |]
+    (newInternalId, newInternalRcvId, connId)
+
+-- * createRcvMsg helpers
+
+insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgBody, internalRcvId} = do
+  let MsgMeta {recipient = (internalId, internalTs)} = msgMeta
+  execute
+    dbConn
+    [sql|
+      INSERT INTO messages
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+      VALUES
+        (?,?,?,?,NULL,?,?);
+    |]
+    (connId, internalId, internalTs, internalRcvId, msgType, msgBody)
+
+insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+insertRcvMsgDetails_ dbConn connId RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
+  let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta
+  execute
+    dbConn
+    [sql|
+      INSERT INTO rcv_messages
+        ( conn_id, internal_rcv_id, internal_id, external_snd_id,
+          broker_id, broker_ts,
+          internal_hash, external_prev_snd_hash, integrity)
+      VALUES
+        (?,?,?,?,
+         ?,?,
+         ?,?,?);
+    |]
+    (connId, internalRcvId, fst recipient, sndMsgId, fst broker, snd broker, internalHash, externalPrevSndHash, integrity)
+
+updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
+updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} =
+  execute
+    dbConn
+    -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved
+    [sql|
+      UPDATE connections
+      SET last_external_snd_msg_id = ?,
+          last_rcv_msg_hash = ?
+      WHERE conn_id = ?
+        AND last_internal_rcv_msg_id = ?;
+    |]
+    (sndMsgId (msgMeta :: MsgMeta), internalHash, connId, internalRcvId)
+
+-- * updateSndIds helpers
+
+retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
+retrieveLastIdsAndHashSnd_ dbConn connId = do
+  [(lastInternalId, lastInternalSndId, lastSndHash)] <-
+    DB.query
+      dbConn
+      [sql|
+        SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash
+        FROM connections
+        WHERE conn_id = ?;
+      |]
+      (Only connId)
+  return (lastInternalId, lastInternalSndId, lastSndHash)
+
+updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()
+updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
+  execute
+    dbConn
+    [sql|
+      UPDATE connections
+      SET last_internal_msg_id = ?,
+          last_internal_snd_msg_id = ?
+      WHERE conn_id = ?;
+    |]
+    (newInternalId, newInternalSndId, connId)
+
+-- * createSndMsg helpers
+
+insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+insertSndMsgBase_ dbConn connId SndMsgData {..} = do
+  execute
+    dbConn
+    [sql|
+      INSERT INTO messages
+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)
+      VALUES
+        (?,?,?,NULL,?,?, ?);
+    |]
+    (connId, internalId, internalTs, internalSndId, msgType, msgBody)
+
+insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+insertSndMsgDetails_ dbConn connId SndMsgData {..} =
+  execute
+    dbConn
+    [sql|
+      INSERT INTO snd_messages
+        ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash)
+      VALUES
+        (?,?,?,?,?);
+    |]
+    (connId, internalSndId, internalId, internalHash, prevMsgHash)
+
+updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
+updateHashSnd_ dbConn connId SndMsgData {..} =
+  execute
+    dbConn
+    -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved
+    [sql|
+      UPDATE connections
+      SET last_snd_msg_hash = ?
+      WHERE conn_id = ?
+        AND last_internal_snd_msg_id = ?;
+    |]
+    (internalHash, connId, internalSndId)
+
+-- create record with a random ID
+createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
+createWithRandomId gVar create = tryCreate 3
+  where
+    tryCreate :: Int -> IO (Either StoreError ByteString)
+    tryCreate 0 = pure $ Left SEUniqueID
+    tryCreate n = do
+      id' <- randomId gVar 12
+      E.try (create id') >>= \case
+        Right _ -> pure $ Right id'
+        Left e -> case constraintViolation e of
+          Just _ -> tryCreate (n - 1)
+          Nothing -> pure . Left . SEInternal $ bshow e
+
+randomId :: TVar ChaChaDRG -> Int -> IO ByteString
+randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)

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

@@ -0,0 +1,73 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations
+  ( Migration (..),
+    app,
+    initialize,
+    get,
+    run,
+  )
+where
+
+import Control.Monad (forM_, void)
+import Data.Function (on)
+import Data.List (intercalate, sortBy)
+import Data.Time.Clock (getCurrentTime)
+import Database.PostgreSQL.Simple (Connection, Only (..))
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.Internal (exec)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.Transaction (withTransaction)
+import Database.PostgreSQL.Simple.Types (Query (..))
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial (m20220202_initial)
+
+data Migration = Migration {name :: String, up :: Query}
+  deriving (Show)
+
+schemaMigrations :: [(String, Query)]
+schemaMigrations =
+  [ ("20220101_initial", m20220202_initial)
+  ]
+
+-- | The list of migrations in ascending order by date
+app :: [Migration]
+app = sortBy (compare `on` name) $ map migration schemaMigrations
+  where
+    migration (name, query) = Migration {name, up = query}
+
+get :: Connection -> [Migration] -> IO (Either String [Migration])
+get conn migrations =
+  migrationsToRun migrations . map fromOnly
+    <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
+
+run :: Connection -> [Migration] -> IO ()
+run conn ms = withTransaction conn . forM_ ms $
+  \Migration {name, up} -> insert name >> exec conn (fromQuery up)
+  where
+    insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
+
+initialize :: Connection -> IO ()
+initialize conn =
+  void $
+    DB.execute_
+      conn
+      [sql|
+    CREATE TABLE IF NOT EXISTS migrations (
+      name TEXT NOT NULL,
+      ts TEXT NOT NULL,
+      PRIMARY KEY (name)
+    );
+  |]
+
+migrationsToRun :: [Migration] -> [String] -> Either String [Migration]
+migrationsToRun appMs [] = Right appMs
+migrationsToRun [] dbMs = Left $ "database version is newer than the app: " <> intercalate ", " dbMs
+migrationsToRun (a : as) (d : ds)
+  | name a == d = migrationsToRun as ds
+  | otherwise = Left $ "different migration in the app/database: " <> name a <> " / " <> d

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

@@ -0,0 +1,158 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20220202_initial where
+
+import Database.PostgreSQL.Simple (Query)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+
+m20220202_initial :: Query
+m20220202_initial =
+  [sql|
+-- for easy testing
+DROP SCHEMA public CASCADE;
+CREATE SCHEMA public;
+
+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 INTEGER NOT NULL DEFAULT 0,
+  last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,
+  last_rcv_msg_hash BYTEA NOT NULL DEFAULT '',
+  last_snd_msg_hash BYTEA NOT NULL DEFAULT '',
+  smp_agent_version INTEGER NOT NULL DEFAULT 1
+);
+
+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,
+  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,
+  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 INTEGER NOT NULL,
+  internal_ts TIMESTAMP NOT NULL,
+  internal_rcv_id INTEGER,
+  internal_snd_id INTEGER,
+  msg_type BYTEA NOT NULL, -- (H)ELLO, (R)EPLY, (D)ELETE. Should SMP confirmation be saved too?
+  msg_body BYTEA NOT NULL DEFAULT '',
+  PRIMARY KEY (conn_id, internal_id)
+);
+
+CREATE TABLE rcv_messages (
+  conn_id BYTEA NOT NULL,
+  internal_rcv_id INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  external_snd_id INTEGER NOT NULL,
+  broker_id BYTEA NOT NULL,
+  broker_ts TIMESTAMP NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  external_prev_snd_hash BYTEA NOT NULL,
+  integrity BYTEA NOT NULL, -- in the list of keywords
+  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 INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  internal_hash BYTEA NOT NULL,
+  previous_msg_hash BYTEA NOT NULL DEFAULT '',
+  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, -- TODO per-queue key. Split?
+  sender_key BYTEA NOT NULL, -- TODO per-queue key. Split?
+  ratchet_state BYTEA NOT NULL,
+  sender_conn_info BYTEA NOT NULL,
+  accepted INTEGER NOT NULL,
+  own_conn_info BYTEA,
+  created_at TIMESTAMP NOT NULL DEFAULT (now())
+);
+
+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 INTEGER NOT NULL DEFAULT 0,
+  own_conn_info BYTEA,
+  created_at TIMESTAMP NOT NULL DEFAULT (now())
+);
+
+CREATE TABLE ratchets (
+  conn_id BYTEA NOT NULL PRIMARY KEY REFERENCES connections
+    ON DELETE CASCADE,
+  -- x3dh keys are not saved on the sending side (the side accepting the connection)
+  x3dh_priv_key_1 BYTEA,
+  x3dh_priv_key_2 BYTEA,
+  -- ratchet is initially empty on the receiving side (the side offering the connection)
+  ratchet_state BYTEA,
+  e2e_version INTEGER NOT NULL DEFAULT 1
+);
+
+CREATE TABLE skipped_messages (
+  skipped_message_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  conn_id BYTEA NOT NULL REFERENCES ratchets
+    ON DELETE CASCADE,
+  header_key BYTEA NOT NULL,
+  msg_n INTEGER NOT NULL,
+  msg_key BYTEA NOT NULL
+);
+|]

src/Simplex/Messaging/Agent/Store/Postgres/README.md

@@ -0,0 +1,9 @@
+# Postgres setup
+
+Create three databases - `agent_poc_1`, `agent_poc_2`, `agent_poc_3` - and have Postgres server running.
+
+~~`brew install postgresql` - required by postgresql-simple.~~
+
+~~You may run into compilation errors, then you might also need to `brew install libpq --build-from-source`, see [this Stack Overflow answer](https://stackoverflow.com/a/70012033).~~
+
+In the end I managed to build using cabal.

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

@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -16,49 +15,28 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
   )
 where
 
-import Control.Monad (forM_, when)
-import Data.List (intercalate, sortOn)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map as M
+import Control.Monad (forM_)
+import Data.Function (on)
+import Data.List (intercalate, sortBy)
 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.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
-import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
-import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Transport.Client (TransportHost)
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
 
 schemaMigrations :: [(String, Query)]
 schemaMigrations =
-  [ ("20220101_initial", m20220101_initial),
-    ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
-    ("20220322_notifications", m20220322_notifications),
-    ("20220607_v2", m20220608_v2),
-    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
-    ("m20220811_onion_hosts", m20220811_onion_hosts),
-    ("m20220817_connection_ntfs", m20220817_connection_ntfs),
-    ("m20220905_commands", m20220905_commands),
-    ("m20220915_connection_queues", m20220915_connection_queues)
+  [ ("20220101_initial", m20220101_initial)
   ]
 
 -- | The list of migrations in ascending order by date
 app :: [Migration]
-app = sortOn name $ map migration schemaMigrations
+app = sortBy (compare `on` name) $ map migration schemaMigrations
   where
     migration (name, query) = Migration {name = name, up = fromQuery query}
 
@@ -68,16 +46,11 @@ get conn migrations =
     <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
 
 run :: Connection -> [Migration] -> IO ()
-run conn ms = forM_ ms $ \Migration {name, up} -> do
-  when (name == "m20220811_onion_hosts") updateServers
-  DB.withImmediateTransaction conn $ insert name >> execSQL up
+run conn ms = DB.withImmediateTransaction conn . forM_ ms $
+  \Migration {name, up} -> insert name >> execSQL up
   where
     insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
     execSQL = SQLite3.exec $ DB.connectionHandle conn
-    updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
-      DB.withImmediateTransaction conn $
-        let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
-         in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
 
 initialize :: Connection -> IO ()
 initialize conn =

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

@@ -1,13 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220301_snd_queue_keys :: Query
-m20220301_snd_queue_keys =
-  [sql|
-ALTER TABLE snd_queues ADD COLUMN snd_public_key BLOB;
-ALTER TABLE snd_queues ADD COLUMN e2e_pub_key BLOB;
-|]

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

@@ -1,39 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220322_notifications :: Query
-m20220322_notifications =
-  [sql|
-CREATE TABLE ntf_servers (
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  created_at TEXT NOT NULL DEFAULT (datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
-  PRIMARY KEY (ntf_host, ntf_port)
-) WITHOUT ROWID;
-
-CREATE TABLE ntf_tokens (
-  provider TEXT NOT NULL, -- apns
-  device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  tkn_id BLOB, -- token ID assigned by notifications server
-  tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands (used by server, for repeat registraions)
-  tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
-  tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key (for repeat registraions)
-  tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key (for repeat registraions)
-  tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
-  tkn_status TEXT NOT NULL,
-  tkn_action BLOB,
-  created_at TEXT NOT NULL DEFAULT (datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT (datetime('now')), -- this is to check token status periodically to know when it was last checked
-  PRIMARY KEY (provider, device_token, ntf_host, ntf_port),
-  FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
-    ON DELETE RESTRICT ON UPDATE CASCADE
-) WITHOUT ROWID;
-|]

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

@@ -1,50 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220608_v2 :: Query
-m20220608_v2 =
-  [sql|
-ALTER TABLE messages ADD COLUMN msg_flags TEXT NULL;
-
-ALTER TABLE conn_confirmations ADD COLUMN smp_reply_queues BLOB NULL;
-
-ALTER TABLE connections ADD COLUMN duplex_handshake INTEGER NULL DEFAULT 0;
-
-ALTER TABLE rcv_messages ADD COLUMN user_ack INTEGER NULL DEFAULT 0;
-
-ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
-
-ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
-
-ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
-
-ALTER TABLE rcv_queues ADD COLUMN rcv_ntf_dh_secret BLOB;
-
-CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
-
-CREATE TABLE ntf_subscriptions (
-  conn_id BLOB NOT NULL,
-  smp_host TEXT NULL,
-  smp_port TEXT NULL,
-  smp_ntf_id BLOB,
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_sub_id BLOB,
-  ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
-  ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can (should) be not null in same record
-  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
-  updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command (state still should be updated)
-  created_at TEXT NOT NULL DEFAULT (datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
-  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
-) WITHOUT ROWID;
-|]

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

@@ -1,14 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220625_v2_ntf_mode :: Query
-m20220625_v2_ntf_mode =
-  [sql|
-ALTER TABLE ntf_tokens ADD COLUMN ntf_mode TEXT NULL;
-
-DELETE FROM ntf_tokens;
-|]

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

@@ -1,16 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220811_onion_hosts :: Query
-m20220811_onion_hosts =
-  [sql|
-ALTER TABLE conn_confirmations ADD COLUMN smp_client_version INTEGER;
-
-UPDATE ntf_servers
-SET ntf_host = 'ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion'
-WHERE ntf_host = 'ntf2.simplex.im';
-|]

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

@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220817_connection_ntfs :: Query
-m20220817_connection_ntfs =
-  [sql|
-ALTER TABLE connections ADD COLUMN enable_ntfs INTEGER;
-|]

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

@@ -1,23 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220905_commands :: Query
-m20220905_commands =
-  [sql|
-CREATE TABLE commands (
-  command_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  host TEXT,
-  port TEXT,
-  corr_id BLOB NOT NULL,
-  command_tag BLOB NOT NULL,
-  command BLOB NOT NULL,
-  agent_version INTEGER NOT NULL DEFAULT 1,
-  FOREIGN KEY (host, port) REFERENCES servers
-    ON DELETE RESTRICT ON UPDATE CASCADE
-);
-|]

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

@@ -1,52 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues where
-
-import Database.SQLite.Simple (Query)
-import Database.SQLite.Simple.QQ (sql)
-
-m20220915_connection_queues :: Query
-m20220915_connection_queues =
-  [sql|
-PRAGMA ignore_check_constraints=ON;
-
--- rcv_queues
-ALTER TABLE rcv_queues ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
-UPDATE rcv_queues SET rcv_queue_id = 1;
-CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues (conn_id, rcv_queue_id);
-
-ALTER TABLE rcv_queues ADD COLUMN rcv_primary INTEGER CHECK (rcv_primary NOT NULL);
-UPDATE rcv_queues SET rcv_primary = 1;
-
-ALTER TABLE rcv_queues ADD COLUMN replace_rcv_queue_id INTEGER NULL;
-
--- snd_queues
-ALTER TABLE snd_queues ADD COLUMN snd_queue_id INTEGER CHECK (snd_queue_id NOT NULL);
-UPDATE snd_queues SET snd_queue_id = 1;
-CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues (conn_id, snd_queue_id);
-
-ALTER TABLE snd_queues ADD COLUMN snd_primary INTEGER CHECK (snd_primary NOT NULL);
-UPDATE snd_queues SET snd_primary = 1;
-
-ALTER TABLE snd_queues ADD COLUMN replace_snd_queue_id INTEGER NULL;
-
--- connections
-ALTER TABLE connections ADD COLUMN deleted INTEGER DEFAULT 0 CHECK (deleted NOT NULL);
-UPDATE connections SET deleted = 0;
-
--- messages
-CREATE TABLE snd_message_deliveries (
-  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_queue_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  FOREIGN KEY (conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-);
-
-CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries (conn_id, snd_queue_id);
-
-ALTER TABLE rcv_messages ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
-UPDATE rcv_messages SET rcv_queue_id = 1;
-
-PRAGMA ignore_check_constraints=OFF;
-|]

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

@@ -1,230 +0,0 @@
-CREATE TABLE migrations(
-  name TEXT NOT NULL,
-  ts TEXT NOT NULL,
-  PRIMARY KEY(name)
-);
-CREATE TABLE servers(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  key_hash BLOB NOT NULL,
-  PRIMARY KEY(host, port)
-) WITHOUT ROWID;
-CREATE TABLE connections(
-  conn_id BLOB NOT NULL PRIMARY KEY,
-  conn_mode TEXT NOT NULL,
-  last_internal_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,
-  last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',
-  last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
-  smp_agent_version INTEGER NOT NULL DEFAULT 1
-  ,
-  duplex_handshake INTEGER NULL DEFAULT 0,
-  enable_ntfs INTEGER,
-  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
-) WITHOUT ROWID;
-CREATE TABLE rcv_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  rcv_id BLOB NOT NULL,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  rcv_private_key BLOB NOT NULL,
-  rcv_dh_secret BLOB NOT NULL,
-  e2e_priv_key BLOB NOT NULL,
-  e2e_dh_secret BLOB,
-  snd_id BLOB NOT NULL,
-  snd_key BLOB,
-  status TEXT NOT NULL,
-  smp_server_version INTEGER NOT NULL DEFAULT 1,
-  smp_client_version INTEGER,
-  ntf_public_key BLOB,
-  ntf_private_key BLOB,
-  ntf_id BLOB,
-  rcv_ntf_dh_secret BLOB,
-  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
-  rcv_primary INTEGER CHECK(rcv_primary NOT NULL),
-  replace_rcv_queue_id INTEGER NULL,
-  PRIMARY KEY(host, port, rcv_id),
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE,
-  UNIQUE(host, port, snd_id)
-) WITHOUT ROWID;
-CREATE TABLE snd_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  snd_id BLOB NOT NULL,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_private_key BLOB NOT NULL,
-  e2e_dh_secret BLOB 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 BLOB,
-  e2e_pub_key BLOB,
-  snd_queue_id INTEGER CHECK(snd_queue_id NOT NULL),
-  snd_primary INTEGER CHECK(snd_primary NOT NULL),
-  replace_snd_queue_id INTEGER NULL,
-  PRIMARY KEY(host, port, snd_id),
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE
-) WITHOUT ROWID;
-CREATE TABLE messages(
-  conn_id BLOB NOT NULL REFERENCES connections(conn_id)
-  ON DELETE CASCADE,
-  internal_id INTEGER NOT NULL,
-  internal_ts TEXT NOT NULL,
-  internal_rcv_id INTEGER,
-  internal_snd_id INTEGER,
-  msg_type BLOB NOT NULL, --(H)ELLO,(R)EPLY,(D)ELETE. Should SMP confirmation be saved too?
-  msg_body BLOB NOT NULL DEFAULT x'',
-  msg_flags TEXT NULL,
-  PRIMARY KEY(conn_id, internal_id),
-  FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
-  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
-  FOREIGN KEY(conn_id, internal_snd_id) REFERENCES snd_messages
-  ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-) WITHOUT ROWID;
-CREATE TABLE rcv_messages(
-  conn_id BLOB NOT NULL,
-  internal_rcv_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  external_snd_id INTEGER NOT NULL,
-  broker_id BLOB NOT NULL,
-  broker_ts TEXT NOT NULL,
-  internal_hash BLOB NOT NULL,
-  external_prev_snd_hash BLOB NOT NULL,
-  integrity BLOB NOT NULL,
-  user_ack INTEGER NULL DEFAULT 0,
-  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
-  PRIMARY KEY(conn_id, internal_rcv_id),
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
-  ON DELETE CASCADE
-) WITHOUT ROWID;
-CREATE TABLE snd_messages(
-  conn_id BLOB NOT NULL,
-  internal_snd_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  internal_hash BLOB NOT NULL,
-  previous_msg_hash BLOB NOT NULL DEFAULT x'',
-  PRIMARY KEY(conn_id, internal_snd_id),
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages
-  ON DELETE CASCADE
-) WITHOUT ROWID;
-CREATE TABLE conn_confirmations(
-  confirmation_id BLOB NOT NULL PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
-  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
-  ratchet_state BLOB NOT NULL,
-  sender_conn_info BLOB NOT NULL,
-  accepted INTEGER NOT NULL,
-  own_conn_info BLOB,
-  created_at TEXT NOT NULL DEFAULT(datetime('now'))
-  ,
-  smp_reply_queues BLOB NULL,
-  smp_client_version INTEGER
-) WITHOUT ROWID;
-CREATE TABLE conn_invitations(
-  invitation_id BLOB NOT NULL PRIMARY KEY,
-  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  cr_invitation BLOB NOT NULL,
-  recipient_conn_info BLOB NOT NULL,
-  accepted INTEGER NOT NULL DEFAULT 0,
-  own_conn_info BLOB,
-  created_at TEXT NOT NULL DEFAULT(datetime('now'))
-) WITHOUT ROWID;
-CREATE TABLE ratchets(
-  conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections
-  ON DELETE CASCADE,
-  -- x3dh keys are not saved on the sending side(the side accepting the connection)
-  x3dh_priv_key_1 BLOB,
-  x3dh_priv_key_2 BLOB,
-  -- ratchet is initially empty on the receiving side(the side offering the connection)
-  ratchet_state BLOB,
-  e2e_version INTEGER NOT NULL DEFAULT 1
-) WITHOUT ROWID;
-CREATE TABLE skipped_messages(
-  skipped_message_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES ratchets
-  ON DELETE CASCADE,
-  header_key BLOB NOT NULL,
-  msg_n INTEGER NOT NULL,
-  msg_key BLOB NOT NULL
-);
-CREATE TABLE ntf_servers(
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_key_hash BLOB NOT NULL,
-  created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
-  PRIMARY KEY(ntf_host, ntf_port)
-) WITHOUT ROWID;
-CREATE TABLE ntf_tokens(
-  provider TEXT NOT NULL, -- apns
-  device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  tkn_id BLOB, -- token ID assigned by notifications server
-  tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands(used by server, for repeat registraions)
-tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
-tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key(for repeat registraions)
-tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key(for repeat registraions)
-tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
-  tkn_status TEXT NOT NULL,
-  tkn_action BLOB,
-  created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
-  ntf_mode TEXT NULL, -- this is to check token status periodically to know when it was last checked
-  PRIMARY KEY(provider, device_token, ntf_host, ntf_port),
-  FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
-  ON DELETE RESTRICT ON UPDATE CASCADE
-) WITHOUT ROWID;
-CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
-CREATE TABLE ntf_subscriptions(
-  conn_id BLOB NOT NULL,
-  smp_host TEXT NULL,
-  smp_port TEXT NULL,
-  smp_ntf_id BLOB,
-  ntf_host TEXT NOT NULL,
-  ntf_port TEXT NOT NULL,
-  ntf_sub_id BLOB,
-  ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
-  ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
-  ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can(should) be not null in same record
-  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
-  updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
-  created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
-  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
-) WITHOUT ROWID;
-CREATE TABLE commands(
-  command_id INTEGER PRIMARY KEY,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  host TEXT,
-  port TEXT,
-  corr_id BLOB NOT NULL,
-  command_tag BLOB NOT NULL,
-  command BLOB NOT NULL,
-  agent_version INTEGER NOT NULL DEFAULT 1,
-  FOREIGN KEY(host, port) REFERENCES servers
-  ON DELETE RESTRICT ON UPDATE CASCADE
-);
-CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
-CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
-CREATE TABLE snd_message_deliveries(
-  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  snd_queue_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
-);
-CREATE TABLE sqlite_sequence(name,seq);
-CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
-  conn_id,
-  snd_queue_id
-);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,50 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Agent.TRcvQueues where
-
-import Control.Concurrent.STM
-import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import qualified Data.Set as S
-import Simplex.Messaging.Agent.Protocol (ConnId)
-import Simplex.Messaging.Agent.Store (RcvQueue (..))
-import Simplex.Messaging.Protocol (RecipientId, SMPServer)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-
-newtype TRcvQueues = TRcvQueues (TMap (SMPServer, RecipientId) RcvQueue)
-
-empty :: STM TRcvQueues
-empty = TRcvQueues <$> TM.empty
-
-clear :: TRcvQueues -> STM ()
-clear (TRcvQueues qs) = TM.clear qs
-
-deleteConn :: ConnId -> TRcvQueues -> STM ()
-deleteConn cId (TRcvQueues qs) = modifyTVar' qs $ M.filter (\rq -> cId /= connId rq)
-
--- TODO possibly, should be limited to active queues
-hasConn :: ConnId -> TRcvQueues -> STM Bool
-hasConn cId (TRcvQueues qs) = any (\rq -> cId == connId rq) <$> readTVar qs
-
--- TODO possibly, should be limited to active queues
-getConns :: TRcvQueues -> STM (Set ConnId)
-getConns (TRcvQueues qs) = M.foldr' (S.insert . connId) S.empty <$> readTVar qs
-
-addQueue :: RcvQueue -> TRcvQueues -> STM ()
-addQueue rq@RcvQueue {server, rcvId} (TRcvQueues qs) = TM.insert (server, rcvId) rq qs
-
-deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
-deleteQueue RcvQueue {server, rcvId} (TRcvQueues qs) = TM.delete (server, rcvId) qs
-
-getSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
-getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
-  where
-    addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs'
-
-getDelSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
-getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty)
-  where
-    addQ (removed, qs') rq@RcvQueue {server, rcvId}
-      | srv == server = (rq : removed, qs')
-      | otherwise = (removed, M.insert (server, rcvId) rq qs')

src/Simplex/Messaging/Client.hs

@@ -1,13 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,36 +23,27 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    ProtocolClient (thVersion, sessionId, transportHost),
     SMPClient,
-    getProtocolClient,
-    closeProtocolClient,
+    getSMPClient,
+    closeSMPClient,
 
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
-    subscribeSMPQueues,
-    getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
-    disableSMPQueueNotifications,
-    enableSMPQueuesNtfs,
-    disableSMPQueuesNtfs,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
     deleteSMPQueue,
-    sendProtocolCommand,
+    sendSMPCommand,
 
     -- * Supporting types and client configuration
-    ProtocolClientError (..),
-    ProtocolClientConfig (..),
-    NetworkConfig (..),
-    defaultClientConfig,
-    defaultNetworkConfig,
-    chooseTransportHost,
-    ServerTransmission,
+    SMPClientError (..),
+    SMPClientConfig (..),
+    smpDefaultConfig,
+    SMPServerTransmission,
   )
 where
 
@@ -64,183 +52,96 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (rights)
-import Data.Functor (($>))
-import Data.List (find)
-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 (fromMaybe)
-import GHC.Generics (Generic)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
-import Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), runTransportClient)
-import Simplex.Messaging.Transport.KeepAlive
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake)
+import Simplex.Messaging.Transport.Client (runTransportClient)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
-import Simplex.Messaging.Version
 import System.Timeout (timeout)
 
 -- | 'SMPClient' is a handle used to send commands to a specific SMP server.
 --
+-- The only exported selector is blockSize that is negotiated
+-- with the server during the TCP transport handshake.
+--
 -- Use 'getSMPClient' to connect to an SMP server and create a client handle.
-data ProtocolClient msg = ProtocolClient
+data SMPClient = SMPClient
   { action :: Async (),
     connected :: TVar Bool,
-    sessionId :: SessionId,
-    thVersion :: Version,
-    protocolServer :: ProtoServer msg,
-    transportHost :: TransportHost,
+    sessionId :: ByteString,
+    smpServer :: SMPServer,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
-    sentCommands :: TMap CorrId (Request msg),
-    sndQ :: TBQueue (NonEmpty SentRawTransmission),
-    rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
-    msgQ :: Maybe (TBQueue (ServerTransmission msg))
+    sentCommands :: TVar (Map CorrId Request),
+    sndQ :: TBQueue SentRawTransmission,
+    rcvQ :: TBQueue (SignedTransmission BrokerMsg),
+    msgQ :: TBQueue SMPServerTransmission
   }
 
-type SMPClient = ProtocolClient SMP.BrokerMsg
-
--- | Type for client command data
-type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
-
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
+type SMPServerTransmission = (SMPServer, RecipientId, BrokerMsg)
 
-data HostMode
-  = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
-    HMOnionViaSocks
-  | -- | prefer (or require) onion hosts
-    HMOnion
-  | -- | prefer (or require) public hosts
-    HMPublic
-  deriving (Eq, Show, Generic)
-
-instance FromJSON HostMode where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
-
-instance ToJSON HostMode where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
-
--- | network configuration for the client
-data NetworkConfig = NetworkConfig
-  { -- | use SOCKS5 proxy
-    socksProxy :: Maybe SocksProxy,
-    -- | determines critera which host is chosen from the list
-    hostMode :: HostMode,
-    -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
-    requiredHostMode :: Bool,
-    -- | timeout for the initial client TCP/TLS connection (microseconds)
-    tcpConnectTimeout :: Int,
-    -- | timeout of protocol commands (microseconds)
-    tcpTimeout :: Int,
-    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    -- | period for SMP ping commands (microseconds)
-    smpPingInterval :: Int
-  }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON NetworkConfig where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-defaultNetworkConfig :: NetworkConfig
-defaultNetworkConfig =
-  NetworkConfig
-    { socksProxy = Nothing,
-      hostMode = HMOnionViaSocks,
-      requiredHostMode = False,
-      tcpConnectTimeout = 7_500_000,
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPingInterval = 600_000_000 -- 10min
-    }
-
--- | protocol client configuration.
-data ProtocolClientConfig = ProtocolClientConfig
+-- | SMP client configuration.
+data SMPClientConfig = SMPClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
-    -- | default server port if port is not specified in ProtocolServer
+    -- | default SMP server port if port is not specified in SMPServer
     defaultTransport :: (ServiceName, ATransport),
-    -- | network configuration
-    networkConfig :: NetworkConfig,
-    -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    -- | timeout of TCP commands (microseconds)
+    tcpTimeout :: Int,
+    -- | period for SMP ping commands (microseconds)
+    smpPing :: Int
   }
 
--- | Default protocol client configuration.
-defaultClientConfig :: ProtocolClientConfig
-defaultClientConfig =
-  ProtocolClientConfig
-    { qSize = 64,
-      defaultTransport = ("443", transport @TLS),
-      networkConfig = defaultNetworkConfig,
-      smpServerVRange = supportedSMPServerVRange
+-- | Default SMP client configuration.
+smpDefaultConfig :: SMPClientConfig
+smpDefaultConfig =
+  SMPClientConfig
+    { qSize = 16,
+      defaultTransport = ("5223", transport @TLS),
+      tcpTimeout = 4_000_000,
+      smpPing = 30_000_000
     }
 
-data Request msg = Request
+data Request = Request
   { queueId :: QueueId,
-    responseVar :: TMVar (Response msg)
+    responseVar :: TMVar Response
   }
 
-type Response msg = Either ProtocolClientError msg
+type Response = Either SMPClientError BrokerMsg
 
-chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
-chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
-  firstOrError $ case hostMode of
-    HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
-    HMOnion -> onionHost
-    HMPublic -> publicHost
-  where
-    firstOrError
-      | requiredHostMode = maybe (Left PCEIncompatibleHost) Right
-      | otherwise = Right . fromMaybe (L.head hosts)
-    isOnionHost = \case THOnionHost _ -> True; _ -> False
-    onionHost = find isOnionHost hosts
-    publicHost = find (not . isOnionHost) hosts
-
--- | Connects to 'ProtocolServer' using passed client configuration
+-- | Connects to 'SMPServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
-  case chooseTransportHost networkConfig (host protocolServer) of
-    Right useHost ->
-      (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
-        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
-    Left e -> pure $ Left e
+getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
+getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =
+  atomically mkSMPClient >>= runClient useTransport
   where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> STM (ProtocolClient msg)
-    mkProtocolClient transportHost = do
+    mkSMPClient :: STM SMPClient
+    mkSMPClient = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
-      sentCommands <- TM.empty
+      sentCommands <- newTVar M.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        ProtocolClient
+        SMPClient
           { action = undefined,
             sessionId = undefined,
-            thVersion = undefined,
             connected,
-            protocolServer,
-            transportHost,
+            smpServer,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -249,108 +150,101 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
-    runClient (port', ATransport t) useHost c = do
+    runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
+    runClient (port', ATransport t) c = do
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
-            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
-      th_ <- tcpConnectTimeout `timeout` atomically (takeTMVar thVar)
+          runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)
+            `finally` atomically (putTMVar thVar $ Left SMPNetworkError)
+      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of
-        Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
+        Just (Right THandle {sessionId}) -> Right c {action, sessionId}
         Just (Left e) -> Left e
-        Nothing -> Left PCENetworkError
+        Nothing -> Left SMPNetworkError
 
     useTransport :: (ServiceName, ATransport)
-    useTransport = case port protocolServer of
+    useTransport = case port smpServer of
       "" -> defaultTransport cfg
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
+    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()
     client _ c thVar h =
-      runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
-        Right th@THandle {sessionId, thVersion} -> do
+      runExceptT (clientHandshake h $ keyHash smpServer) >>= \case
+        Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
+        Right th@THandle {sessionId} -> do
           atomically $ do
             writeTVar (connected c) True
             putTMVar thVar $ Right th
-          let c' = c {sessionId, thVersion} :: ProtocolClient msg
-          -- TODO remove ping if 0 is passed (or Nothing?)
+          let c' = c {sessionId} :: SMPClient
           raceAny_ [send c' th, process c', receive c' th, ping c']
-            `finally` disconnected c'
+            `finally` disconnected
 
-    send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    send :: Transport c => SMPClient -> THandle c -> IO ()
+    send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-    receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
-    receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
+    receive :: Transport c => SMPClient -> THandle c -> IO ()
+    receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
-    ping :: ProtocolClient msg -> IO ()
+    ping :: SMPClient -> IO ()
     ping c = forever $ do
-      threadDelay smpPingInterval
-      runExceptT $ sendProtocolCommand c Nothing "" protocolPing
+      threadDelay smpPing
+      runExceptT $ sendSMPCommand c Nothing "" PING
 
-    process :: ProtocolClient msg -> IO ()
-    process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
-
-    processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
-    processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
+    process :: SMPClient -> IO ()
+    process SMPClient {rcvQ, sentCommands} = forever $ do
+      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
       if B.null $ bs corrId
-        then sendMsg respOrErr
+        then sendMsg qId respOrErr
         else do
-          atomically (TM.lookup corrId sentCommands) >>= \case
-            Nothing -> sendMsg respOrErr
+          cs <- readTVarIO sentCommands
+          case M.lookup corrId cs of
+            Nothing -> sendMsg qId respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
-              TM.delete corrId sentCommands
+              modifyTVar sentCommands $ M.delete corrId
               putTMVar responseVar $
                 if queueId == qId
                   then case respOrErr of
-                    Left e -> Left $ PCEResponseError e
-                    Right r -> case protocolError r of
-                      Just e -> Left $ PCEProtocolError e
-                      _ -> Right r
-                  else Left . PCEUnexpectedResponse $ bshow respOrErr
-      where
-        sendMsg :: Either ErrorType msg -> IO ()
-        sendMsg = \case
-          Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
-          -- TODO send everything else to errQ and log in agent
-          _ -> return ()
+                    Left e -> Left $ SMPResponseError e
+                    Right (ERR e) -> Left $ SMPServerError e
+                    Right r -> Right r
+                  else Left SMPUnexpectedResponse
 
--- | Disconnects client from the server and terminates client threads.
-closeProtocolClient :: ProtocolClient msg -> IO ()
-closeProtocolClient = uninterruptibleCancel . action
+    sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO ()
+    sendMsg qId = \case
+      Right cmd -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)
+      -- TODO send everything else to errQ and log in agent
+      _ -> return ()
+
+-- | Disconnects SMP client from the server and terminates client threads.
+closeSMPClient :: SMPClient -> IO ()
+closeSMPClient = uninterruptibleCancel . action
 
 -- | SMP client error type.
-data ProtocolClientError
+data SMPClientError
   = -- | Correctly parsed SMP server ERR response.
     -- This error is forwarded to the agent client as `ERR SMP err`.
-    PCEProtocolError ErrorType
+    SMPServerError ErrorType
   | -- | Invalid server response that failed to parse.
     -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
-    PCEResponseError ErrorType
+    SMPResponseError ErrorType
   | -- | Different response from what is expected to a certain SMP command,
     -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
     -- other responses would result in this error.
     -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
-    PCEUnexpectedResponse ByteString
+    SMPUnexpectedResponse
   | -- | Used for TCP connection and command response timeouts.
     -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
-    PCEResponseTimeout
+    SMPResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
-    PCENetworkError
-  | -- | No host compatible with network configuration
-    PCEIncompatibleHost
+    SMPNetworkError
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
-    PCETransportError TransportError
+    SMPTransportError TransportError
   | -- | Error when cryptographically "signing" the command.
-    PCESignatureError C.CryptoError
-  | -- | IO Error
-    PCEIOError IOException
+    SMPSignatureError C.CryptoError
   deriving (Eq, Show, Exception)
 
 -- | Create a new SMP queue.
@@ -361,182 +255,115 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
-  Maybe BasicAuth ->
-  ExceptT ProtocolClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey auth =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
+  ExceptT SMPClientError IO QueueIdsKeys
+createSMPQueue c rpKey rKey dhKey =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
     IDS qik -> pure qik
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
-subscribeSMPQueue c rpKey rId =
+subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
+subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
-    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
--- | Subscribe to multiple SMP queues batching commands if supported.
-subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
-subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
-  where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
-    response ((_, rId), r) = case r of
-      Right OK -> pure $ Right ()
-      Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
-      Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
-      Left e -> pure $ Left e
-
-writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
-writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
-
-serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
-serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
-  (protocolServer, thVersion, sessionId, entityId, message)
-
--- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
---
--- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
-getSMPMessage c rpKey rId =
-  sendSMPCommand c (Just rpKey) rId GET >>= \case
-    OK -> pure Nothing
-    cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    cmd@MSG {} ->
+      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT ProtocolClientError IO ()
+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications = okSMPCommand NSUB
 
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
-secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
+secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
 secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
-enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
-enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
-  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
-    NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
--- | Enable notifications for the multiple queues for push notifications server.
-enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
-enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
-  where
-    cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
-    response = \case
-      Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
-      Right r -> Left . PCEUnexpectedResponse $ bshow r
-      Left e -> Left e
-
--- | Disable notifications for the queue for push notifications server.
---
--- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
-disableSMPQueueNotifications = okSMPCommand NDEL
-
--- | Disable notifications for multiple queues for push notifications server.
-disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
-disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
-  where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
-    response = \case
-      Right OK -> Right ()
-      Right r -> Left . PCEUnexpectedResponse $ bshow r
-      Left e -> Left e
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId
+enableSMPQueueNotifications c rpKey rId notifierKey =
+  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
+    NID nId -> pure nId
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT ProtocolClientError IO ()
-sendSMPMessage c spKey sId flags msg =
-  sendSMPCommand c spKey sId (SEND flags msg) >>= \case
+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
+sendSMPMessage c spKey sId msg =
+  sendSMPCommand c spKey sId (SEND msg) >>= \case
     OK -> pure ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
-ackSMPMessage c rpKey rId msgId =
-  sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
+ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
+  sendSMPCommand c (Just rpKey) rId ACK >>= \case
     OK -> return ()
-    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    cmd@MSG {} ->
+      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Irreversibly suspend SMP queue.
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 suspendSMPQueue = okSMPCommand OFF
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r
+    _ -> throwE SMPUnexpectedResponse
 
 -- | Send SMP command
-sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
-sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
-
--- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
-sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
-  ts <- mapM (runExceptT . mkTransmission c) cs
-  mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
-  forConcurrently ts $ \case
-    Right (_, r) -> withTimeout . atomically $ takeTMVar r
-    Left e -> pure $ Left e
+-- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient)
+sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
+sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
+  corrId <- lift_ getNextCorrId
+  t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
+  ExceptT $ sendRecv corrId t
   where
-    withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
+    lift_ :: STM a -> ExceptT SMPClientError IO a
+    lift_ action = ExceptT $ Right <$> atomically action
 
--- | Send Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
-  (t, r) <- mkTransmission c (pKey, qId, cmd)
-  ExceptT $ sendRecv t r
-  where
-    -- two separate "atomically" needed to avoid blocking
-    sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
-    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
-      where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
-
-mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
-mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands} (pKey, qId, cmd) = do
-  corrId <- liftIO $ atomically getNextCorrId
-  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
-  r <- liftIO . atomically $ mkRequest corrId
-  pure (t, r)
-  where
     getNextCorrId :: STM CorrId
     getNextCorrId = do
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
-    signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
+
+    signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission
     signTransmission t = case pKey of
-      Nothing -> pure (Nothing, t)
+      Nothing -> return (Nothing, t)
       Just pk -> do
-        sig <- liftError PCESignatureError $ C.sign pk t
+        sig <- liftError SMPSignatureError $ C.sign pk t
         return (Just sig, t)
-    mkRequest :: CorrId -> STM (TMVar (Response msg))
-    mkRequest corrId = do
+
+    -- two separate "atomically" needed to avoid blocking
+    sendRecv :: CorrId -> SentRawTransmission -> IO Response
+    sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
+      where
+        withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
+
+    send :: CorrId -> SentRawTransmission -> STM (TMVar Response)
+    send corrId t = do
       r <- newEmptyTMVar
-      TM.insert corrId (Request qId r) sentCommands
-      pure r
+      modifyTVar sentCommands . M.insert corrId $ Request qId r
+      writeTBQueue sndQ t
+      return r

src/Simplex/Messaging/Client/Agent.hs

@@ -1,304 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Simplex.Messaging.Client.Agent where
-
-import Control.Concurrent (forkIO)
-import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Logger.Simple
-import Control.Monad.Except
-import Control.Monad.IO.Unlift
-import Control.Monad.Trans.Except
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import Data.Text.Encoding
-import Numeric.Natural
-import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Client
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
-import System.Timeout (timeout)
-import UnliftIO (async, forConcurrently_)
-import UnliftIO.Exception (Exception)
-import qualified UnliftIO.Exception as E
-import UnliftIO.STM
-
-type SMPClientVar = TMVar (Either ProtocolClientError SMPClient)
-
-data SMPClientAgentEvent
-  = CAConnected SMPServer
-  | CADisconnected SMPServer (Set SMPSub)
-  | CAReconnected SMPServer
-  | CAResubscribed SMPServer SMPSub
-  | CASubError SMPServer SMPSub ProtocolClientError
-
-data SMPSubParty = SPRecipient | SPNotifier
-  deriving (Eq, Ord, Show)
-
-type SMPSub = (SMPSubParty, QueueId)
-
--- type SMPServerSub = (SMPServer, SMPSub)
-
-data SMPClientAgentConfig = SMPClientAgentConfig
-  { smpCfg :: ProtocolClientConfig,
-    reconnectInterval :: RetryInterval,
-    msgQSize :: Natural,
-    agentQSize :: Natural
-  }
-
-defaultSMPClientAgentConfig :: SMPClientAgentConfig
-defaultSMPClientAgentConfig =
-  SMPClientAgentConfig
-    { smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
-      reconnectInterval =
-        RetryInterval
-          { initialInterval = second,
-            increaseAfter = 10 * second,
-            maxInterval = 10 * second
-          },
-      msgQSize = 64,
-      agentQSize = 64
-    }
-  where
-    second = 1000000
-
-data SMPClientAgent = SMPClientAgent
-  { agentCfg :: SMPClientAgentConfig,
-    msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    agentQ :: TBQueue SMPClientAgentEvent,
-    smpClients :: TMap SMPServer SMPClientVar,
-    srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
-    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
-    reconnections :: TVar [Async ()],
-    asyncClients :: TVar [Async ()]
-  }
-
-newtype InternalException e = InternalException {unInternalException :: e}
-  deriving (Eq, Show)
-
-instance Exception e => Exception (InternalException e)
-
-instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
-  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
-  withRunInIO exceptToIO =
-    withExceptT unInternalException . ExceptT . E.try $
-      withRunInIO $ \run ->
-        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
-
-newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent
-newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
-  msgQ <- newTBQueue msgQSize
-  agentQ <- newTBQueue agentQSize
-  smpClients <- TM.empty
-  srvSubs <- TM.empty
-  pendingSrvSubs <- TM.empty
-  reconnections <- newTVar []
-  asyncClients <- newTVar []
-  pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
-
-getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT ProtocolClientError IO SMPClient
-getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
-  atomically getClientVar >>= either newSMPClient waitForSMPClient
-  where
-    getClientVar :: STM (Either SMPClientVar SMPClientVar)
-    getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
-
-    newClientVar :: STM SMPClientVar
-    newClientVar = do
-      smpVar <- newEmptyTMVar
-      TM.insert srv smpVar smpClients
-      pure smpVar
-
-    waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
-    waitForSMPClient smpVar = do
-      let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
-      liftEither $ case smpClient_ of
-        Just (Right smpClient) -> Right smpClient
-        Just (Left e) -> Left e
-        Nothing -> Left PCEResponseTimeout
-
-    newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
-    newSMPClient smpVar = tryConnectClient pure tryConnectAsync
-      where
-        tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
-        tryConnectClient successAction retryAction =
-          tryE connectClient >>= \r -> case r of
-            Right smp -> do
-              logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-              atomically $ putTMVar smpVar r
-              successAction smp
-            Left e -> do
-              if e == PCENetworkError || e == PCEResponseTimeout
-                then retryAction
-                else atomically $ do
-                  putTMVar smpVar (Left e)
-                  TM.delete srv smpClients
-              throwE e
-        tryConnectAsync :: ExceptT ProtocolClientError IO ()
-        tryConnectAsync = do
-          a <- async connectAsync
-          atomically $ modifyTVar' (asyncClients ca) (a :)
-        connectAsync :: ExceptT ProtocolClientError IO ()
-        connectAsync =
-          withRetryInterval (reconnectInterval agentCfg) $ \loop ->
-            void $ tryConnectClient (const reconnectClient) loop
-
-    connectClient :: ExceptT ProtocolClientError IO SMPClient
-    connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
-
-    clientDisconnected :: SMPClient -> IO ()
-    clientDisconnected _ = do
-      removeClientAndSubs >>= (`forM_` serverDown)
-      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
-
-    removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
-      TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
-      where
-        updateSubs sVar = do
-          ss <- readTVar sVar
-          addPendingSubs sVar ss
-          pure ss
-
-        addPendingSubs sVar ss = do
-          let ps = pendingSrvSubs ca
-          TM.lookup srv ps >>= \case
-            Just v -> TM.union ss v
-            _ -> TM.insert srv sVar ps
-
-    serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
-    serverDown ss = unless (M.null ss) . void . runExceptT $ do
-      notify . CADisconnected srv $ M.keysSet ss
-      reconnectServer
-
-    reconnectServer :: ExceptT ProtocolClientError IO ()
-    reconnectServer = do
-      a <- async tryReconnectClient
-      atomically $ modifyTVar' (reconnections ca) (a :)
-
-    tryReconnectClient :: ExceptT ProtocolClientError IO ()
-    tryReconnectClient = do
-      withRetryInterval (reconnectInterval agentCfg) $ \loop ->
-        reconnectClient `catchE` const loop
-
-    reconnectClient :: ExceptT ProtocolClientError IO ()
-    reconnectClient = do
-      withSMP ca srv $ \smp -> do
-        notify $ CAReconnected srv
-        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
-        forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          unlessM (atomically $ hasSub (srvSubs ca) srv s) $
-            subscribe_ smp sub `catchE` handleError s
-      where
-        subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
-        subscribe_ smp sub@(s, _) = do
-          smpSubscribe smp sub
-          atomically $ addSubscription ca srv sub
-          notify $ CAResubscribed srv s
-
-        handleError :: SMPSub -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
-        handleError s = \case
-          e@PCEResponseTimeout -> throwE e
-          e@PCENetworkError -> throwE e
-          e -> do
-            notify $ CASubError srv s e
-            atomically $ removePendingSubscription ca srv s
-
-    notify :: SMPClientAgentEvent -> ExceptT ProtocolClientError IO ()
-    notify evt = atomically $ writeTBQueue (agentQ ca) evt
-
-closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
-closeSMPClientAgent c = liftIO $ do
-  closeSMPServerClients c
-  cancelActions $ reconnections c
-  cancelActions $ asyncClients c
-
-closeSMPServerClients :: SMPClientAgent -> IO ()
-closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
-  where
-    closeClient smpVar =
-      atomically (readTMVar smpVar) >>= \case
-        Right smp -> closeProtocolClient smp `catchAll_` pure ()
-        _ -> pure ()
-
-cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
-
-withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO a
-withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
-  where
-    logSMPError :: ProtocolClientError -> ExceptT ProtocolClientError IO a
-    logSMPError e = do
-      liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
-      throwE e
-
-subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
-subscribeQueue ca srv sub = do
-  atomically $ addPendingSubscription ca srv sub
-  withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
-  where
-    subscribe_ smp = do
-      smpSubscribe smp sub
-      atomically $ addSubscription ca srv sub
-
-    handleError e = do
-      atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
-        removePendingSubscription ca srv $ fst sub
-      throwE e
-
-showServer :: SMPServer -> ByteString
-showServer ProtocolServer {host, port} =
-  strEncode host <> B.pack (if null port then "" else ':' : port)
-
-smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
-smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
-  where
-    subscribe_ = case party of
-      SPRecipient -> subscribeSMPQueue
-      SPNotifier -> subscribeSMPQueueNotifications
-
-addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addSubscription ca srv sub = do
-  addSub_ (srvSubs ca) srv sub
-  removePendingSubscription ca srv $ fst sub
-
-addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addPendingSubscription = addSub_ . pendingSrvSubs
-
-addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
-addSub_ subs srv (s, key) =
-  TM.lookup srv subs >>= \case
-    Just m -> TM.insert s key m
-    _ -> TM.singleton s key >>= \v -> TM.insert srv v subs
-
-removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removeSubscription = removeSub_ . srvSubs
-
-removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
-removePendingSubscription = removeSub_ . pendingSrvSubs
-
-removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
-removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
-
-getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
-getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
-
-hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
-hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs

src/Simplex/Messaging/Crypto.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -53,7 +52,6 @@ module Simplex.Messaging.Crypto
     CryptoPublicKey (..),
     CryptoPrivateKey (..),
     KeyPair,
-    ASignatureKeyPair,
     DhSecret (..),
     DhSecretX25519,
     ADhSecret (..),
@@ -102,14 +100,9 @@ module Simplex.Messaging.Crypto
     -- * NaCl crypto_box
     CbNonce (unCbNonce),
     cbEncrypt,
-    cbEncryptMaxLenBS,
     cbDecrypt,
     cbNonce,
     randomCbNonce,
-    pseudoRandomCbNonce,
-
-    -- * pseudo-random bytes
-    pseudoRandomBytes,
 
     -- * SHA256 hash
     sha256Hash,
@@ -120,17 +113,9 @@ module Simplex.Messaging.Crypto
 
     -- * Cryptography error type
     CryptoError (..),
-
-    -- * Limited size ByteStrings
-    MaxLenBS,
-    pattern MaxLenBS,
-    maxLenBS,
-    unsafeMaxLenBS,
-    appendMaxLenBS,
   )
 where
 
-import Control.Concurrent.STM
 import Control.Exception (Exception)
 import Control.Monad.Except
 import Control.Monad.Trans.Except
@@ -144,7 +129,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import qualified Crypto.PubKey.Ed448 as Ed448
-import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate)
+import Crypto.Random (getRandomBytes)
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
 import Data.ASN1.Types
@@ -162,16 +147,22 @@ import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
 import Data.String
 import Data.Type.Equality
-import Data.Typeable (Proxy (Proxy), Typeable)
+import Data.Typeable (Typeable)
 import Data.X509
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
+import qualified Database.PostgreSQL.Simple as PDB
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.ToField as PT
+import qualified Database.PostgreSQL.Simple.TypeInfo as PTI
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PTIS
+import qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.ToField as ST
+import GHC.TypeLits (ErrorMessage (..), TypeError)
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
+import qualified Database.PostgreSQL.Simple as PDB
 
 -- | Cryptographic algorithms.
 data Algorithm = Ed25519 | Ed448 | X25519 | X448
@@ -259,12 +250,6 @@ deriving instance Eq (PrivateKey a)
 
 deriving instance Show (PrivateKey a)
 
-instance StrEncoding (PrivateKey X25519) where
-  strEncode = strEncode . encodePrivKey
-  {-# INLINE strEncode #-}
-  strDecode = decodePrivKey
-  {-# INLINE strDecode #-}
-
 data APrivateKey
   = forall a.
     AlgorithmI a =>
@@ -305,18 +290,6 @@ instance Eq APrivateSignKey where
 
 deriving instance Show APrivateSignKey
 
-instance Encoding APrivateSignKey where
-  smpEncode = smpEncode . encodePrivKey
-  {-# INLINE smpEncode #-}
-  smpDecode = decodePrivKey
-  {-# INLINE smpDecode #-}
-
-instance StrEncoding APrivateSignKey where
-  strEncode = strEncode . encodePrivKey
-  {-# INLINE strEncode #-}
-  strDecode = decodePrivKey
-  {-# INLINE strDecode #-}
-
 data APublicVerifyKey
   = forall a.
     (AlgorithmI a, SignatureAlgorithm a) =>
@@ -573,33 +546,62 @@ 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 ST.ToField APrivateSignKey where toField = ST.toField . encodePrivKey
 
-instance ToField APublicVerifyKey where toField = toField . encodePubKey
+instance ST.ToField APublicVerifyKey where toField = ST.toField . encodePubKey
 
-instance ToField APrivateDhKey where toField = toField . encodePrivKey
+instance ST.ToField APrivateDhKey where toField = ST.toField . encodePrivKey
 
-instance ToField APublicDhKey where toField = toField . encodePubKey
+instance ST.ToField APublicDhKey where toField = ST.toField . encodePubKey
 
-instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . encodePrivKey
+instance AlgorithmI a => ST.ToField (PrivateKey a) where toField = ST.toField . encodePrivKey
 
-instance AlgorithmI a => ToField (PublicKey a) where toField = toField . encodePubKey
+instance AlgorithmI a => ST.ToField (PublicKey a) where toField = ST.toField . encodePubKey
 
-instance ToField (DhSecret a) where toField = toField . dhBytes'
+instance ST.ToField (DhSecret a) where toField = ST.toField . dhBytes'
 
-instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey
+instance SF.FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey
 
-instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey
+instance SF.FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey
 
-instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey
+instance SF.FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey
 
-instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey
+instance SF.FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey
 
-instance (Typeable a, AlgorithmI a) => FromField (PrivateKey a) where fromField = blobFieldDecoder decodePrivKey
+instance (Typeable a, AlgorithmI a) => SF.FromField (PrivateKey a) where fromField = blobFieldDecoder decodePrivKey
 
-instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField = blobFieldDecoder decodePubKey
+instance (Typeable a, AlgorithmI a) => SF.FromField (PublicKey a) where fromField = blobFieldDecoder decodePubKey
 
-instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode
+instance (Typeable a, AlgorithmI a) => SF.FromField (DhSecret a) where fromField = blobFieldDecoder strDecode
+
+instance PT.ToField APrivateSignKey where toField = PT.toField . encodePrivKey
+
+instance PT.ToField APublicVerifyKey where toField = PT.toField . encodePubKey
+
+instance PT.ToField APrivateDhKey where toField = PT.toField . encodePrivKey
+
+instance PT.ToField APublicDhKey where toField = PT.toField . encodePubKey
+
+instance AlgorithmI a => PT.ToField (PrivateKey a) where toField = PT.toField . encodePrivKey
+
+instance AlgorithmI a => PT.ToField (PublicKey a) where toField = PT.toField . encodePubKey
+
+instance PT.ToField (DhSecret a) where toField = PT.toField . PDB.Binary . dhBytes'
+
+instance PF.FromField APrivateSignKey where fromField = fromByteStringField decodePrivKey
+
+instance PF.FromField APublicVerifyKey where fromField = fromByteStringField decodePubKey
+
+instance PF.FromField APrivateDhKey where fromField = fromByteStringField decodePrivKey
+
+instance PF.FromField APublicDhKey where fromField = fromByteStringField decodePubKey
+
+instance (Typeable a, AlgorithmI a) => PF.FromField (PrivateKey a) where fromField = fromByteStringField decodePrivKey
+
+instance (Typeable a, AlgorithmI a) => PF.FromField (PublicKey a) where fromField = fromByteStringField decodePubKey
+
+-- instance (Typeable a, AlgorithmI a) => PF.FromField (DhSecret a) where fromField = fromByteStringField strDecode
+instance (Typeable a, AlgorithmI a) => PF.FromField (DhSecret a) where fromField x = fromByteStringField strDecode x
 
 instance IsString (Maybe ASignature) where
   fromString = parseString $ decode >=> decodeSignature
@@ -691,8 +693,6 @@ data CryptoError
   | -- | message is larger that allowed padded length minus 2 (to prepend message length)
     -- (or required un-padded length is larger than the message length)
     CryptoLargeMsgError
-  | -- | padded message is shorter than 2 bytes
-    CryptoInvalidMsgError
   | -- | failure parsing message header
     CryptoHeaderError String
   | -- | no sending chain key in ratchet state
@@ -701,9 +701,7 @@ data CryptoError
     CERatchetHeader
   | -- | too many skipped messages
     CERatchetTooManySkipped
-  | -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
-    CERatchetEarlierMessage
-  | -- | duplicate message number
+  | -- | duplicate message number (or, possibly, skipped message that failed to decrypt?)
     CERatchetDuplicateMessage
   deriving (Eq, Show, Exception)
 
@@ -727,9 +725,13 @@ validSignatureSize n =
 newtype Key = Key {unKey :: ByteString}
   deriving (Eq, Ord, Show)
 
-instance ToField Key where toField = toField . unKey
+instance ST.ToField Key where toField = ST.toField . unKey
 
-instance FromField Key where fromField f = Key <$> fromField f
+instance PT.ToField Key where toField = PT.toField . unKey
+
+instance SF.FromField Key where fromField f = Key <$> SF.fromField f
+
+instance PF.FromField Key where fromField f = PF.fromField f
 
 instance ToJSON Key where
   toJSON = strToJSON . unKey
@@ -767,9 +769,27 @@ instance StrEncoding KeyHash where
 instance IsString KeyHash where
   fromString = parseString $ parseAll strP
 
-instance ToField KeyHash where toField = toField . strEncode
+instance ST.ToField KeyHash where toField = ST.toField . strEncode
 
-instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
+instance SF.FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
+
+instance PT.ToField KeyHash where toField = PT.toField . strEncode
+
+-- TODO
+-- instance PF.FromField KeyHash where fromField = blobFieldDecoderPostgres $ parseAll strP
+
+instance PF.FromField KeyHash where fromField = fromByteStringField $ parseAll strP
+
+fromByteStringField :: Typeable a => (ByteString -> Either String a) -> PF.Field -> Maybe ByteString -> PF.Conversion a
+fromByteStringField dec f mdata =
+  if PF.typeOid f /= PTI.typoid PTIS.bytea
+    then PF.returnError PF.Incompatible f ""
+    else case mdata of
+      Nothing -> PF.returnError PF.UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> PF.returnError PF.ConversionFailed f (B.unpack dat)
 
 -- | SHA256 digest.
 sha256Hash :: ByteString -> ByteString
@@ -804,12 +824,9 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
   aead <- initAEAD @AES256 aesKey ivBytes
   liftEither . unPad =<< maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg authTag)
 
-maxMsgLen :: Int
-maxMsgLen = 2 ^ (16 :: Int) - 3
-
 pad :: ByteString -> Int -> Either CryptoError ByteString
 pad msg paddedLen
-  | len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
+  | padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
   | otherwise = Left CryptoLargeMsgError
   where
     len = B.length msg
@@ -817,47 +834,12 @@ pad msg paddedLen
 
 unPad :: ByteString -> Either CryptoError ByteString
 unPad padded
-  | B.length lenWrd == 2 && B.length rest >= len = Right $ B.take len rest
-  | otherwise = Left CryptoInvalidMsgError
+  | B.length rest >= len = Right $ B.take len rest
+  | otherwise = Left CryptoLargeMsgError
   where
     (lenWrd, rest) = B.splitAt 2 padded
     len = fromIntegral $ decodeWord16 lenWrd
 
-newtype MaxLenBS (i :: Nat) = MLBS {unMaxLenBS :: ByteString}
-
-pattern MaxLenBS :: ByteString -> MaxLenBS i
-pattern MaxLenBS s <- MLBS s
-
-{-# COMPLETE MaxLenBS #-}
-
-instance KnownNat i => Encoding (MaxLenBS i) where
-  smpEncode (MLBS s) = smpEncode s
-  smpP = first show . maxLenBS <$?> smpP
-
-instance KnownNat i => StrEncoding (MaxLenBS i) where
-  strEncode (MLBS s) = strEncode s
-  strP = first show . maxLenBS <$?> strP
-
-maxLenBS :: forall i. KnownNat i => ByteString -> Either CryptoError (MaxLenBS i)
-maxLenBS s
-  | B.length s > maxLength @i = Left CryptoLargeMsgError
-  | otherwise = Right $ MLBS s
-
-unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
-unsafeMaxLenBS = MLBS
-
-padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
-padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
-  where
-    len = B.length msg
-    padLen = maxLength @i - len
-
-appendMaxLenBS :: (KnownNat i, KnownNat j) => MaxLenBS i -> MaxLenBS j -> MaxLenBS (i + j)
-appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
-
-maxLength :: forall i. KnownNat i => Int
-maxLength = fromIntegral (natVal $ Proxy @i)
-
 initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEAD (Key aesKey) (IV ivBytes) = do
   iv <- makeIV @c ivBytes
@@ -913,17 +895,12 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 
 -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
 cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
-cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
-
--- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
-cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
-cbEncryptMaxLenBS secret (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
-
-cryptoBox :: DhSecret 'X25519 -> ByteString -> ByteString -> ByteString
-cryptoBox secret nonce s = BA.convert tag <> c
+cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox <$> pad msg paddedLen
   where
-    (rs, c) = xSalsa20 secret nonce s
-    tag = Poly1305.auth rs c
+    cryptoBox s = BA.convert tag <> c
+      where
+        (rs, c) = xSalsa20 secret nonce s
+        tag = Poly1305.auth rs c
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
@@ -937,15 +914,7 @@ cbDecrypt secret (CbNonce nonce) packet
     tag = Poly1305.auth rs c
 
 newtype CbNonce = CbNonce {unCbNonce :: ByteString}
-  deriving (Eq, Show)
-
-instance StrEncoding CbNonce where
-  strEncode (CbNonce s) = strEncode s
-  strP = cbNonce <$> strP
-
-instance ToJSON CbNonce where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
+  deriving (Show)
 
 cbNonce :: ByteString -> CbNonce
 cbNonce s
@@ -958,16 +927,6 @@ cbNonce s
 randomCbNonce :: IO CbNonce
 randomCbNonce = CbNonce <$> getRandomBytes 24
 
-pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
-pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar
-
-pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
-pseudoRandomBytes n gVar = do
-  g <- readTVar gVar
-  let (bytes, g') = randomBytesGenerate n g
-  writeTVar gVar g'
-  return bytes
-
 instance Encoding CbNonce where
   smpEncode = unCbNonce
   smpP = CbNonce <$> A.take 24

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -30,8 +30,12 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Data.Typeable (Typeable)
 import Data.Word (Word32)
-import Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.ToField as PT
+import qualified Database.PostgreSQL.Simple.TypeInfo as PTI
+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PTIS
+import qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.ToField as ST
 import GHC.Generics
 import Simplex.Messaging.Agent.QueryString
 import Simplex.Messaging.Crypto
@@ -41,11 +45,11 @@ import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')
 import Simplex.Messaging.Util (tryE)
 import Simplex.Messaging.Version
 
-currentE2EEncryptVersion :: Version
-currentE2EEncryptVersion = 2
+e2eEncryptVersion :: Version
+e2eEncryptVersion = 1
 
-supportedE2EEncryptVRange :: VersionRange
-supportedE2EEncryptVRange = mkVersionRange 1 currentE2EEncryptVersion
+e2eEncryptVRange :: VersionRange
+e2eEncryptVRange = mkVersionRange 1 e2eEncryptVersion
 
 data E2ERatchetParams (a :: Algorithm)
   = E2ERatchetParams Version (PublicKey a) (PublicKey a)
@@ -96,27 +100,20 @@ data RatchetInitParams = RatchetInitParams
   deriving (Eq, Show)
 
 x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhSnd spk1 spk2 (E2ERatchetParams v rk1 rk2) =
-  x3dh v (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
+x3dhSnd spk1 spk2 (E2ERatchetParams _ rk1 rk2) =
+  x3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
 
 x3dhRcv :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhRcv rpk1 rpk2 (E2ERatchetParams v sk1 sk2) =
-  x3dh v (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
+x3dhRcv rpk1 rpk2 (E2ERatchetParams _ sk1 sk2) =
+  x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
 
-x3dh :: DhAlgorithm a => Version -> (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
-x3dh v (sk1, rk1) dh1 dh2 dh3 =
+x3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
+x3dh (sk1, rk1) dh1 dh2 dh3 =
   RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk}
   where
     assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
-    dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
-    (hk, nhk, sk)
-      -- for backwards compatibility with clients using agent version before 3.4.0
-      | v == 1 =
-        let (hk', rest) = B.splitAt 32 dhs
-         in uncurry (hk',,) $ B.splitAt 32 rest
-      | otherwise =
-        let salt = B.replicate 64 '\0'
-         in hkdf3 salt dhs "SimpleXX3DH"
+    (hk, rest) = B.splitAt 32 $ dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
+    (nhk, sk) = B.splitAt 32 rest
 
 type RatchetX448 = Ratchet 'X448
 
@@ -204,25 +201,44 @@ instance ToJSON RatchetKey where
 instance FromJSON RatchetKey where
   parseJSON = fmap RatchetKey . strParseJSON "Key"
 
-instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode
+instance AlgorithmI a => ST.ToField (Ratchet a) where toField = ST.toField . LB.toStrict . J.encode
 
-instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
+instance AlgorithmI a => PT.ToField (Ratchet a) where toField = PT.toField . LB.toStrict . J.encode
 
-instance ToField MessageKey where toField = toField . smpEncode
+instance (AlgorithmI a, Typeable a) => PF.FromField (Ratchet a) where fromField = fromByteStringField J.eitherDecodeStrict'
 
-instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
+instance (AlgorithmI a, Typeable a) => SF.FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
+
+instance ST.ToField MessageKey where toField = ST.toField . smpEncode
+
+instance PT.ToField MessageKey where toField = PT.toField . smpEncode
+
+instance SF.FromField MessageKey where fromField = blobFieldDecoder smpDecode
+
+instance PF.FromField MessageKey where fromField = fromByteStringField smpDecode
+
+fromByteStringField :: Typeable a => (ByteString -> Either String a) -> PF.Field -> Maybe ByteString -> PF.Conversion a
+fromByteStringField dec f mdata =
+  if PF.typeOid f /= PTI.typoid PTIS.bytea
+    then PF.returnError PF.Incompatible f ""
+    else case mdata of
+      Nothing -> PF.returnError PF.UnexpectedNull f ""
+      Just dat ->
+        case dec dat of
+          Right x -> return x
+          _ -> PF.returnError PF.ConversionFailed f (B.unpack dat)
 
 -- | Sending ratchet initialization, equivalent to RatchetInitAliceHE in double ratchet spec
 --
 -- Please note that sPKey is not stored, and its public part together with random salt
 -- is sent to the recipient.
 initSndRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
-initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
+  forall a. (AlgorithmI a, DhAlgorithm a) => PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
+initSndRatchet rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))
   let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs
    in Ratchet
-        { rcVersion,
+        { rcVersion = e2eEncryptVRange,
           rcAD = assocData,
           rcDHRs,
           rcRK,
@@ -240,10 +256,10 @@ initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey,
 -- Please note that the public part of rcDHRs was sent to the sender
 -- as part of the connection request and random salt was received from the sender.
 initRcvRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PrivateKey a -> RatchetInitParams -> Ratchet a
-initRcvRatchet rcVersion rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
+  forall a. (AlgorithmI a, DhAlgorithm a) => PrivateKey a -> RatchetInitParams -> Ratchet a
+initRcvRatchet rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
   Ratchet
-    { rcVersion,
+    { rcVersion = e2eEncryptVRange,
       rcAD = assocData,
       rcDHRs,
       rcRK = ratchetKey,
@@ -423,8 +439,7 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
     skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
     skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
     skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
-      | rcNr > untilN + 1 = Left CERatchetEarlierMessage
-      | rcNr == untilN + 1 = Left CERatchetDuplicateMessage
+      | rcNr > untilN = Left CERatchetDuplicateMessage
       | rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
       | rcNr == untilN = Right (r, M.empty)
       | otherwise =

src/Simplex/Messaging/Encoding.hs

@@ -13,7 +13,6 @@ module Simplex.Messaging.Encoding
     Large (..),
     smpEncodeList,
     smpListP,
-    lenEncode,
   )
 where
 
@@ -48,100 +47,66 @@ class Encoding a where
 
 instance Encoding Char where
   smpEncode = B.singleton
-  {-# INLINE smpEncode #-}
   smpP = A.anyChar
-  {-# INLINE smpP #-}
-
-instance Encoding Bool where
-  smpEncode = \case
-    True -> "T"
-    False -> "F"
-  {-# INLINE smpEncode #-}
-  smpP =
-    smpP >>= \case
-      'T' -> pure True
-      'F' -> pure False
-      _ -> fail "invalid Bool"
-  {-# INLINE smpP #-}
 
 instance Encoding Word16 where
   smpEncode = encodeWord16
-  {-# INLINE smpEncode #-}
   smpP = decodeWord16 <$> A.take 2
-  {-# INLINE smpP #-}
 
 instance Encoding Word32 where
   smpEncode = encodeWord32
-  {-# INLINE smpEncode #-}
   smpP = decodeWord32 <$> A.take 4
-  {-# INLINE smpP #-}
 
 instance Encoding Int64 where
   smpEncode i = w32 (i `shiftR` 32) <> w32 i
-  {-# INLINE smpEncode #-}
   smpP = do
     l <- w32P
     r <- w32P
     pure $ (l `shiftL` 32) .|. r
-  {-# INLINE smpP #-}
 
 w32 :: Int64 -> ByteString
 w32 = smpEncode @Word32 . fromIntegral
-{-# INLINE w32 #-}
 
 w32P :: Parser Int64
 w32P = fromIntegral <$> smpP @Word32
-{-# INLINE w32P #-}
 
 -- ByteStrings are assumed no longer than 255 bytes
 instance Encoding ByteString where
   smpEncode s = B.cons (lenEncode $ B.length s) s
-  {-# INLINE smpEncode #-}
   smpP = A.take =<< lenP
-  {-# INLINE smpP #-}
 
 lenEncode :: Int -> Char
 lenEncode = w2c . fromIntegral
-{-# INLINE lenEncode #-}
 
 lenP :: Parser Int
 lenP = fromIntegral . c2w <$> A.anyChar
-{-# INLINE lenP #-}
 
 instance Encoding a => Encoding (Maybe a) where
   smpEncode s = maybe "0" (("1" <>) . smpEncode) s
-  {-# INLINE smpEncode #-}
   smpP =
     smpP >>= \case
       '0' -> pure Nothing
       '1' -> Just <$> smpP
       _ -> fail "invalid Maybe tag"
-  {-# INLINE smpP #-}
 
 newtype Tail = Tail {unTail :: ByteString}
 
 instance Encoding Tail where
   smpEncode = unTail
-  {-# INLINE smpEncode #-}
   smpP = Tail <$> A.takeByteString
-  {-# INLINE smpP #-}
 
 -- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix
 newtype Large = Large {unLarge :: ByteString}
 
 instance Encoding Large where
   smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s
-  {-# INLINE smpEncode #-}
   smpP = do
     len <- fromIntegral <$> smpP @Word16
     Large <$> A.take len
-  {-# INLINE smpP #-}
 
 instance Encoding SystemTime where
   smpEncode = smpEncode . systemSeconds
-  {-# INLINE smpEncode #-}
   smpP = MkSystemTime <$> smpP <*> pure 0
-  {-# INLINE smpP #-}
 
 -- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
 smpEncodeList :: Encoding a => [a] -> ByteString
@@ -152,9 +117,7 @@ smpListP = (`A.count` smpP) =<< lenP
 
 instance Encoding String where
   smpEncode = smpEncode . B.pack
-  {-# INLINE smpEncode #-}
   smpP = B.unpack <$> smpP
-  {-# INLINE smpP #-}
 
 instance Encoding a => Encoding (L.NonEmpty a) where
   smpEncode = smpEncodeList . L.toList
@@ -165,42 +128,16 @@ instance Encoding a => Encoding (L.NonEmpty a) where
 
 instance (Encoding a, Encoding b) => Encoding (a, b) where
   smpEncode (a, b) = smpEncode a <> smpEncode b
-  {-# INLINE smpEncode #-}
   smpP = (,) <$> smpP <*> smpP
-  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
   smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
-  {-# INLINE smpEncode #-}
   smpP = (,,) <$> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
   smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d
-  {-# INLINE smpEncode #-}
   smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}
 
 instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
   smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
-  {-# INLINE smpEncode #-}
   smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}
-
-instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
-  smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
-  {-# INLINE smpEncode #-}
-  smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}
-
-instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
-  smpEncode (a, b, c, d, e, f, g) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g
-  {-# INLINE smpEncode #-}
-  smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}
-
-instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
-  smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
-  {-# INLINE smpEncode #-}
-  smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
-  {-# INLINE smpP #-}

src/Simplex/Messaging/Encoding/String.hs

@@ -2,11 +2,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Encoding.String
-  ( TextEncoding (..),
-    StrEncoding (..),
+  ( StrEncoding (..),
     Str (..),
     strP_,
-    _strP,
     strToJSON,
     strToJEncoding,
     strParseJSON,
@@ -27,24 +25,12 @@ import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
-import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-import Data.Time.Clock (UTCTime)
-import Data.Time.Clock.System (SystemTime (..))
-import Data.Time.Format.ISO8601
 import Data.Word (Word16)
-import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))
 
-class TextEncoding a where
-  textEncode :: a -> Text
-  textDecode :: Text -> Maybe a
-
 -- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols
 class StrEncoding a where
   {-# MINIMAL strEncode, (strDecode | strP) #-}
@@ -84,47 +70,11 @@ instance FromJSON Str where
 
 instance StrEncoding a => StrEncoding (Maybe a) where
   strEncode = maybe "" strEncode
-  {-# INLINE strEncode #-}
   strP = optional strP
-  {-# INLINE strP #-}
 
 instance StrEncoding Word16 where
   strEncode = B.pack . show
-  {-# INLINE strEncode #-}
   strP = A.decimal
-  {-# INLINE strP #-}
-
-instance StrEncoding Char where
-  strEncode = smpEncode
-  {-# INLINE strEncode #-}
-  strP = smpP
-  {-# INLINE strP #-}
-
-instance StrEncoding Bool where
-  strEncode = smpEncode
-  {-# INLINE strEncode #-}
-  strP = smpP
-  {-# INLINE strP #-}
-
-instance StrEncoding Int where
-  strEncode = B.pack . show
-  {-# INLINE strEncode #-}
-  strP = A.decimal
-  {-# INLINE strP #-}
-
-instance StrEncoding Int64 where
-  strEncode = B.pack . show
-  {-# INLINE strEncode #-}
-  strP = A.decimal
-  {-# INLINE strP #-}
-
-instance StrEncoding SystemTime where
-  strEncode = strEncode . systemSeconds
-  strP = MkSystemTime <$> strP <*> pure 0
-
-instance StrEncoding UTCTime where
-  strEncode = B.pack . iso8601Show
-  strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
 
 -- lists encode/parse as comma-separated strings
 strEncodeList :: StrEncoding a => [a] -> ByteString
@@ -138,43 +88,28 @@ instance StrEncoding a => StrEncoding (L.NonEmpty a) where
   strEncode = strEncodeList . L.toList
   strP = L.fromList <$> listItem `A.sepBy1'` A.char ','
 
-instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
-  strEncode = strEncodeList . S.toList
-  strP = S.fromList <$> listItem `A.sepBy'` A.char ','
-
 listItem :: StrEncoding a => Parser a
-listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
+listItem = parseAll strP <$?> A.takeTill (== ',')
 
 instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
   strEncode (a, b) = B.unwords [strEncode a, strEncode b]
-  {-# INLINE strEncode #-}
   strP = (,) <$> strP_ <*> strP
-  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c) => StrEncoding (a, b, c) where
   strEncode (a, b, c) = B.unwords [strEncode a, strEncode b, strEncode c]
-  {-# INLINE strEncode #-}
   strP = (,,) <$> strP_ <*> strP_ <*> strP
-  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d) => StrEncoding (a, b, c, d) where
   strEncode (a, b, c, d) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d]
-  {-# INLINE strEncode #-}
   strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP
-  {-# INLINE strP #-}
 
 instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e) => StrEncoding (a, b, c, d, e) where
   strEncode (a, b, c, d, e) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e]
-  {-# INLINE strEncode #-}
   strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
-  {-# INLINE strP #-}
 
 strP_ :: StrEncoding a => Parser a
 strP_ = strP <* A.space
 
-_strP :: StrEncoding a => Parser a
-_strP = A.space *> strP
-
 strToJSON :: StrEncoding a => a -> J.Value
 strToJSON = J.String . decodeLatin1 . strEncode
 

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,64 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Client where
-
-import Control.Monad.Except
-import Control.Monad.Trans.Except
-import Data.Word (Word16)
-import Simplex.Messaging.Client
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Util (bshow)
-
-type NtfClient = ProtocolClient NtfResponse
-
-ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
-ntfRegisterToken c pKey newTkn =
-  sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
-    NRTknId tknId dhKey -> pure (tknId, dhKey)
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
-ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
-ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
-
-ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
-ntfCheckToken c pKey tknId =
-  sendNtfCommand c (Just pKey) tknId TCHK >>= \case
-    NRTkn stat -> pure stat
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
-ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT ProtocolClientError IO ()
-ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
-
-ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
-ntfDeleteToken = okNtfCommand TDEL
-
-ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
-ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
-
-ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO NtfSubscriptionId
-ntfCreateSubscription c pKey newSub =
-  sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
-    NRSubId subId -> pure subId
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
-ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
-ntfCheckSubscription c pKey subId =
-  sendNtfCommand c (Just pKey) subId SCHK >>= \case
-    NRSub stat -> pure stat
-    r -> throwE . PCEUnexpectedResponse $ bshow r
-
-ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
-ntfDeleteSubscription = okNtfCommand SDEL
-
--- | Send notification server command
-sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
-sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
-
-okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
-okNtfCommand cmd c pKey entId =
-  sendNtfCommand c (Just pKey) entId cmd >>= \case
-    NROk -> return ()
-    r -> throwE . PCEUnexpectedResponse $ bshow r

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -1,507 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Simplex.Messaging.Notifications.Protocol where
-
-import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
-import qualified Data.Aeson as J
-import qualified Data.Aeson.Encoding as JE
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Kind
-import Data.Maybe (isNothing)
-import Data.Text.Encoding (decodeLatin1, encodeUtf8)
-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 qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
-import Simplex.Messaging.Parsers (fromTextField_)
-import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
-import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
-
-data NtfEntity = Token | Subscription
-  deriving (Show)
-
-data SNtfEntity :: NtfEntity -> Type where
-  SToken :: SNtfEntity 'Token
-  SSubscription :: SNtfEntity 'Subscription
-
-instance TestEquality SNtfEntity where
-  testEquality SToken SToken = Just Refl
-  testEquality SSubscription SSubscription = Just Refl
-  testEquality _ _ = Nothing
-
-deriving instance Show (SNtfEntity e)
-
-class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e
-
-instance NtfEntityI 'Token where sNtfEntity = SToken
-
-instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
-
-data NtfCommandTag (e :: NtfEntity) where
-  TNEW_ :: NtfCommandTag 'Token
-  TVFY_ :: NtfCommandTag 'Token
-  TCHK_ :: NtfCommandTag 'Token
-  TRPL_ :: NtfCommandTag 'Token
-  TDEL_ :: NtfCommandTag 'Token
-  TCRN_ :: NtfCommandTag 'Token
-  SNEW_ :: NtfCommandTag 'Subscription
-  SCHK_ :: NtfCommandTag 'Subscription
-  SDEL_ :: NtfCommandTag 'Subscription
-  PING_ :: NtfCommandTag 'Subscription
-
-deriving instance Show (NtfCommandTag e)
-
-data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)
-
-instance NtfEntityI e => Encoding (NtfCommandTag e) where
-  smpEncode = \case
-    TNEW_ -> "TNEW"
-    TVFY_ -> "TVFY"
-    TCHK_ -> "TCHK"
-    TRPL_ -> "TRPL"
-    TDEL_ -> "TDEL"
-    TCRN_ -> "TCRN"
-    SNEW_ -> "SNEW"
-    SCHK_ -> "SCHK"
-    SDEL_ -> "SDEL"
-    PING_ -> "PING"
-  smpP = messageTagP
-
-instance Encoding NtfCmdTag where
-  smpEncode (NCT _ t) = smpEncode t
-  smpP = messageTagP
-
-instance ProtocolMsgTag NtfCmdTag where
-  decodeTag = \case
-    "TNEW" -> Just $ NCT SToken TNEW_
-    "TVFY" -> Just $ NCT SToken TVFY_
-    "TCHK" -> Just $ NCT SToken TCHK_
-    "TRPL" -> Just $ NCT SToken TRPL_
-    "TDEL" -> Just $ NCT SToken TDEL_
-    "TCRN" -> Just $ NCT SToken TCRN_
-    "SNEW" -> Just $ NCT SSubscription SNEW_
-    "SCHK" -> Just $ NCT SSubscription SCHK_
-    "SDEL" -> Just $ NCT SSubscription SDEL_
-    "PING" -> Just $ NCT SSubscription PING_
-    _ -> Nothing
-
-instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
-  decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
-
-newtype NtfRegCode = NtfRegCode ByteString
-  deriving (Eq, Show)
-
-instance Encoding NtfRegCode where
-  smpEncode (NtfRegCode code) = smpEncode code
-  smpP = NtfRegCode <$> smpP
-
-instance StrEncoding NtfRegCode where
-  strEncode (NtfRegCode m) = strEncode m
-  strDecode s = NtfRegCode <$> strDecode s
-  strP = NtfRegCode <$> strP
-
-instance FromJSON NtfRegCode where
-  parseJSON = strParseJSON "NtfRegCode"
-
-instance ToJSON NtfRegCode where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-data NewNtfEntity (e :: NtfEntity) where
-  NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
-  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription
-
-deriving instance Show (NewNtfEntity e)
-
-data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
-
-deriving instance Show ANewNtfEntity
-
-instance NtfEntityI e => Encoding (NewNtfEntity e) where
-  smpEncode = \case
-    NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
-    NewNtfSub tknId smpQueue notifierKey -> smpEncode ('S', tknId, smpQueue, notifierKey)
-  smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
-
-instance Encoding ANewNtfEntity where
-  smpEncode (ANE _ e) = smpEncode e
-  smpP =
-    A.anyChar >>= \case
-      'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
-      'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP <*> smpP)
-      _ -> fail "bad ANewNtfEntity"
-
-instance Protocol NtfResponse where
-  type ProtoCommand NtfResponse = NtfCmd
-  type ProtoType NtfResponse = 'PNTF
-  protocolClientHandshake = ntfClientHandshake
-  protocolPing = NtfCmd SSubscription PING
-  protocolError = \case
-    NRErr e -> Just e
-    _ -> Nothing
-
-data NtfCommand (e :: NtfEntity) where
-  -- | register new device token for notifications
-  TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
-  -- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
-  TVFY :: NtfRegCode -> NtfCommand 'Token
-  -- | check token status
-  TCHK :: NtfCommand 'Token
-  -- | replace device token (while keeping all existing subscriptions)
-  TRPL :: DeviceToken -> NtfCommand 'Token
-  -- | delete token - all subscriptions will be removed and no more notifications will be sent
-  TDEL :: NtfCommand 'Token
-  -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
-  TCRN :: Word16 -> NtfCommand 'Token
-  -- | create SMP subscription
-  SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
-  -- | check SMP subscription status (response is SUB)
-  SCHK :: NtfCommand 'Subscription
-  -- | delete SMP subscription
-  SDEL :: NtfCommand 'Subscription
-  -- | keep-alive command
-  PING :: NtfCommand 'Subscription
-
-deriving instance Show (NtfCommand e)
-
-data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
-
-deriving instance Show NtfCmd
-
-instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
-  type Tag (NtfCommand e) = NtfCommandTag e
-  encodeProtocol _v = \case
-    TNEW newTkn -> e (TNEW_, ' ', newTkn)
-    TVFY code -> e (TVFY_, ' ', code)
-    TCHK -> e TCHK_
-    TRPL tkn -> e (TRPL_, ' ', tkn)
-    TDEL -> e TDEL_
-    TCRN int -> e (TCRN_, ' ', int)
-    SNEW newSub -> e (SNEW_, ' ', newSub)
-    SCHK -> e SCHK_
-    SDEL -> e SDEL_
-    PING -> e PING_
-    where
-      e :: Encoding a => a -> ByteString
-      e = smpEncode
-
-  protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
-
-  checkCredentials (sig, _, entityId, _) cmd = case cmd of
-    -- TNEW and SNEW must have signature but NOT token/subscription IDs
-    TNEW {} -> sigNoEntity
-    SNEW {} -> sigNoEntity
-    PING
-      | isNothing sig && B.null entityId -> Right cmd
-      | otherwise -> Left $ CMD HAS_AUTH
-    -- other client commands must have both signature and entity ID
-    _
-      | isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
-      | otherwise -> Right cmd
-    where
-      sigNoEntity
-        | isNothing sig = Left $ CMD NO_AUTH
-        | not (B.null entityId) = Left $ CMD HAS_AUTH
-        | otherwise = Right cmd
-
-instance ProtocolEncoding NtfCmd where
-  type Tag NtfCmd = NtfCmdTag
-  encodeProtocol _v (NtfCmd _ c) = encodeProtocol _v c
-
-  protocolP _v = \case
-    NCT SToken tag ->
-      NtfCmd SToken <$> case tag of
-        TNEW_ -> TNEW <$> _smpP
-        TVFY_ -> TVFY <$> _smpP
-        TCHK_ -> pure TCHK
-        TRPL_ -> TRPL <$> _smpP
-        TDEL_ -> pure TDEL
-        TCRN_ -> TCRN <$> _smpP
-    NCT SSubscription tag ->
-      NtfCmd SSubscription <$> case tag of
-        SNEW_ -> SNEW <$> _smpP
-        SCHK_ -> pure SCHK
-        SDEL_ -> pure SDEL
-        PING_ -> pure PING
-
-  checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
-
-data NtfResponseTag
-  = NRTknId_
-  | NRSubId_
-  | NROk_
-  | NRErr_
-  | NRTkn_
-  | NRSub_
-  | NRPong_
-  deriving (Show)
-
-instance Encoding NtfResponseTag where
-  smpEncode = \case
-    NRTknId_ -> "IDTKN" -- it should be "TID", "SID"
-    NRSubId_ -> "IDSUB"
-    NROk_ -> "OK"
-    NRErr_ -> "ERR"
-    NRTkn_ -> "TKN"
-    NRSub_ -> "SUB"
-    NRPong_ -> "PONG"
-  smpP = messageTagP
-
-instance ProtocolMsgTag NtfResponseTag where
-  decodeTag = \case
-    "IDTKN" -> Just NRTknId_
-    "IDSUB" -> Just NRSubId_
-    "OK" -> Just NROk_
-    "ERR" -> Just NRErr_
-    "TKN" -> Just NRTkn_
-    "SUB" -> Just NRSub_
-    "PONG" -> Just NRPong_
-    _ -> Nothing
-
-data NtfResponse
-  = NRTknId NtfEntityId C.PublicKeyX25519
-  | NRSubId NtfEntityId
-  | NROk
-  | NRErr ErrorType
-  | NRTkn NtfTknStatus
-  | NRSub NtfSubStatus
-  | NRPong
-  deriving (Show)
-
-instance ProtocolEncoding NtfResponse where
-  type Tag NtfResponse = NtfResponseTag
-  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)
-    NRSub stat -> e (NRSub_, ' ', stat)
-    NRPong -> e NRPong_
-    where
-      e :: Encoding a => a -> ByteString
-      e = smpEncode
-
-  protocolP _v = \case
-    NRTknId_ -> NRTknId <$> _smpP <*> smpP
-    NRSubId_ -> NRSubId <$> _smpP
-    NROk_ -> pure NROk
-    NRErr_ -> NRErr <$> _smpP
-    NRTkn_ -> NRTkn <$> _smpP
-    NRSub_ -> NRSub <$> _smpP
-    NRPong_ -> pure NRPong
-
-  checkCredentials (_, _, entId, _) cmd = case cmd of
-    -- IDTKN response must not have queue ID
-    NRTknId {} -> noEntity
-    -- IDSUB response must not have queue ID
-    NRSubId {} -> noEntity
-    -- ERR response does not always have entity ID
-    NRErr _ -> Right cmd
-    -- PONG response must not have queue ID
-    NRPong -> noEntity
-    -- other server responses must have entity ID
-    _
-      | B.null entId -> Left $ CMD NO_ENTITY
-      | otherwise -> Right cmd
-    where
-      noEntity
-        | B.null entId = Right cmd
-        | otherwise = Left $ CMD HAS_AUTH
-
-data SMPQueueNtf = SMPQueueNtf
-  { smpServer :: SMPServer,
-    notifierId :: NotifierId
-  }
-  deriving (Eq, Ord, Show)
-
-instance Encoding SMPQueueNtf where
-  smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
-  smpP = do
-    smpServer <- updateSMPServerHosts <$> smpP
-    notifierId <- smpP
-    pure SMPQueueNtf {smpServer, notifierId}
-
-instance StrEncoding SMPQueueNtf where
-  strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
-  strP = do
-    smpServer <- updateSMPServerHosts <$> strP
-    notifierId <- A.char '/' *> strP
-    pure SMPQueueNtf {smpServer, notifierId}
-
-data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
-  deriving (Eq, Ord, Show)
-
-instance Encoding PushProvider where
-  smpEncode = \case
-    PPApnsDev -> "AD"
-    PPApnsProd -> "AP"
-    PPApnsTest -> "AT"
-  smpP =
-    A.take 2 >>= \case
-      "AD" -> pure PPApnsDev
-      "AP" -> pure PPApnsProd
-      "AT" -> pure PPApnsTest
-      _ -> fail "bad PushProvider"
-
-instance StrEncoding PushProvider where
-  strEncode = \case
-    PPApnsDev -> "apns_dev"
-    PPApnsProd -> "apns_prod"
-    PPApnsTest -> "apns_test"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "apns_dev" -> pure PPApnsDev
-      "apns_prod" -> pure PPApnsProd
-      "apns_test" -> pure PPApnsTest
-      _ -> fail "bad PushProvider"
-
-instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
-
-instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
-
-data DeviceToken = DeviceToken PushProvider ByteString
-  deriving (Eq, Ord, Show)
-
-instance Encoding DeviceToken where
-  smpEncode (DeviceToken p t) = smpEncode (p, t)
-  smpP = DeviceToken <$> smpP <*> smpP
-
-instance StrEncoding DeviceToken where
-  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = DeviceToken <$> strP <* A.space <*> hexStringP
-    where
-      hexStringP =
-        A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
-          if even (B.length s) then pure s else fail "odd number of hex characters"
-
-instance ToJSON DeviceToken where
-  toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
-  toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
-
-type NtfEntityId = ByteString
-
-type NtfSubscriptionId = NtfEntityId
-
-type NtfTokenId = NtfEntityId
-
-data NtfSubStatus
-  = -- | state after SNEW
-    NSNew
-  | -- | pending connection/subscription to SMP server
-    NSPending
-  | -- | connected and subscribed to SMP server
-    NSActive
-  | -- | disconnected/unsubscribed from SMP server
-    NSInactive
-  | -- | END received
-    NSEnd
-  | -- | SMP AUTH error
-    NSAuth
-  | -- | SMP error other than AUTH
-    NSErr ByteString
-  deriving (Eq, Show)
-
-ntfShouldSubscribe :: NtfSubStatus -> Bool
-ntfShouldSubscribe = \case
-  NSNew -> True
-  NSPending -> True
-  NSActive -> True
-  NSInactive -> True
-  NSEnd -> False
-  NSAuth -> False
-  NSErr _ -> False
-
-instance Encoding NtfSubStatus where
-  smpEncode = \case
-    NSNew -> "NEW"
-    NSPending -> "PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
-    NSActive -> "ACTIVE"
-    NSInactive -> "INACTIVE"
-    NSEnd -> "END"
-    NSAuth -> "AUTH"
-    NSErr err -> "ERR " <> err
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NSNew
-      "PENDING" -> pure NSPending
-      "ACTIVE" -> pure NSActive
-      "INACTIVE" -> pure NSInactive
-      "END" -> pure NSEnd
-      "AUTH" -> pure NSAuth
-      "ERR" -> NSErr <$> (A.space *> A.takeByteString)
-      _ -> fail "bad NtfSubStatus"
-
-instance StrEncoding NtfSubStatus where
-  strEncode = smpEncode
-  strP = smpP
-
-data NtfTknStatus
-  = -- | Token created in DB
-    NTNew
-  | -- | state after registration (TNEW)
-    NTRegistered
-  | -- | if initial notification failed (push provider error) or verification failed
-    NTInvalid
-  | -- | Token confirmed via notification (accepted by push provider or verification code received by client)
-    NTConfirmed
-  | -- | after successful verification (TVFY)
-    NTActive
-  | -- | after it is no longer valid (push provider error)
-    NTExpired
-  deriving (Eq, Show)
-
-instance Encoding NtfTknStatus where
-  smpEncode = \case
-    NTNew -> "NEW"
-    NTRegistered -> "REGISTERED"
-    NTInvalid -> "INVALID"
-    NTConfirmed -> "CONFIRMED"
-    NTActive -> "ACTIVE"
-    NTExpired -> "EXPIRED"
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NTNew
-      "REGISTERED" -> pure NTRegistered
-      "INVALID" -> pure NTInvalid
-      "CONFIRMED" -> pure NTConfirmed
-      "ACTIVE" -> pure NTActive
-      "EXPIRED" -> pure NTExpired
-      _ -> fail "bad NtfTknStatus"
-
-instance StrEncoding NtfTknStatus where
-  strEncode = smpEncode
-  strP = smpP
-
-instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
-
-instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
-
-instance ToJSON NtfTknStatus where
-  toEncoding = JE.text . decodeLatin1 . smpEncode
-  toJSON = J.String . decodeLatin1 . smpEncode
-
-checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
-checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
-  Just Refl -> Right c
-  Nothing -> Left "bad command party"
-
-checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
-checkEntity' c = case testEquality (sNtfEntity @p) (sNtfEntity @p') of
-  Just Refl -> Just c
-  _ -> Nothing

src/Simplex/Messaging/Notifications/Server.hs

@@ -1,577 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Simplex.Messaging.Notifications.Server where
-
-import Control.Concurrent.STM (stateTVar)
-import Control.Logger.Simple
-import Control.Monad.Except
-import Control.Monad.Reader
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
-import Data.List (intercalate)
-import Data.Map.Strict (Map)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
-import Data.Time.Clock.System (getSystemTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
-import Network.Socket (ServiceName)
-import Simplex.Messaging.Client (ProtocolClientError (..))
-import Simplex.Messaging.Client.Agent
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Env
-import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
-import Simplex.Messaging.Notifications.Server.Stats
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Server.StoreLog
-import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
-import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Server
-import Simplex.Messaging.Server.Stats
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
-import Simplex.Messaging.Transport.Server (runTransportServer)
-import Simplex.Messaging.Util
-import System.Exit (exitFailure)
-import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
-import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
-import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
-import UnliftIO.Directory (doesFileExist, renameFile)
-import UnliftIO.Exception
-import UnliftIO.STM
-
-runNtfServer :: NtfServerConfig -> IO ()
-runNtfServer cfg = do
-  started <- newEmptyTMVarIO
-  runNtfServerBlocking started cfg
-
-runNtfServerBlocking :: TMVar Bool -> NtfServerConfig -> IO ()
-runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
-
-type M a = ReaderT NtfEnv IO a
-
-ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
-ntfServer cfg@NtfServerConfig {transports} started = do
-  restoreServerStats
-  s <- asks subscriber
-  ps <- asks pushServer
-  subs <- readTVarIO =<< asks (subscriptions . store)
-  void . forkIO $ resubscribe s subs
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
-  where
-    runServer :: (ServiceName, ATransport) -> M ()
-    runServer (tcpPort, ATransport t) = do
-      serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
-
-    runClient :: Transport c => TProxy c -> c -> M ()
-    runClient _ h = do
-      kh <- asks serverIdentity
-      liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
-        Right th -> runNtfClientTransport th
-        Left _ -> pure ()
-
-    stopServer :: M ()
-    stopServer = do
-      withNtfLog closeStoreLog
-      saveServerStats
-      asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
-
-    serverStatsThread_ :: NtfServerConfig -> [M ()]
-    serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
-      [logServerStats logStatsStartTime interval serverStatsLogFile]
-    serverStatsThread_ _ = []
-
-    logServerStats :: Int -> Int -> FilePath -> M ()
-    logServerStats startAt logInterval statsFilePath = do
-      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
-      let interval = 1000000 * logInterval
-      withFile statsFilePath AppendMode $ \h -> liftIO $ do
-        hSetBuffering h LineBuffering
-        forever $ do
-          ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          tknCreated' <- atomically $ swapTVar tknCreated 0
-          tknVerified' <- atomically $ swapTVar tknVerified 0
-          tknDeleted' <- atomically $ swapTVar tknDeleted 0
-          subCreated' <- atomically $ swapTVar subCreated 0
-          subDeleted' <- atomically $ swapTVar subDeleted 0
-          ntfReceived' <- atomically $ swapTVar ntfReceived 0
-          ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
-          tkn <- atomically $ periodStatCounts activeTokens ts
-          sub <- atomically $ periodStatCounts activeSubs ts
-          hPutStrLn h $
-            intercalate
-              ","
-              [ iso8601Show $ utctDay fromTime',
-                show tknCreated',
-                show tknVerified',
-                show tknDeleted',
-                show subCreated',
-                show subDeleted',
-                show ntfReceived',
-                show ntfDelivered',
-                dayCount tkn,
-                weekCount tkn,
-                monthCount tkn,
-                dayCount sub,
-                weekCount sub,
-                monthCount sub
-              ]
-          threadDelay interval
-
-resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
-resubscribe NtfSubscriber {newSubQ} subs = do
-  d <- asks $ resubscribeDelay . config
-  forM_ subs $ \sub@NtfSubData {} ->
-    whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
-      atomically $ writeTBQueue newSubQ $ NtfSub sub
-      threadDelay d
-  liftIO $ logInfo "SMP connections resubscribed"
-
-ntfSubscriber :: NtfSubscriber -> M ()
-ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
-  raceAny_ [subscribe, receiveSMP, receiveAgent]
-  where
-    subscribe :: M ()
-    subscribe =
-      forever $
-        atomically (readTBQueue newSubQ) >>= \case
-          sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
-            SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
-            atomically $ writeTQueue subscriberSubQ sub
-
-    getSMPSubscriber :: SMPServer -> M SMPSubscriber
-    getSMPSubscriber smpServer =
-      atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
-      where
-        createSMPSubscriber = do
-          sub@SMPSubscriber {subThreadId} <- atomically newSMPSubscriber
-          atomically $ TM.insert smpServer sub smpSubscribers
-          tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub)
-          atomically . writeTVar subThreadId $ Just tId
-          pure sub
-
-    runSMPSubscriber :: SMPSubscriber -> M ()
-    runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
-      forever $
-        atomically (peekTQueue subscriberSubQ)
-          >>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
-            updateSubStatus smpQueue NSPending
-            let SMPQueueNtf {smpServer, notifierId} = smpQueue
-            liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
-              Right _ -> do
-                updateSubStatus smpQueue NSActive
-                void . atomically $ readTQueue subscriberSubQ
-              Left err -> do
-                handleSubError smpQueue err
-                case err of
-                  PCEResponseTimeout -> pure ()
-                  PCENetworkError -> pure ()
-                  _ -> void . atomically $ readTQueue subscriberSubQ
-
-    receiveSMP :: M ()
-    receiveSMP = forever $ do
-      (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
-      let smpQueue = SMPQueueNtf srv ntfId
-      case msg of
-        SMP.NMSG nmsgNonce encNMsgMeta -> do
-          ntfTs <- liftIO getSystemTime
-          st <- asks store
-          NtfPushServer {pushQ} <- asks pushServer
-          stats <- asks serverStats
-          atomically $ updatePeriodStats (activeSubs stats) ntfId
-          atomically $
-            findNtfSubscriptionToken st smpQueue
-              >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
-          incNtfStat ntfReceived
-        SMP.END -> updateSubStatus smpQueue NSEnd
-        _ -> pure ()
-
-    receiveAgent =
-      forever $
-        atomically (readTBQueue agentQ) >>= \case
-          CAConnected _ -> pure ()
-          CADisconnected srv subs -> do
-            logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
-            forM_ subs $ \(_, ntfId) -> do
-              let smpQueue = SMPQueueNtf srv ntfId
-              updateSubStatus smpQueue NSInactive
-          CAReconnected srv ->
-            logInfo $ "SMP server reconnected " <> showServer' srv
-          CAResubscribed srv sub -> do
-            let ntfId = snd sub
-                smpQueue = SMPQueueNtf srv ntfId
-            updateSubStatus smpQueue NSActive
-          CASubError srv (_, ntfId) err -> do
-            logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
-            handleSubError (SMPQueueNtf srv ntfId) err
-      where
-        showServer' = decodeLatin1 . strEncode . host
-
-    handleSubError :: SMPQueueNtf -> ProtocolClientError -> M ()
-    handleSubError smpQueue = \case
-      PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
-      PCEProtocolError e -> updateErr "SMP error " e
-      PCEIOError e -> updateErr "IOError " e
-      PCEResponseError e -> updateErr "ResponseError " e
-      PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
-      PCETransportError e -> updateErr "TransportError " e
-      PCESignatureError e -> updateErr "SignatureError " e
-      PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
-      PCEResponseTimeout -> pure ()
-      PCENetworkError -> pure ()
-      where
-        updateErr :: Show e => ByteString -> e -> M ()
-        updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
-
-    updateSubStatus smpQueue status = do
-      st <- asks store
-      atomically (findNtfSubscription st smpQueue)
-        >>= mapM_
-          ( \NtfSubData {ntfSubId, subStatus} -> do
-              atomically $ writeTVar subStatus status
-              withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status
-          )
-
-ntfPush :: NtfPushServer -> M ()
-ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
-  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
-  status <- readTVarIO tknStatus
-  case (status, ntf) of
-    (_, PNVerification _) ->
-      -- TODO check token status
-      deliverNotification pp tkn ntf >>= \case
-        Right _ -> do
-          status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
-          forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
-        _ -> pure ()
-    (NTActive, PNCheckMessages) ->
-      void $ deliverNotification pp tkn ntf
-    (NTActive, PNMessage {}) -> do
-      stats <- asks serverStats
-      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
-      void $ deliverNotification pp tkn ntf
-      incNtfStat ntfDelivered
-    _ ->
-      liftIO $ logError "bad notification token status"
-  where
-    deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ())
-    deliverNotification pp tkn@NtfTknData {ntfTknId, tknStatus} ntf = do
-      deliver <- liftIO $ getPushClient s pp
-      liftIO (runExceptT $ deliver tkn ntf) >>= \case
-        Right _ -> pure $ Right ()
-        Left e -> case e of
-          PPConnection _ -> retryDeliver
-          PPRetryLater -> retryDeliver
-          -- TODO alert
-          PPCryptoError _ -> err e
-          PPResponseError _ _ -> err e
-          PPTokenInvalid -> updateTknStatus NTInvalid >> 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)
-        updateTknStatus :: NtfTknStatus -> M ()
-        updateTknStatus status = do
-          atomically $ writeTVar tknStatus status
-          withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
-        err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
-
-runNtfClientTransport :: Transport c => THandle c -> M ()
-runNtfClientTransport th@THandle {sessionId} = do
-  qSize <- asks $ clientQSize . config
-  ts <- liftIO getSystemTime
-  c <- atomically $ newNtfServerClient qSize sessionId ts
-  s <- asks subscriber
-  ps <- asks pushServer
-  expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
-    `finally` liftIO (clientDisconnected c)
-  where
-    disconnectThread_ c expCfg = maybe [] ((: []) . liftIO . disconnectTransport th c activeAt) expCfg
-
-clientDisconnected :: NtfServerClient -> IO ()
-clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
-
-receive :: Transport c => THandle c -> NtfServerClient -> M ()
-receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- tGet th
-  forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
-    atomically . writeTVar activeAt =<< liftIO getSystemTime
-    logDebug "received transmission"
-    case cmdOrError of
-      Left e -> write sndQ (corrId, entId, NRErr e)
-      Right cmd ->
-        verifyNtfTransmission t cmd >>= \case
-          VRVerified req -> write rcvQ req
-          VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
-  where
-    write q t = atomically $ writeTBQueue q t
-
-send :: Transport c => THandle c -> NtfServerClient -> IO ()
-send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
-  t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-
--- instance Show a => Show (TVar a) where
---   show x = unsafePerformIO $ show <$> readTVarIO x
-
-data VerificationResult = VRVerified NtfRequest | VRFailed
-
-verifyNtfTransmission :: SignedTransmission NtfCmd -> NtfCmd -> M VerificationResult
-verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
-  st <- asks store
-  case cmd of
-    NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do
-      r_ <- atomically $ getNtfTokenRegistration st tkn
-      pure $
-        if verifyCmdSignature sig_ signed k
-          then case r_ of
-            Just t@NtfTknData {tknVerifyKey}
-              | k == tknVerifyKey -> verifiedTknCmd t c
-              | otherwise -> VRFailed
-            _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn))
-          else VRFailed
-    NtfCmd SToken c -> do
-      t_ <- atomically $ getNtfToken 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
-          -- TODO move active token check here to differentiate error
-          t_ <- atomically $ getActiveNtfToken st tknId
-          verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
-        Just s@NtfSubData {tokenId = subTknId} ->
-          if subTknId == tknId
-            then do
-              -- TODO move active token check here to differentiate error
-              t_ <- atomically $ getActiveNtfToken st subTknId
-              verifyToken' t_ $ verifiedSubCmd s c
-            else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    NtfCmd SSubscription c -> do
-      s_ <- atomically $ getNtfSubscription st entId
-      case s_ of
-        Just s@NtfSubData {tokenId = subTknId} -> do
-          -- TODO move active token check here to differentiate error
-          t_ <- atomically $ getActiveNtfToken st subTknId
-          verifyToken' t_ $ verifiedSubCmd s c
-        _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `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))
-    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult
-    verifyToken t_ positiveVerificationResult =
-      pure $ case t_ of
-        Just t@NtfTknData {tknVerifyKey} ->
-          if verifyCmdSignature sig_ signed tknVerifyKey
-            then positiveVerificationResult t
-            else VRFailed
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult
-    verifyToken' t_ = verifyToken t_ . const
-
-client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
-client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
-  forever $
-    atomically (readTBQueue rcvQ)
-      >>= processCommand
-      >>= atomically . writeTBQueue sndQ
-  where
-    processCommand :: NtfRequest -> M (Transmission NtfResponse)
-    processCommand = \case
-      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
-        logDebug "TNEW - new token"
-        st <- asks store
-        ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
-        let dhSecret = C.dh' dhPubKey srvDhPrivKey
-        tknId <- getId
-        regCode <- getRegCode
-        tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode
-        atomically $ addNtfToken st tknId tkn
-        atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
-        withNtfLog (`logCreateToken` tkn)
-        incNtfStat tknCreated
-        pure (corrId, "", NRTknId tknId srvDhPubKey)
-      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
-        status <- readTVarIO tknStatus
-        (corrId,tknId,) <$> case cmd of
-          TNEW (NewNtfTkn _ _ dhPubKey) -> do
-            logDebug "TNEW - registered token"
-            let dhSecret = C.dh' dhPubKey srvDhPrivKey
-            -- it is required that DH secret is the same, to avoid failed verifications if notification is delaying
-            if tknDhSecret == dhSecret
-              then do
-                atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
-                pure $ NRTknId ntfTknId srvDhPubKey
-              else pure $ NRErr AUTH
-          TVFY code -- this allows repeated verification for cases when client connection dropped before server response
-            | (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
-              logDebug "TVFY - token verified"
-              st <- asks store
-              atomically $ writeTVar tknStatus NTActive
-              tIds <- atomically $ removeInactiveTokenRegistrations st tkn
-              forM_ tIds cancelInvervalNotifications
-              withNtfLog $ \s -> logTokenStatus s tknId NTActive
-              incNtfStat tknVerified
-              pure NROk
-            | otherwise -> do
-              logDebug "TVFY - incorrect code or token status"
-              pure $ NRErr AUTH
-          TCHK -> do
-            logDebug "TCHK"
-            pure $ NRTkn status
-          TRPL token' -> do
-            logDebug "TRPL - replace token"
-            st <- asks store
-            regCode <- getRegCode
-            atomically $ do
-              removeTokenRegistration st tkn
-              writeTVar tknStatus NTRegistered
-              let tkn' = tkn {token = token', tknRegCode = regCode}
-              addNtfToken st tknId tkn'
-              writeTBQueue pushQ (tkn', PNVerification regCode)
-            withNtfLog $ \s -> logUpdateToken s tknId token' regCode
-            incNtfStat tknDeleted
-            incNtfStat tknCreated
-            pure NROk
-          TDEL -> do
-            logDebug "TDEL"
-            st <- asks store
-            qs <- atomically $ deleteNtfToken st tknId
-            forM_ qs $ \SMPQueueNtf {smpServer, notifierId} ->
-              atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
-            cancelInvervalNotifications tknId
-            withNtfLog (`logDeleteToken` tknId)
-            incNtfStat tknDeleted
-            pure NROk
-          TCRN 0 -> do
-            logDebug "TCRN 0"
-            atomically $ writeTVar tknCronInterval 0
-            cancelInvervalNotifications tknId
-            withNtfLog $ \s -> logTokenCron s tknId 0
-            pure NROk
-          TCRN int
-            | int < 20 -> pure $ NRErr QUOTA
-            | otherwise -> do
-              logDebug "TCRN"
-              atomically $ writeTVar tknCronInterval int
-              atomically (TM.lookup tknId intervalNotifiers) >>= \case
-                Nothing -> runIntervalNotifier int
-                Just IntervalNotifier {interval, action} ->
-                  unless (interval == int) $ do
-                    uninterruptibleCancel action
-                    runIntervalNotifier int
-              withNtfLog $ \s -> logTokenCron s tknId int
-              pure NROk
-            where
-              runIntervalNotifier interval = do
-                action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
-                let notifier = IntervalNotifier {action, token = tkn, interval}
-                atomically $ TM.insert tknId notifier intervalNotifiers
-                where
-                  intervalNotifier delay = forever $ do
-                    threadDelay delay
-                    atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
-      NtfReqNew corrId (ANE SSubscription newSub) -> do
-        logDebug "SNEW - new subscription"
-        st <- asks store
-        subId <- getId
-        sub <- atomically $ mkNtfSubData subId newSub
-        resp <-
-          atomically (addNtfSubscription st subId sub) >>= \case
-            Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
-            _ -> pure $ NRErr AUTH
-        withNtfLog (`logCreateSubscription` sub)
-        incNtfStat subCreated
-        pure (corrId, "", resp)
-      NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
-        status <- readTVarIO subStatus
-        (corrId,subId,) <$> case cmd of
-          SNEW (NewNtfSub _ _ notifierKey) -> do
-            logDebug "SNEW - existing subscription"
-            -- TODO retry if subscription failed, if pending or AUTH do nothing
-            pure $
-              if notifierKey == registeredNKey
-                then NRSubId subId
-                else NRErr AUTH
-          SCHK -> do
-            logDebug "SCHK"
-            pure $ NRSub status
-          SDEL -> do
-            logDebug "SDEL"
-            st <- asks store
-            atomically $ deleteNtfSubscription st subId
-            atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
-            withNtfLog (`logDeleteSubscription` subId)
-            incNtfStat subDeleted
-            pure NROk
-          PING -> pure NRPong
-    getId :: M NtfEntityId
-    getId = getRandomBytes =<< asks (subIdBytes . config)
-    getRegCode :: M NtfRegCode
-    getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
-    getRandomBytes :: Int -> M ByteString
-    getRandomBytes n = do
-      gVar <- asks idsDrg
-      atomically (C.pseudoRandomBytes n gVar)
-    cancelInvervalNotifications :: NtfTokenId -> M ()
-    cancelInvervalNotifications tknId =
-      atomically (TM.lookupDelete tknId intervalNotifiers)
-        >>= mapM_ (uninterruptibleCancel . action)
-
-withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
-withNtfLog action = liftIO . mapM_ action =<< asks storeLog
-
-incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
-incNtfStat statSel = do
-  stats <- asks serverStats
-  atomically $ modifyTVar (statSel stats) (+ 1)
-
-saveServerStats :: M ()
-saveServerStats =
-  asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
-  where
-    saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
-      B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
-
-restoreServerStats :: M ()
-restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
-  where
-    restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
-      liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d -> do
-          s <- asks serverStats
-          atomically $ setNtfServerStats s d
-          renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
-        Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
-          liftIO exitFailure

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

@@ -1,165 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Notifications.Server.Env where
-
-import Control.Concurrent (ThreadId)
-import Control.Concurrent.Async (Async)
-import Control.Monad.IO.Unlift
-import Crypto.Random
-import Data.ByteString.Char8 (ByteString)
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock.System (SystemTime)
-import Data.Word (Word16)
-import Data.X509.Validation (Fingerprint (..))
-import Network.Socket
-import qualified Network.TLS as T
-import Numeric.Natural
-import Simplex.Messaging.Client.Agent
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Server.Stats
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Notifications.Server.StoreLog
-import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport)
-import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
-import System.IO (IOMode (..))
-import System.Mem.Weak (Weak)
-import UnliftIO.STM
-
-data NtfServerConfig = NtfServerConfig
-  { transports :: [(ServiceName, ATransport)],
-    subIdBytes :: Int,
-    regCodeBytes :: Int,
-    clientQSize :: Natural,
-    subQSize :: Natural,
-    pushQSize :: Natural,
-    smpAgentCfg :: SMPClientAgentConfig,
-    apnsConfig :: APNSPushClientConfig,
-    inactiveClientExpiration :: Maybe ExpirationConfig,
-    storeLogFile :: Maybe FilePath,
-    resubscribeDelay :: Int, -- microseconds
-    -- CA certificate private key is not needed for initialization
-    caCertificateFile :: FilePath,
-    privateKeyFile :: FilePath,
-    certificateFile :: FilePath,
-    -- stats config - see SMP server config
-    logStatsInterval :: Maybe Int,
-    logStatsStartTime :: Int,
-    serverStatsLogFile :: FilePath,
-    serverStatsBackupFile :: Maybe FilePath
-  }
-
-defaultInactiveClientExpiration :: ExpirationConfig
-defaultInactiveClientExpiration =
-  ExpirationConfig
-    { ttl = 7200, -- 2 hours
-      checkInterval = 3600 -- seconds, 1 hour
-    }
-
-data NtfEnv = NtfEnv
-  { config :: NtfServerConfig,
-    subscriber :: NtfSubscriber,
-    pushServer :: NtfPushServer,
-    store :: NtfStore,
-    storeLog :: Maybe (StoreLog 'WriteMode),
-    idsDrg :: TVar ChaChaDRG,
-    serverIdentity :: C.KeyHash,
-    tlsServerParams :: T.ServerParams,
-    serverIdentity :: C.KeyHash,
-    serverStats :: NtfServerStats
-  }
-
-newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
-  idsDrg <- newTVarIO =<< drgNew
-  store <- atomically newNtfStore
-  storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
-  subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
-  pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
-  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
-  serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
-  pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
-
-data NtfSubscriber = NtfSubscriber
-  { smpSubscribers :: TMap SMPServer SMPSubscriber,
-    newSubQ :: TBQueue (NtfEntityRec 'Subscription),
-    smpAgent :: SMPClientAgent
-  }
-
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
-newNtfSubscriber qSize smpAgentCfg = do
-  smpSubscribers <- TM.empty
-  newSubQ <- newTBQueue qSize
-  smpAgent <- newSMPClientAgent smpAgentCfg
-  pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
-
-data SMPSubscriber = SMPSubscriber
-  { newSubQ :: TQueue (NtfEntityRec 'Subscription),
-    subThreadId :: TVar (Maybe (Weak ThreadId))
-  }
-
-newSMPSubscriber :: STM SMPSubscriber
-newSMPSubscriber = do
-  newSubQ <- newTQueue
-  subThreadId <- newTVar Nothing
-  pure SMPSubscriber {newSubQ, subThreadId}
-
-data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (NtfTknData, PushNotification),
-    pushClients :: TMap PushProvider PushProviderClient,
-    intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
-    apnsConfig :: APNSPushClientConfig
-  }
-
-data IntervalNotifier = IntervalNotifier
-  { action :: Async (),
-    token :: NtfTknData,
-    interval :: Word16
-  }
-
-newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
-newNtfPushServer qSize apnsConfig = do
-  pushQ <- newTBQueue qSize
-  pushClients <- TM.empty
-  intervalNotifiers <- TM.empty
-  pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
-
-newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  c <- apnsPushProviderClient <$> createAPNSPushClient (apnsProviderHost pp) apnsConfig
-  atomically $ TM.insert pp c pushClients
-  pure c
-
-getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-getPushClient s@NtfPushServer {pushClients} pp =
-  atomically (TM.lookup pp pushClients) >>= maybe (newPushClient s pp) pure
-
-data NtfRequest
-  = NtfReqNew CorrId ANewNtfEntity
-  | forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
-
-data NtfServerClient = NtfServerClient
-  { rcvQ :: TBQueue NtfRequest,
-    sndQ :: TBQueue (Transmission NtfResponse),
-    sessionId :: ByteString,
-    connected :: TVar Bool,
-    activeAt :: TVar SystemTime
-  }
-
-newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
-newNtfServerClient qSize sessionId ts = do
-  rcvQ <- newTBQueue qSize
-  sndQ <- newTBQueue qSize
-  connected <- newTVar True
-  activeAt <- newTVar ts
-  return NtfServerClient {rcvQ, sndQ, sessionId, connected, activeAt}

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

@@ -1,169 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Simplex.Messaging.Notifications.Server.Main where
-
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
-import Network.Socket (HostName)
-import Options.Applicative
-import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Server (runNtfServer)
-import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
-import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
-import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Transport.Client (TransportHost (..))
-import System.Directory (createDirectoryIfMissing, doesFileExist)
-import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
-import Text.Read (readMaybe)
-
-ntfServerCLI :: FilePath -> FilePath -> IO ()
-ntfServerCLI cfgPath logPath =
-  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
-    Init opts ->
-      doesFileExist iniFile >>= \case
-        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
-        _ -> initializeServer opts
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-      deleteDirIfExists cfgPath
-      deleteDirIfExists logPath
-      putStrLn "Deleted configuration and log files"
-  where
-    iniFile = combine cfgPath "ntf-server.ini"
-    serverVersion = "SMP notifications server v1.2.0"
-    defaultServerPort = "443"
-    executableName = "ntf-server"
-    storeLogFilePath = combine logPath "ntf-server-store.log"
-    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
-      clearDirIfExists cfgPath
-      clearDirIfExists logPath
-      createDirectoryIfMissing True cfgPath
-      createDirectoryIfMissing True logPath
-      let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
-      fp <- createServerX509 cfgPath x509cfg
-      let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
-      writeFile iniFile $ iniFileContent host
-      putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
-      warnCAPrivateKeyFile cfgPath x509cfg
-      printServiceInfo serverVersion srv
-      where
-        iniFileContent host =
-          "[STORE_LOG]\n\
-          \# The server uses STM memory for persistence,\n\
-          \# that will be lost on restart (e.g., as with redis).\n\
-          \# This option enables saving memory to append only log,\n\
-          \# and restoring it when the server is started.\n\
-          \# Log is compacted on start (deleted objects are removed).\n"
-            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-            <> "log_stats: off\n\n"
-            <> "[TRANSPORT]\n"
-            <> "# host is only used to print server address on start\n"
-            <> ("host: " <> host <> "\n")
-            <> ("port: " <> defaultServerPort <> "\n")
-            <> "websockets: off\n"
-    runServer ini = do
-      hSetBuffering stdout LineBuffering
-      hSetBuffering stderr LineBuffering
-      fp <- checkSavedFingerprint cfgPath defaultX509Config
-      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
-          port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
-          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
-      printServiceInfo serverVersion srv
-      printServerConfig transports storeLogFile
-      runNtfServer cfg
-      where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-        logStats = settingIsOn "STORE_LOG" "log_stats" ini
-        c = combine cfgPath . ($ defaultX509Config)
-        serverConfig =
-          NtfServerConfig
-            { transports = iniTransports ini,
-              subIdBytes = 24,
-              regCodeBytes = 32,
-              clientQSize = 16,
-              subQSize = 64,
-              pushQSize = 128,
-              smpAgentCfg = defaultSMPClientAgentConfig,
-              apnsConfig = defaultAPNSPushClientConfig,
-              inactiveClientExpiration = Nothing,
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              resubscribeDelay = 50000, -- 50ms
-              caCertificateFile = c caCrtFile,
-              privateKeyFile = c serverKeyFile,
-              certificateFile = c serverCrtFile,
-              logStatsInterval = logStats $> 86400, -- seconds
-              logStatsStartTime = 0, -- seconds from 00:00 UTC
-              serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
-              serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log"
-            }
-
-data CliCommand
-  = Init InitOptions
-  | Start
-  | Delete
-
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName
-  }
-  deriving (Show)
-
-cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
-cliCommandP cfgPath logPath iniFile =
-  hsubparser
-    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
-        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
-    )
-  where
-    initP :: Parser InitOptions
-    initP =
-      InitOptions
-        <$> switch
-          ( long "store-log"
-              <> short 'l'
-              <> help "Enable store log for persistence"
-          )
-        <*> option
-          (maybeReader readMaybe)
-          ( long "sign-algorithm"
-              <> short 'a'
-              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
-              <> value ED448
-              <> showDefault
-              <> metavar "ALG"
-          )
-        <*> strOption
-          ( long "ip"
-              <> help
-                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
-              <> value "127.0.0.1"
-              <> showDefault
-              <> metavar "IP"
-          )
-        <*> (optional . strOption)
-          ( long "fqdn"
-              <> short 'n'
-              <> help "Server FQDN used as Common Name for TLS online certificate"
-              <> showDefault
-              <> metavar "FQDN"
-          )

src/Simplex/Messaging/Notifications/Server/Push/.gitignore

@@ -1 +0,0 @@
-local.env

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

@@ -1,373 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use newtype instead of data" #-}
-
-module Simplex.Messaging.Notifications.Server.Push.APNS where
-
-import Control.Exception (Exception)
-import Control.Logger.Simple
-import Control.Monad.Except
-import Crypto.Hash.Algorithms (SHA256 (..))
-import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
-import Crypto.Random (ChaChaDRG, drgNew)
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
-import Data.Aeson (FromJSON, ToJSON, (.=))
-import qualified Data.Aeson as J
-import qualified Data.Aeson.Encoding as JE
-import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as U
-import Data.ByteString.Builder (lazyByteString)
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
-import qualified Data.CaseInsensitive as CI
-import Data.Int (Int64)
-import Data.Map.Strict (Map)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock.System
-import qualified Data.X509 as X
-import GHC.Generics (Generic)
-import Network.HTTP.Types (HeaderName, Status)
-import qualified Network.HTTP.Types as N
-import Network.HTTP2.Client (Request)
-import qualified Network.HTTP2.Client as H
-import Network.Socket (HostName, ServiceName)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
-import Simplex.Messaging.Protocol (EncNMsgMeta)
-import Simplex.Messaging.Transport.HTTP2.Client
-import Simplex.Messaging.Util (safeDecodeUtf8)
-import System.Environment (getEnv)
-import UnliftIO.STM
-
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show, Generic)
-
-instance ToJSON JWTHeader where toEncoding = J.genericToEncoding J.defaultOptions
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show, Generic)
-
-instance ToJSON JWTClaims where toEncoding = J.genericToEncoding J.defaultOptions
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- TODO this is specific to APNS key
-  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
-  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
-
-data PushNotification
-  = PNVerification NtfRegCode
-  | PNMessage PNMessageData
-  | PNAlert Text
-  | PNCheckMessages
-  deriving (Show)
-
-data PNMessageData = PNMessageData
-  { smpQueue :: SMPQueueNtf,
-    ntfTs :: SystemTime,
-    nmsgNonce :: C.CbNonce,
-    encNMsgMeta :: EncNMsgMeta
-  }
-  deriving (Show)
-
-instance StrEncoding PNMessageData where
-  strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
-    strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
-  strP = do
-    (smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
-    pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
-
-data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
-  deriving (Show, Generic)
-
-instance ToJSON APNSNotification where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-data APNSNotificationBody
-  = APNSBackground {contentAvailable :: Int}
-  | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text}
-  | APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
-  deriving (Show, Generic)
-
-apnsJSONOptions :: J.Options
-apnsJSONOptions = J.defaultOptions {J.omitNothingFields = True, J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'}
-
-instance ToJSON APNSNotificationBody where
-  toJSON = J.genericToJSON apnsJSONOptions
-  toEncoding = J.genericToEncoding apnsJSONOptions
-
-type APNSNotificationData = Map Text Text
-
-data APNSAlertBody = APNSAlertObject {title :: Text, subtitle :: Text, body :: Text} | APNSAlertText Text
-  deriving (Show)
-
-instance ToJSON APNSAlertBody where
-  toEncoding = \case
-    APNSAlertObject {title, subtitle, body} -> J.pairs $ "title" .= title <> "subtitle" .= subtitle <> "body" .= body
-    APNSAlertText t -> JE.text t
-  toJSON = \case
-    APNSAlertObject {title, subtitle, body} -> J.object ["title" .= title, "subtitle" .= subtitle, "body" .= body]
-    APNSAlertText t -> J.String t
-
--- APNS notification types
---
--- Visible alerts:
--- {
---    "aps" : {
---       "alert" : {
---          "title" : "Game Request",
---          "subtitle" : "Five Card Draw",
---          "body" : "Bob wants to play poker"
---       },
---       "badge" : 9,
---       "sound" : "bingbong.aiff",
---       "category" : "GAME_INVITATION"
---    },
---    "gameID" : "12345678"
--- }
---
--- Simple text alert:
--- {"aps":{"alert":"you have a new message"}}
---
--- Background notification to fetch content
--- {"aps":{"content-available":1}}
---
--- Mutable content notification that must be shown but can be processed before before being shown (up to 30 sec)
--- {
---    "aps" : {
---       "category" : "SECRET",
---       "mutable-content" : 1,
---       "alert" : {
---          "title" : "Secret Message!",
---          "body"  : "(Encrypted)"
---      },
---    },
---    "ENCRYPTED_DATA" : "Salted__·öîQÊ$UDì_¶Ù∞èΩ^¬%gq∞NÿÒQùw"
--- }
-
-data APNSPushClientConfig = APNSPushClientConfig
-  { tokenTTL :: Int64,
-    authKeyFileEnv :: String,
-    authKeyAlg :: Text,
-    authKeyIdEnv :: String,
-    paddedNtfLength :: Int,
-    appName :: ByteString,
-    appTeamId :: Text,
-    apnsPort :: ServiceName,
-    http2cfg :: HTTP2ClientConfig
-  }
-  deriving (Show)
-
-apnsProviderHost :: PushProvider -> HostName
-apnsProviderHost = \case
-  PPApnsTest -> "localhost"
-  PPApnsDev -> "api.sandbox.push.apple.com"
-  PPApnsProd -> "api.push.apple.com"
-
-defaultAPNSPushClientConfig :: APNSPushClientConfig
-defaultAPNSPushClientConfig =
-  APNSPushClientConfig
-    { tokenTTL = 1800, -- 30 minutes
-      authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
-      authKeyAlg = "ES256",
-      authKeyIdEnv = "APNS_KEY_ID",
-      paddedNtfLength = 512,
-      appName = "chat.simplex.app",
-      appTeamId = "5NN7GUYB6T",
-      apnsPort = "443",
-      http2cfg = defaultHTTP2ClientConfig
-    }
-
-data APNSPushClient = APNSPushClient
-  { https2Client :: TVar (Maybe HTTP2Client),
-    privateKey :: EC.PrivateKey,
-    jwtHeader :: JWTHeader,
-    jwtToken :: TVar (JWTToken, SignedJWTToken),
-    nonceDrg :: TVar ChaChaDRG,
-    apnsHost :: HostName,
-    apnsCfg :: APNSPushClientConfig
-  }
-
-createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
-createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
-  https2Client <- newTVarIO Nothing
-  void $ connectHTTPS2 apnsHost apnsCfg https2Client
-  privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
-  authKeyId <- T.pack <$> getEnv authKeyIdEnv
-  let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
-  jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
-  nonceDrg <- drgNew >>= newTVarIO
-  pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
-
-getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
-getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do
-  (jwt, signedJWT) <- readTVarIO jwtToken
-  age <- jwtTokenAge jwt
-  if age < tokenTTL
-    then pure signedJWT
-    else do
-      t@(_, signedJWT') <- mkApnsJWTToken appTeamId jwtHeader privateKey
-      atomically $ writeTVar jwtToken t
-      pure signedJWT'
-  where
-    jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
-
-mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
-mkApnsJWTToken appTeamId jwtHeader privateKey = do
-  jwt <- mkJWTToken jwtHeader appTeamId
-  signedJWT <- signedJWTToken privateKey jwt
-  pure (jwt, signedJWT)
-
-connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
-connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
-  r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
-  case r of
-    Right client -> atomically . writeTVar https2Client $ Just client
-    Left e -> putStrLn $ "Error connecting to APNS: " <> show e
-  pure r
-  where
-    disconnected = atomically $ writeTVar https2Client Nothing
-
-getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
-getApnsHTTP2Client APNSPushClient {https2Client, apnsHost, apnsCfg} =
-  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsHost apnsCfg https2Client) (pure . Right)
-
-disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
-disconnectApnsHTTP2Client APNSPushClient {https2Client} =
-  readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
-
-ntfCategoryCheckMessage :: Text
-ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
-
-apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
-apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
-  PNVerification (NtfRegCode code) ->
-    encrypt code $ \code' ->
-      apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
-  PNMessage pnMessageData ->
-    encrypt (strEncode pnMessageData) $ \ntfData ->
-      apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
-  PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
-  PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
-  where
-    encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
-    encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
-    apn aps notificationData = APNSNotification {aps, notificationData}
-    apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or another app event", category = Just ntfCategoryCheckMessage}
-    apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
-
-apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
-apnsRequest c tkn ntf@APNSNotification {aps} = do
-  signedJWT <- getApnsJWTToken c
-  pure $ H.requestBuilder N.methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf)
-  where
-    path = "/3/device/" <> tkn
-    headers signedJWT =
-      [ (hApnsTopic, appName $ apnsCfg (c :: APNSPushClient)),
-        (hApnsPushType, pushType aps),
-        (N.hAuthorization, "bearer " <> signedJWT)
-      ]
-        <> [(hApnsPriority, "5") | isBackground aps]
-    isBackground = \case
-      APNSBackground {} -> True
-      _ -> False
-    pushType = \case
-      APNSBackground {} -> "background"
-      _ -> "alert"
-
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid
-  | PPRetryLater
-  | PPPermanentError
-  deriving (Show, Exception)
-
-type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
-
--- this is not a newtype on purpose to have a correct JSON encoding as a record
-data APNSErrorResponse = APNSErrorResponse {reason :: Text}
-  deriving (Generic, FromJSON)
-
-apnsPushProviderClient :: APNSPushClient -> PushProviderClient
-apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
-  http2 <- liftHTTPS2 $ getApnsHTTP2Client c
-  nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
-  apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
-  req <- liftIO $ apnsRequest c tknStr apnsNtf
-  HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
-  let status = H.responseStatus response
-      reason' = maybe "" reason $ J.decodeStrict' respBody
-  logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
-  result status reason'
-  where
-    result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
-    result status reason'
-      | status == Just N.ok200 = pure ()
-      | status == Just N.badRequest400 =
-        case reason' of
-          "BadDeviceToken" -> throwError PPTokenInvalid
-          "DeviceTokenNotForTopic" -> throwError PPTokenInvalid
-          "TopicDisallowed" -> throwError PPPermanentError
-          _ -> err status reason'
-      | status == Just N.forbidden403 = case reason' of
-        "ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
-        "InvalidProviderToken" -> throwError PPPermanentError
-        _ -> err status reason'
-      | status == Just N.gone410 = throwError PPTokenInvalid
-      | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-      -- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token
-      | otherwise = err status reason'
-    err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
-    err s r = throwError $ PPResponseError s r
-    liftHTTPS2 a = ExceptT $ first PPConnection <$> a
-
-hApnsTopic :: HeaderName
-hApnsTopic = CI.mk "apns-topic"
-
-hApnsPushType :: HeaderName
-hApnsPushType = CI.mk "apns-push-type"
-
-hApnsPriority :: HeaderName
-hApnsPriority = CI.mk "apns-priority"

src/Simplex/Messaging/Notifications/Server/Push/testpush.sh

@@ -1,26 +0,0 @@
-#!/bin/sh
-
-export TEAM_ID=5NN7GUYB6T
-# export APNS_KEY_FILE=""
-# export APNS_KEY_ID=""
-export TOPIC=chat.simplex.app
-# export DEVICE_TOKEN=
-export APNS_HOST_NAME=api.sandbox.push.apple.com
-
-export JWT_ISSUE_TIME=$(date +%s)
-export JWT_HEADER=$(printf '{"alg":"ES256","kid":"%s"}' "${APNS_KEY_ID}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export JWT_CLAIMS=$(printf '{"iss":"%s","iat":%d}' "${TEAM_ID}" "${JWT_ISSUE_TIME}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export JWT_HEADER_CLAIMS="${JWT_HEADER}.${JWT_CLAIMS}"
-
-export JWT_SIGNED_HEADER_CLAIMS=$(printf "${JWT_HEADER_CLAIMS}" | openssl dgst -binary -sha256 -sign "${APNS_KEY_FILE}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
-export AUTHENTICATION_TOKEN="${JWT_HEADER}.${JWT_CLAIMS}.${JWT_SIGNED_HEADER_CLAIMS}"
-
-# simple alert
-# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"},"data":{"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
-
-# background notification
-# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: background" --header "apns-priority: 5" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"content-available":1}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
-
-# mutable-content notification
-# NTF_CAT_CHECK_MESSAGE category will not show alert if the app is in foreground
-curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"category": "NTF_CAT_CHECK_MESSAGE__SECRET", "mutable-content": 1, "alert":"received encrypted message"}, "data": {"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}

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

@@ -1,113 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Server.Stats where
-
-import Control.Applicative (optional)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Time.Clock (UTCTime)
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
-import Simplex.Messaging.Protocol (NotifierId)
-import Simplex.Messaging.Server.Stats
-import UnliftIO.STM
-
-data NtfServerStats = NtfServerStats
-  { fromTime :: TVar UTCTime,
-    tknCreated :: TVar Int,
-    tknVerified :: TVar Int,
-    tknDeleted :: TVar Int,
-    subCreated :: TVar Int,
-    subDeleted :: TVar Int,
-    ntfReceived :: TVar Int,
-    ntfDelivered :: TVar Int,
-    activeTokens :: PeriodStats NtfTokenId,
-    activeSubs :: PeriodStats NotifierId
-  }
-
-data NtfServerStatsData = NtfServerStatsData
-  { _fromTime :: UTCTime,
-    _tknCreated :: Int,
-    _tknVerified :: Int,
-    _tknDeleted :: Int,
-    _subCreated :: Int,
-    _subDeleted :: Int,
-    _ntfReceived :: Int,
-    _ntfDelivered :: Int,
-    _activeTokens :: PeriodStatsData NtfTokenId,
-    _activeSubs :: PeriodStatsData NotifierId
-  }
-
-newNtfServerStats :: UTCTime -> STM NtfServerStats
-newNtfServerStats ts = do
-  fromTime <- newTVar ts
-  tknCreated <- newTVar 0
-  tknVerified <- newTVar 0
-  tknDeleted <- newTVar 0
-  subCreated <- newTVar 0
-  subDeleted <- newTVar 0
-  ntfReceived <- newTVar 0
-  ntfDelivered <- newTVar 0
-  activeTokens <- newPeriodStats
-  activeSubs <- newPeriodStats
-  pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
-
-getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
-getNtfServerStatsData s = do
-  _fromTime <- readTVar $ fromTime (s :: NtfServerStats)
-  _tknCreated <- readTVar $ tknCreated s
-  _tknVerified <- readTVar $ tknVerified s
-  _tknDeleted <- readTVar $ tknDeleted s
-  _subCreated <- readTVar $ subCreated s
-  _subDeleted <- readTVar $ subDeleted s
-  _ntfReceived <- readTVar $ ntfReceived s
-  _ntfDelivered <- readTVar $ ntfDelivered s
-  _activeTokens <- getPeriodStatsData $ activeTokens s
-  _activeSubs <- getPeriodStatsData $ activeSubs s
-  pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
-
-setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
-setNtfServerStats s d = do
-  writeTVar (fromTime (s :: NtfServerStats)) (_fromTime (d :: NtfServerStatsData))
-  writeTVar (tknCreated s) (_tknCreated d)
-  writeTVar (tknVerified s) (_tknVerified d)
-  writeTVar (tknDeleted s) (_tknDeleted d)
-  writeTVar (subCreated s) (_subCreated d)
-  writeTVar (subDeleted s) (_subDeleted d)
-  writeTVar (ntfReceived s) (_ntfReceived d)
-  writeTVar (ntfDelivered s) (_ntfDelivered 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} =
-    B.unlines
-      [ "fromTime=" <> strEncode _fromTime,
-        "tknCreated=" <> strEncode _tknCreated,
-        "tknVerified=" <> strEncode _tknVerified,
-        "tknDeleted=" <> strEncode _tknDeleted,
-        "subCreated=" <> strEncode _subCreated,
-        "subDeleted=" <> strEncode _subDeleted,
-        "ntfReceived=" <> strEncode _ntfReceived,
-        "ntfDelivered=" <> strEncode _ntfDelivered,
-        "activeTokens:",
-        strEncode _activeTokens,
-        "activeSubs:",
-        strEncode _activeSubs
-      ]
-  strP = do
-    _fromTime <- "fromTime=" *> strP <* A.endOfLine
-    _tknCreated <- "tknCreated=" *> strP <* A.endOfLine
-    _tknVerified <- "tknVerified=" *> strP <* A.endOfLine
-    _tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
-    _subCreated <- "subCreated=" *> strP <* A.endOfLine
-    _subDeleted <- "subDeleted=" *> strP <* A.endOfLine
-    _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
-    _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
-    _ <- "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}

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

@@ -1,202 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Notifications.Server.Store where
-
-import Control.Concurrent.STM
-import Control.Monad
-import Data.ByteString.Char8 (ByteString)
-import Data.Functor (($>))
-import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Word (Word16)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (NtfPrivateSignKey)
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (whenM, ($>>=))
-
-data NtfStore = NtfStore
-  { tokens :: TMap NtfTokenId NtfTknData,
-    -- multiple registrations exist to protect from malicious registrations if token is compromised
-    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
-    subscriptions :: TMap NtfSubscriptionId NtfSubData,
-    tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
-    subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
-  }
-
-newNtfStore :: STM NtfStore
-newNtfStore = do
-  tokens <- TM.empty
-  tokenRegistrations <- TM.empty
-  subscriptions <- TM.empty
-  tokenSubscriptions <- TM.empty
-  subscriptionLookup <- TM.empty
-  pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
-
-data NtfTknData = NtfTknData
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: TVar NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: TVar Word16
-  }
-
-mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
-mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
-  tknStatus <- newTVar NTRegistered
-  tknCronInterval <- newTVar 0
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-data NtfSubData = NtfSubData
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateSignKey,
-    tokenId :: NtfTokenId,
-    subStatus :: TVar NtfSubStatus
-  }
-
-data NtfEntityRec (e :: NtfEntity) where
-  NtfTkn :: NtfTknData -> NtfEntityRec 'Token
-  NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
-
-getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getNtfToken st tknId = TM.lookup tknId (tokens st)
-
-addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
-addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
-  TM.insert tknId tkn $ tokens st
-  TM.lookup token regs >>= \case
-    Just tIds -> TM.insert regKey tknId tIds
-    _ -> do
-      tIds <- TM.singleton regKey tknId
-      TM.insert token tIds regs
-  where
-    regs = tokenRegistrations st
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
-getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
-  TM.lookup token (tokenRegistrations st)
-    $>>= TM.lookup regKey
-    $>>= (`TM.lookup` tokens st)
-  where
-    regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
-removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
-  TM.lookup token (tokenRegistrations st)
-    >>= maybe (pure []) removeRegs
-  where
-    removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId]
-    removeRegs tknRegs = do
-      tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs
-      forM_ tIds $ \(regKey, tId') -> do
-        TM.delete regKey tknRegs
-        TM.delete tId' $ tokens st
-        -- TODO remove token subscriptions as in deleteNtfToken
-      pure $ map snd tIds
-
-removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
-removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
-  TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
-  where
-    removeReg regs =
-      TM.lookup k regs
-        >>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
-    k = C.toPubKey C.pubKeyBytes tknVerifyKey
-
-deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
-deleteNtfToken st tknId = do
-  TM.lookupDelete tknId (tokens st)
-    >>= mapM_
-      ( \NtfTknData {token, tknVerifyKey} ->
-          TM.lookup token regs
-            >>= mapM_
-              ( \tIds -> do
-                  TM.delete (regKey tknVerifyKey) tIds
-                  whenM (TM.null tIds) $ TM.delete token regs
-              )
-      )
-
-  -- TODO refactor
-  qs <-
-    TM.lookupDelete tknId (tokenSubscriptions st)
-      >>= mapM
-        ( readTVar
-            >=> mapM
-              ( \subId -> do
-                  TM.lookupDelete subId (subscriptions st)
-                    >>= mapM
-                      ( \NtfSubData {smpQueue} ->
-                          TM.delete smpQueue (subscriptionLookup st) $> smpQueue
-                      )
-              )
-              . S.toList
-        )
-  pure $ maybe [] catMaybes qs
-  where
-    regs = tokenRegistrations st
-    regKey = C.toPubKey C.pubKeyBytes
-
-getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
-getNtfSubscription st subId =
-  TM.lookup subId (subscriptions st)
-
-findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
-findNtfSubscription st smpQueue = do
-  TM.lookup smpQueue (subscriptionLookup st)
-    $>>= \subId -> TM.lookup subId (subscriptions st)
-
-findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
-findNtfSubscriptionToken st smpQueue = do
-  findNtfSubscription st smpQueue
-    $>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
-
-getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
-getActiveNtfToken st tknId =
-  getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
-    tStatus <- readTVar tknStatus
-    pure $ if tStatus == NTActive then Just tkn else Nothing
-
-mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
-mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
-  subStatus <- newTVar NSNew
-  pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
-
-addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
-addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
-  TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
-  where
-    newTokenSub = do
-      ts <- newTVar S.empty
-      TM.insert tokenId ts $ tokenSubscriptions st
-      pure ts
-    insertSub ts = do
-      modifyTVar' ts $ S.insert subId
-      TM.insert subId sub $ subscriptions st
-      TM.insert smpQueue subId (subscriptionLookup st)
-      -- return Nothing if subscription existed before
-      pure $ Just ()
-
-deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
-deleteNtfSubscription st subId = do
-  TM.lookupDelete subId (subscriptions st)
-    >>= mapM_
-      ( \NtfSubData {smpQueue, tokenId} -> do
-          TM.delete smpQueue $ subscriptionLookup st
-          ts_ <- TM.lookup tokenId (tokenSubscriptions st)
-          forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
-      )

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

@@ -1,227 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Notifications.Server.StoreLog
-  ( StoreLog,
-    NtfStoreLogRecord (..),
-    readWriteNtfStore,
-    logCreateToken,
-    logTokenStatus,
-    logUpdateToken,
-    logTokenCron,
-    logDeleteToken,
-    logCreateSubscription,
-    logSubscriptionStatus,
-    logDeleteSubscription,
-    closeStoreLog,
-  )
-where
-
-import Control.Concurrent.STM
-import Control.Monad (void)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Word (Word16)
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (NtfPrivateSignKey)
-import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (whenM)
-import System.Directory (doesFileExist, renameFile)
-import System.IO
-
-data NtfStoreLogRecord
-  = CreateToken NtfTknRec
-  | TokenStatus NtfTokenId NtfTknStatus
-  | UpdateToken NtfTokenId DeviceToken NtfRegCode
-  | TokenCron NtfTokenId Word16
-  | DeleteToken NtfTokenId
-  | CreateSubscription NtfSubRec
-  | SubscriptionStatus NtfSubscriptionId NtfSubStatus
-  | DeleteSubscription NtfSubscriptionId
-
-data NtfTknRec = NtfTknRec
-  { ntfTknId :: NtfTokenId,
-    token :: DeviceToken,
-    tknStatus :: NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
-    tknDhKeys :: C.KeyPair 'C.X25519,
-    tknDhSecret :: C.DhSecretX25519,
-    tknRegCode :: NtfRegCode,
-    tknCronInterval :: Word16
-  }
-
-mkTknData :: NtfTknRec -> STM NtfTknData
-mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- newTVar status
-  tknCronInterval <- newTVar cronInt
-  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-mkTknRec :: NtfTknData -> STM NtfTknRec
-mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
-  tknStatus <- readTVar status
-  tknCronInterval <- readTVar cronInt
-  pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-data NtfSubRec = NtfSubRec
-  { ntfSubId :: NtfSubscriptionId,
-    smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateSignKey,
-    tokenId :: NtfTokenId,
-    subStatus :: NtfSubStatus
-  }
-
-mkSubData :: NtfSubRec -> STM NtfSubData
-mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- newTVar status
-  pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-mkSubRec :: NtfSubData -> STM NtfSubRec
-mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
-  subStatus <- readTVar status
-  pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-instance StrEncoding NtfStoreLogRecord where
-  strEncode = \case
-    CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
-    TokenStatus tknId tknStatus -> strEncode (Str "TSTATUS", tknId, tknStatus)
-    UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
-    TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
-    DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
-    CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
-    SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
-    DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
-  strP =
-    A.choice
-      [ "TCREATE " *> (CreateToken <$> strP),
-        "TSTATUS " *> (TokenStatus <$> strP_ <*> strP),
-        "TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
-        "TCRON " *> (TokenCron <$> strP_ <*> strP),
-        "TDELETE " *> (DeleteToken <$> 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} =
-    B.unwords
-      [ "tknId=" <> strEncode ntfTknId,
-        "token=" <> strEncode token,
-        "tokenStatus=" <> strEncode tknStatus,
-        "verifyKey=" <> strEncode tknVerifyKey,
-        "dhKeys=" <> strEncode tknDhKeys,
-        "dhSecret=" <> strEncode tknDhSecret,
-        "regCode=" <> strEncode tknRegCode,
-        "cron=" <> strEncode tknCronInterval
-      ]
-  strP = do
-    ntfTknId <- "tknId=" *> strP_
-    token <- "token=" *> strP_
-    tknStatus <- "tokenStatus=" *> strP_
-    tknVerifyKey <- "verifyKey=" *> strP_
-    tknDhKeys <- "dhKeys=" *> strP_
-    tknDhSecret <- "dhSecret=" *> strP_
-    tknRegCode <- "regCode=" *> strP_
-    tknCronInterval <- "cron=" *> strP
-    pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
-
-instance StrEncoding NtfSubRec where
-  strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
-    B.unwords
-      [ "subId=" <> strEncode ntfSubId,
-        "smpQueue=" <> strEncode smpQueue,
-        "notifierKey=" <> strEncode notifierKey,
-        "tknId=" <> strEncode tokenId,
-        "subStatus=" <> strEncode subStatus
-      ]
-  strP = do
-    ntfSubId <- "subId=" *> strP_
-    smpQueue <- "smpQueue=" *> strP_
-    notifierKey <- "notifierKey=" *> strP_
-    tokenId <- "tknId=" *> strP_
-    subStatus <- "subStatus=" *> strP
-    pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
-
-logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
-logNtfStoreRecord = writeStoreLogRecord
-
-logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
-logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
-
-logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
-logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
-
-logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
-logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode
-
-logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
-logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
-
-logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
-logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
-
-logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
-logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
-
-logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
-logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
-
-logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
-logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
-
-readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
-readWriteNtfStore f st = do
-  whenM (doesFileExist f) $ do
-    readNtfStore f st
-    renameFile f $ f <> ".bak"
-  s <- openWriteStoreLog f
-  writeNtfStore s st
-  pure s
-
-readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
-  where
-    addNtfLogRecord s = case strDecode s of
-      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
-      Right lr -> atomically $ case lr of
-        CreateToken r@NtfTknRec {ntfTknId} -> do
-          tkn <- mkTknData r
-          addNtfToken st ntfTknId tkn
-        TokenStatus tknId status ->
-          getNtfToken st tknId
-            >>= mapM_ (\NtfTknData {tknStatus} -> writeTVar tknStatus status)
-        UpdateToken tknId token' tknRegCode ->
-          getNtfToken st tknId
-            >>= mapM_
-              ( \tkn@NtfTknData {tknStatus} -> do
-                  removeTokenRegistration st tkn
-                  writeTVar tknStatus NTRegistered
-                  addNtfToken st tknId tkn {token = token', tknRegCode}
-              )
-        TokenCron tknId cronInt ->
-          getNtfToken st tknId
-            >>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
-        DeleteToken tknId ->
-          void $ deleteNtfToken st tknId
-        CreateSubscription r@NtfSubRec {ntfSubId} -> do
-          sub <- mkSubData r
-          void $ addNtfSubscription st ntfSubId sub
-        SubscriptionStatus subId status ->
-          getNtfSubscription st subId
-            >>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
-        DeleteSubscription subId ->
-          deleteNtfSubscription st subId
-
-writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
-writeNtfStore s NtfStore {tokens, subscriptions} = do
-  atomically (readTVar tokens >>= mapM mkTknRec)
-    >>= mapM_ (writeStoreLogRecord s . CreateToken)
-  atomically (readTVar subscriptions >>= mapM mkSubRec)
-    >>= mapM_ (writeStoreLogRecord s . CreateSubscription)

src/Simplex/Messaging/Notifications/Transport.hs

@@ -1,72 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Notifications.Transport where
-
-import Control.Monad.Except
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Version
-
-ntfBlockSize :: Int
-ntfBlockSize = 512
-
-supportedNTFServerVRange :: VersionRange
-supportedNTFServerVRange = mkVersionRange 1 1
-
-data NtfServerHandshake = NtfServerHandshake
-  { ntfVersionRange :: VersionRange,
-    sessionId :: SessionId
-  }
-
-data NtfClientHandshake = NtfClientHandshake
-  { -- | agreed SMP notifications server protocol version
-    ntfVersion :: Version,
-    -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
-  }
-
-instance Encoding NtfServerHandshake where
-  smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
-    smpEncode (ntfVersionRange, sessionId)
-  smpP = do
-    (ntfVersionRange, sessionId) <- smpP
-    pure NtfServerHandshake {ntfVersionRange, sessionId}
-
-instance Encoding NtfClientHandshake where
-  smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
-  smpP = do
-    (ntfVersion, keyHash) <- smpP
-    pure NtfClientHandshake {ntfVersion, keyHash}
-
--- | Notifcations server transport handshake.
-ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c kh ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
-  getHandshake th >>= \case
-    NtfClientHandshake {ntfVersion, keyHash}
-      | keyHash /= kh ->
-        throwError $ TEHandshake IDENTITY
-      | ntfVersion `isCompatible` ntfVRange -> do
-        pure (th :: THandle c) {thVersion = ntfVersion}
-      | otherwise -> throwError $ TEHandshake VERSION
-
--- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfClientHandshake c keyHash ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
-  if sessionId /= sessId
-    then throwError TEBadSession
-    else case ntfVersionRange `compatibleVersion` ntfVRange of
-      Just (Compatible ntfVersion) -> do
-        sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
-        pure (th :: THandle c) {thVersion = ntfVersion}
-      Nothing -> throwError $ TEHandshake VERSION
-
-ntfTHandle :: Transport c => c -> THandle c
-ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}

src/Simplex/Messaging/Notifications/Types.hs

@@ -1,197 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-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 (..))
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
-import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
-
-data NtfTknAction
-  = NTARegister
-  | NTAVerify NtfRegCode -- code to verify token
-  | NTACheck
-  | NTADelete
-  deriving (Show)
-
-instance Encoding NtfTknAction where
-  smpEncode = \case
-    NTARegister -> "R"
-    NTAVerify code -> smpEncode ('V', code)
-    NTACheck -> "C"
-    NTADelete -> "D"
-  smpP =
-    A.anyChar >>= \case
-      'R' -> pure NTARegister
-      'V' -> NTAVerify <$> smpP
-      'C' -> pure NTACheck
-      'D' -> pure NTADelete
-      _ -> fail "bad NtfTknAction"
-
-instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfTknAction where toField = toField . smpEncode
-
-data NtfToken = NtfToken
-  { deviceToken :: DeviceToken,
-    ntfServer :: NtfServer,
-    ntfTokenId :: Maybe NtfTokenId,
-    -- | key used by the ntf server to verify transmissions
-    ntfPubKey :: C.APublicVerifyKey,
-    -- | key used by the ntf client to sign transmissions
-    ntfPrivKey :: C.APrivateSignKey,
-    -- | client's DH keys (to repeat registration if necessary)
-    ntfDhKeys :: C.KeyPair 'C.X25519,
-    -- | shared DH secret used to encrypt/decrypt notifications e2e
-    ntfDhSecret :: Maybe C.DhSecretX25519,
-    -- | token status
-    ntfTknStatus :: NtfTknStatus,
-    -- | pending token action and the earliest time
-    ntfTknAction :: Maybe NtfTknAction,
-    ntfMode :: NotificationsMode
-  }
-  deriving (Show)
-
-newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
-newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
-  NtfToken
-    { deviceToken,
-      ntfServer,
-      ntfTokenId = Nothing,
-      ntfPubKey,
-      ntfPrivKey,
-      ntfDhKeys,
-      ntfDhSecret = Nothing,
-      ntfTknStatus = NTNew,
-      ntfTknAction = Just NTARegister,
-      ntfMode
-    }
-
-data NtfSubAction = NtfSubNTFAction NtfSubNTFAction | NtfSubSMPAction NtfSubSMPAction
-  deriving (Show)
-
-isDeleteNtfSubAction :: NtfSubAction -> Bool
-isDeleteNtfSubAction = \case
-  NtfSubNTFAction a -> case a of
-    NSACreate -> False
-    NSACheck -> False
-    NSADelete -> True
-    NSARotate -> True
-  NtfSubSMPAction a -> case a of
-    NSASmpKey -> False
-    NSASmpDelete -> True
-
-type NtfActionTs = UTCTime
-
-data NtfSubNTFAction
-  = NSACreate
-  | NSACheck
-  | NSADelete
-  | NSARotate
-  deriving (Show)
-
-instance Encoding NtfSubNTFAction where
-  smpEncode = \case
-    NSACreate -> "N"
-    NSACheck -> "C"
-    NSADelete -> "D"
-    NSARotate -> "R"
-  smpP =
-    A.anyChar >>= \case
-      'N' -> pure NSACreate
-      'C' -> pure NSACheck
-      'D' -> pure NSADelete
-      'R' -> pure NSARotate
-      _ -> fail "bad NtfSubNTFAction"
-
-instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfSubNTFAction where toField = toField . smpEncode
-
-data NtfSubSMPAction
-  = NSASmpKey
-  | NSASmpDelete
-  deriving (Show)
-
-instance Encoding NtfSubSMPAction where
-  smpEncode = \case
-    NSASmpKey -> "K"
-    NSASmpDelete -> "D"
-  smpP =
-    A.anyChar >>= \case
-      'K' -> pure NSASmpKey
-      'D' -> pure NSASmpDelete
-      _ -> fail "bad NtfSubSMPAction"
-
-instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
-
-instance ToField NtfSubSMPAction where toField = toField . smpEncode
-
-data NtfAgentSubStatus
-  = -- | subscription started
-    NASNew
-  | -- | state after NKEY - notifier ID is assigned to queue on SMP server
-    NASKey
-  | -- | state after SNEW - subscription created on notification server
-    NASCreated NtfSubStatus
-  | -- | state after SDEL (subscription is deleted on notification server)
-    NASOff
-  | -- | state after NDEL (notifier credentials are deleted on SMP server)
-    -- Can only exist transiently - if subscription record was updated by notification supervisor mid worker operation,
-    -- and hence got updated instead of being fully deleted in the database post operation by worker
-    NASDeleted
-  deriving (Eq, Show)
-
-instance Encoding NtfAgentSubStatus where
-  smpEncode = \case
-    NASNew -> "NEW"
-    NASKey -> "KEY"
-    NASCreated status -> "CREATED " <> smpEncode status
-    NASOff -> "OFF"
-    NASDeleted -> "DELETED"
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "NEW" -> pure NASNew
-      "KEY" -> pure NASKey
-      "CREATED" -> do
-        _ <- A.space
-        NASCreated <$> smpP
-      "OFF" -> pure NASOff
-      "DELETED" -> pure NASDeleted
-      _ -> fail "bad NtfAgentSubStatus"
-
-instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
-
-instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
-
-data NtfSubscription = NtfSubscription
-  { connId :: ConnId,
-    smpServer :: SMPServer,
-    ntfQueueId :: Maybe NotifierId,
-    ntfServer :: NtfServer,
-    ntfSubId :: Maybe NtfSubscriptionId,
-    ntfSubStatus :: NtfAgentSubStatus
-  }
-  deriving (Show)
-
-newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> NtfSubscription
-newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus =
-  NtfSubscription
-    { connId,
-      smpServer,
-      ntfQueueId,
-      ntfServer,
-      ntfSubId = Nothing,
-      ntfSubStatus
-    }

src/Simplex/Messaging/Parsers.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -13,15 +12,16 @@ import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum, toLower)
-import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601 (parseISO8601)
 import Data.Typeable (Typeable)
+import qualified Database.PostgreSQL.Simple.FromField as PF
+import qualified Database.PostgreSQL.Simple.Internal as PI
+import qualified Database.PostgreSQL.Simple.Ok as PO
 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 qualified Database.SQLite.Simple.FromField as SF
+import qualified Database.SQLite.Simple.Internal as SI
+import qualified Database.SQLite.Simple.Ok as SO
 import Simplex.Messaging.Util ((<$?>))
 import Text.Read (readMaybe)
 
@@ -72,24 +72,24 @@ wordEnd c = c == ' ' || c == '\n'
 parseString :: (ByteString -> Either String a) -> (String -> a)
 parseString p = either error id . p . B.pack
 
-blobFieldParser :: Typeable k => Parser k -> FieldParser k
+blobFieldParser :: Typeable k => Parser k -> SF.FieldParser k
 blobFieldParser = blobFieldDecoder . parseAll
 
-blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> SF.FieldParser k
 blobFieldDecoder dec = \case
-  f@(Field (SQLBlob b) _) ->
+  f@(SI.Field (SQLBlob b) _) ->
     case dec b of
-      Right k -> Ok k
-      Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
-  f -> returnError ConversionFailed f "expecting SQLBlob column type"
+      Right k -> SO.Ok k
+      Left e -> SF.returnError SF.ConversionFailed f ("couldn't parse field: " ++ e)
+  f -> SF.returnError SF.ConversionFailed f "expecting SQLBlob column type"
 
-fromTextField_ :: (Typeable a) => (Text -> Maybe a) -> Field -> Ok a
-fromTextField_ fromText = \case
-  f@(Field (SQLText t) _) ->
-    case fromText t of
-      Just x -> Ok x
-      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
-  f -> returnError ConversionFailed f "expecting SQLText column type"
+-- blobFieldDecoderPostgres :: Typeable k => (ByteString -> Either String k) -> PF.FieldParser k
+-- blobFieldDecoderPostgres dec = \case
+--   f@(PI.Field b _ _) ->
+--     case dec b of
+--       Right k -> PO.Ok k
+--       Left e -> PF.returnError PF.ConversionFailed f ("couldn't parse field: " ++ e)
+--   f -> PF.returnError PF.ConversionFailed f "expecting SQLBlob column type"
 
 fstToLower :: String -> String
 fstToLower "" = ""
@@ -108,19 +108,13 @@ enumJSON tagModifier =
     }
 
 sumTypeJSON :: (String -> String) -> J.Options
-#if defined(darwin_HOST_OS) && defined(swiftJSON)
 sumTypeJSON = singleFieldJSON
-#else
-sumTypeJSON = taggedObjectJSON
-#endif
 
 taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.TaggedObject "type" "data",
-      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
-      J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
       J.omitNothingFields = True
     }
@@ -129,9 +123,7 @@ singleFieldJSON :: (String -> String) -> J.Options
 singleFieldJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.ObjectWithSingleField,
-      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
-      J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
       J.omitNothingFields = True
     }

src/Simplex/Messaging/Protocol.hs

@@ -1,31 +1,23 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-{-# HLINT ignore "Use newtype instead of data" #-}
-
 -- |
--- Module      : Simplex.Messaging.ProtocolEncoding
+-- Module      : Simplex.Messaging.Protocol
 -- Copyright   : (c) simplex.chat
 -- License     : AGPL-3
 --
@@ -38,13 +30,14 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Protocol
   ( -- * SMP protocol parameters
-    supportedSMPClientVRange,
+    smpClientVersion,
+    smpClientVRange,
     maxMessageLength,
     e2eEncConfirmationLength,
     e2eEncMessageLength,
 
     -- * SMP protocol types
-    ProtocolEncoding (..),
+    Protocol,
     Command (..),
     Party (..),
     Cmd (..),
@@ -62,19 +55,7 @@ module Simplex.Messaging.Protocol
     PubHeader (..),
     ClientMessage (..),
     PrivHeader (..),
-    Protocol (..),
-    ProtocolType (..),
-    AProtocolType (..),
-    ProtocolTypeI (..),
-    ProtocolServer (..),
-    ProtoServer,
-    SMPServer,
-    pattern SMPServer,
-    SMPServerWithAuth,
-    NtfServer,
-    pattern NtfServer,
-    ProtoServerWithAuth (..),
-    BasicAuth (..),
+    SMPServer (..),
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -89,38 +70,13 @@ module Simplex.Messaging.Protocol
     SndPublicVerifyKey,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
-    RcvNtfPublicDhKey,
-    RcvNtfDhSecret,
-    Message (..),
-    RcvMessage (..),
     MsgId,
     MsgBody,
-    MaxMessageLen,
-    MaxRcvMessageLen,
-    EncRcvMsgBody (..),
-    RcvMsgBody (..),
-    ClientRcvMsgBody (..),
-    EncNMsgMeta,
-    SMPMsgMeta (..),
-    NMsgMeta (..),
-    MsgFlags (..),
-    rcvMessageMeta,
-    noMsgFlags,
 
     -- * Parse and serialize
-    ProtocolMsgTag (..),
-    messageTagP,
     encodeTransmission,
     transmissionP,
-    _smpP,
-    encodeRcvMsgBody,
-    clientRcvMsgBodyP,
-    legacyEncodeServer,
-    legacyServerP,
-    legacyStrEncodeServer,
-    sameSrvAddr,
-    sameSrvAddr',
-    noAuthSrv,
+    encodeProtocol,
 
     -- * TCP transport functions
     tPut,
@@ -134,48 +90,38 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad.Except
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isPrint, isSpace)
 import Data.Kind
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as L
-import Data.Maybe (isJust, isNothing)
+import Data.Maybe (isNothing)
 import Data.String
-import Data.Time.Clock.System (SystemTime (..))
+import Data.Time.Clock.System (SystemTime)
 import Data.Type.Equality
 import GHC.Generics (Generic)
-import GHC.TypeLits (type (+))
 import Generic.Random (genericArbitraryU)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
+import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
 import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
-currentSMPClientVersion :: Version
-currentSMPClientVersion = 2
+smpClientVersion :: Version
+smpClientVersion = 1
 
-supportedSMPClientVRange :: VersionRange
-supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
+smpClientVRange :: VersionRange
+smpClientVRange = mkVersionRange 1 smpClientVersion
 
 maxMessageLength :: Int
 maxMessageLength = 16088
 
-type MaxMessageLen = 16088
-
--- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
-type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
-
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
 e2eEncConfirmationLength = 15936
@@ -215,7 +161,7 @@ data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
 deriving instance Show Cmd
 
 -- | Parsed SMP transmission without signature, size and session ID.
-type Transmission c = (CorrId, EntityId, c)
+type Transmission c = (CorrId, QueueId, c)
 
 -- | signed parsed transmission, with original raw bytes and parsing error.
 type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
@@ -226,15 +172,14 @@ type Signed = ByteString
 data RawTransmission = RawTransmission
   { signature :: ByteString,
     signed :: ByteString,
-    sessId :: SessionId,
+    sessId :: ByteString,
     corrId :: ByteString,
-    entityId :: ByteString,
+    queueId :: ByteString,
     command :: ByteString
   }
-  deriving (Show)
 
 -- | unparsed sent SMP transmission with signature, without session ID.
-type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
+type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString)
 
 -- | unparsed sent SMP transmission with signature.
 type SentRawTransmission = (Maybe C.ASignature, ByteString)
@@ -249,28 +194,20 @@ type SenderId = QueueId
 type NotifierId = QueueId
 
 -- | SMP queue ID on the server.
-type QueueId = EntityId
-
-type EntityId = ByteString
+type QueueId = ByteString
 
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient
+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
-  NKEY :: NtfPublicVerifyKey -> 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
+  NKEY :: NtfPublicVerifyKey -> Command Recipient
+  ACK :: Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
   -- SMP sender commands
-  -- SEND v1 has to be supported for encoding/decoding
-  -- SEND :: MsgBody -> Command Sender
-  SEND :: MsgFlags -> MsgBody -> Command Sender
+  SEND :: MsgBody -> Command Sender
   PING :: Command Sender
   -- SMP notification subscriber commands
   NSUB :: Command Notifier
@@ -282,139 +219,15 @@ deriving instance Eq (Command p)
 data BrokerMsg where
   -- SMP broker messages (responses, client messages, notifications)
   IDS :: QueueIdsKeys -> BrokerMsg
-  -- MSG v1/2 has to be supported for encoding/decoding
-  -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
-  -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
-  MSG :: RcvMessage -> BrokerMsg
-  NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
-  NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
+  MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  NID :: NotifierId -> BrokerMsg
+  NMSG :: BrokerMsg
   END :: BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
   deriving (Eq, Show)
 
-data RcvMessage = RcvMessage
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
-  }
-  deriving (Eq, Show)
-
--- | received message without server/recipient encryption
-data Message = Message
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: C.MaxLenBS MaxMessageLen
-  }
-
-instance StrEncoding RcvMessage where
-  strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
-    B.unwords
-      [ strEncode msgId,
-        strEncode msgTs,
-        "flags=" <> strEncode msgFlags,
-        strEncode body
-      ]
-  strP = do
-    msgId <- strP_
-    msgTs <- strP_
-    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-    msgBody <- EncRcvMsgBody <$> strP
-    pure RcvMessage {msgId, msgTs, msgFlags, msgBody}
-
-newtype EncRcvMsgBody = EncRcvMsgBody ByteString
-  deriving (Eq, Show)
-
-data RcvMsgBody = RcvMsgBody
-  { msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: C.MaxLenBS MaxMessageLen
-  }
-
-encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
-encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody} =
-  let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
-   in C.appendMaxLenBS rcvMeta msgBody
-
-data ClientRcvMsgBody = ClientRcvMsgBody
-  { msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: ByteString
-  }
-
-clientRcvMsgBodyP :: Parser ClientRcvMsgBody
-clientRcvMsgBodyP = do
-  msgTs <- smpP
-  msgFlags <- smpP
-  Tail msgBody <- _smpP
-  pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
-
-instance StrEncoding Message where
-  strEncode Message {msgId, msgTs, msgFlags, msgBody} =
-    B.unwords
-      [ strEncode msgId,
-        strEncode msgTs,
-        "flags=" <> strEncode msgFlags,
-        strEncode msgBody
-      ]
-  strP = do
-    msgId <- strP_
-    msgTs <- strP_
-    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-    msgBody <- strP
-    pure Message {msgId, msgTs, msgFlags, msgBody}
-
-type EncNMsgMeta = ByteString
-
-data SMPMsgMeta = SMPMsgMeta
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags
-  }
-  deriving (Show)
-
-rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
-rcvMessageMeta msgId ClientRcvMsgBody {msgTs, msgFlags} = SMPMsgMeta {msgId, msgTs, msgFlags}
-
-data NMsgMeta = NMsgMeta
-  { msgId :: MsgId,
-    msgTs :: SystemTime
-  }
-  deriving (Show)
-
-instance Encoding NMsgMeta where
-  smpEncode NMsgMeta {msgId, msgTs} =
-    smpEncode (msgId, msgTs)
-  smpP = do
-    -- Tail here is to allow extension in the future clients/servers
-    (msgId, msgTs, Tail _) <- smpP
-    pure NMsgMeta {msgId, msgTs}
-
--- it must be data for correct JSON encoding
-data MsgFlags = MsgFlags {notification :: Bool}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions
-
--- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
-instance Encoding MsgFlags where
-  smpEncode MsgFlags {notification} = smpEncode notification
-  smpP = do
-    notification <- smpP <* A.takeTill (== ' ')
-    pure MsgFlags {notification}
-
-instance StrEncoding MsgFlags where
-  strEncode = smpEncode
-  {-# INLINE strEncode #-}
-  strP = smpP
-  {-# INLINE strP #-}
-
-noMsgFlags :: MsgFlags
-noMsgFlags = MsgFlags {notification = False}
-
 -- * SMP command tags
 
 data CommandTag (p :: Party) where
@@ -422,8 +235,6 @@ data CommandTag (p :: Party) where
   SUB_ :: CommandTag Recipient
   KEY_ :: CommandTag Recipient
   NKEY_ :: CommandTag Recipient
-  NDEL_ :: CommandTag Recipient
-  GET_ :: CommandTag Recipient
   ACK_ :: CommandTag Recipient
   OFF_ :: CommandTag Recipient
   DEL_ :: CommandTag Recipient
@@ -453,7 +264,7 @@ class ProtocolMsgTag t where
 
 messageTagP :: ProtocolMsgTag t => Parser t
 messageTagP =
-  maybe (fail "bad message") pure . decodeTag
+  maybe (fail "bad command") pure . decodeTag
     =<< (A.takeTill (== ' ') <* optional A.space)
 
 instance PartyI p => Encoding (CommandTag p) where
@@ -462,8 +273,6 @@ instance PartyI p => Encoding (CommandTag p) where
     SUB_ -> "SUB"
     KEY_ -> "KEY"
     NKEY_ -> "NKEY"
-    NDEL_ -> "NDEL"
-    GET_ -> "GET"
     ACK_ -> "ACK"
     OFF_ -> "OFF"
     DEL_ -> "DEL"
@@ -478,8 +287,6 @@ instance ProtocolMsgTag CmdTag where
     "SUB" -> Just $ CT SRecipient SUB_
     "KEY" -> Just $ CT SRecipient KEY_
     "NKEY" -> Just $ CT SRecipient NKEY_
-    "NDEL" -> Just $ CT SRecipient NDEL_
-    "GET" -> Just $ CT SRecipient GET_
     "ACK" -> Just $ CT SRecipient ACK_
     "OFF" -> Just $ CT SRecipient OFF_
     "DEL" -> Just $ CT SRecipient DEL_
@@ -565,200 +372,32 @@ instance Encoding ClientMessage where
   smpEncode (ClientMessage h msg) = smpEncode h <> msg
   smpP = ClientMessage <$> smpP <*> A.takeByteString
 
-type SMPServer = ProtocolServer 'PSMP
-
-pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
-pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
-
-{-# COMPLETE SMPServer #-}
-
-type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
-
-type NtfServer = ProtocolServer 'PNTF
-
-pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
-pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
-
-{-# COMPLETE NtfServer #-}
-
-sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
-sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
-{-# INLINE sameSrvAddr' #-}
-
-sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
-sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
-{-# INLINE sameSrvAddr #-}
-
-data ProtocolType = PSMP | PNTF
-  deriving (Eq, Ord, Show)
-
-instance StrEncoding ProtocolType where
-  strEncode = \case
-    PSMP -> "smp"
-    PNTF -> "ntf"
-  strP =
-    A.takeTill (\c -> c == ':' || c == ' ') >>= \case
-      "smp" -> pure PSMP
-      "ntf" -> pure PNTF
-      _ -> fail "bad ProtocolType"
-
-data SProtocolType (p :: ProtocolType) where
-  SPSMP :: SProtocolType 'PSMP
-  SPNTF :: SProtocolType 'PNTF
-
-deriving instance Eq (SProtocolType p)
-
-deriving instance Ord (SProtocolType p)
-
-deriving instance Show (SProtocolType p)
-
-data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
-
-deriving instance Show AProtocolType
-
-instance Eq AProtocolType where
-  AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
-
-instance TestEquality SProtocolType where
-  testEquality SPSMP SPSMP = Just Refl
-  testEquality SPNTF SPNTF = Just Refl
-  testEquality _ _ = Nothing
-
-protocolType :: SProtocolType p -> ProtocolType
-protocolType = \case
-  SPSMP -> PSMP
-  SPNTF -> PNTF
-
-aProtocolType :: ProtocolType -> AProtocolType
-aProtocolType = \case
-  PSMP -> AProtocolType SPSMP
-  PNTF -> AProtocolType SPNTF
-
-instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
-  strEncode = strEncode . protocolType
-  strP = (\(AProtocolType p) -> checkProtocolType p) <$?> strP
-
-instance StrEncoding AProtocolType where
-  strEncode (AProtocolType p) = strEncode p
-  strP = aProtocolType <$> strP
-
-instance ToJSON AProtocolType where
-  toEncoding = strToJEncoding
-  toJSON = strToJSON
-
-checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
-checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
-  Just Refl -> Right p
-  Nothing -> Left "bad ProtocolType"
-
-class ProtocolTypeI (p :: ProtocolType) where
-  protocolTypeI :: SProtocolType p
-
-instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP
-
-instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
-
--- | server location and transport key digest (hash).
-data ProtocolServer p = ProtocolServer
-  { scheme :: SProtocolType p,
-    host :: NonEmpty TransportHost,
+-- | SMP server location and transport key digest (hash).
+data SMPServer = SMPServer
+  { host :: HostName,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
   deriving (Eq, Ord, Show)
 
-instance ProtocolTypeI p => IsString (ProtocolServer p) where
+instance IsString SMPServer where
   fromString = parseString strDecode
 
-instance ProtocolTypeI p => Encoding (ProtocolServer p) where
-  smpEncode ProtocolServer {host, port, keyHash} =
+instance Encoding SMPServer where
+  smpEncode SMPServer {host, port, keyHash} =
     smpEncode (host, port, keyHash)
   smpP = do
     (host, port, keyHash) <- smpP
-    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}
+    pure SMPServer {host, port, keyHash}
 
-instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
-  strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncodeServer scheme (strEncode host) port keyHash Nothing
-  strP =
-    serverStrP >>= \case
-      (srv, Nothing) -> pure srv
-      _ -> fail "ProtocolServer with basic auth not allowed"
-
-instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
-  deriving (Eq, Show)
-
-instance IsString BasicAuth where fromString = BasicAuth . B.pack
-
-instance Encoding BasicAuth where
-  smpEncode (BasicAuth s) = smpEncode s
-  smpP = basicAuth <$?> smpP
-
-instance StrEncoding BasicAuth where
-  strEncode (BasicAuth s) = s
-  strP = basicAuth <$?> A.takeWhile1 (/= '@')
-
-basicAuth :: ByteString -> Either String BasicAuth
-basicAuth s
-  | B.all valid s = Right $ BasicAuth s
-  | otherwise = Left "invalid character in BasicAuth"
-  where
-    valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
-
-data ProtoServerWithAuth p = ProtoServerWithAuth (ProtocolServer p) (Maybe BasicAuth)
-  deriving (Show)
-
-instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
-  fromString = parseString strDecode
-
-instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
-  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
-    strEncodeServer scheme (strEncode host) port keyHash auth_
-  strP = uncurry ProtoServerWithAuth <$> serverStrP
-
-instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
-  parseJSON = strParseJSON "ProtoServerWithAuth"
-
-noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
-noAuthSrv srv = ProtoServerWithAuth srv Nothing
-
-legacyEncodeServer :: ProtocolServer p -> ByteString
-legacyEncodeServer ProtocolServer {host, port, keyHash} =
-  smpEncode (L.head host, port, keyHash)
-
-legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
-legacyServerP = do
-  (h, port, keyHash) <- smpP
-  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
-
-legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
-legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
-
-strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
-strEncodeServer scheme host port keyHash auth_ =
-  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
-  where
-    portStr = B.pack $ if null port then "" else ':' : port
-
-serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
-serverStrP = do
-  scheme <- strP <* "://"
-  keyHash <- strP
-  auth_ <- optional $ A.char ':' *> strP
-  TransportHosts host <- A.char '@' *> strP
-  port <- portP <|> pure ""
-  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
-  where
-    portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+instance StrEncoding SMPServer where
+  strEncode SMPServer {host, port, keyHash} =
+    "smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
+  strP = do
+    _ <- "smp://"
+    keyHash <- strP <* A.char '@'
+    SrvLoc host port <- strP
+    pure SMPServer {host, port, keyHash}
 
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
@@ -768,7 +407,7 @@ instance StrEncoding SrvLoc where
   strP = SrvLoc <$> host <*> (port <|> pure "")
     where
       host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
 
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
@@ -815,18 +454,12 @@ type SndPrivateSignKey = C.APrivateSignKey
 -- | Sender's public key used by SMP server to verify authorization of SMP commands.
 type SndPublicVerifyKey = C.APublicVerifyKey
 
--- | Private key used by push notifications server to authorize (sign) NSUB command.
+-- | Private key used by push notifications server to authorize (sign) LSTN command.
 type NtfPrivateSignKey = C.APrivateSignKey
 
--- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
+-- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server.
 type NtfPublicVerifyKey = C.APublicVerifyKey
 
--- | Public key used for DH exchange to encrypt notification metadata from server to recipient
-type RcvNtfPublicDhKey = C.PublicKeyX25519
-
--- | DH Secret used to encrypt notification metadata from server to recipient
-type RcvNtfDhSecret = C.DhSecretX25519
-
 -- | SMP message server ID.
 type MsgId = ByteString
 
@@ -847,7 +480,7 @@ data ErrorType
     QUOTA
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
-  | -- | sent message is too large (> maxMessageLength = 16088 bytes)
+  | -- | sent message is too large (> maxMessageLength = 16078 bytes)
     LARGE_MSG
   | -- | internal server error
     INTERNAL
@@ -871,14 +504,12 @@ data CommandError
     UNKNOWN
   | -- | error parsing command
     SYNTAX
-  | -- | command is not allowed (SUB/GET cannot be used with the same queue in the same TCP connection)
-    PROHIBITED
   | -- | transmission has no required credentials (signature or queue ID)
     NO_AUTH
   | -- | transmission has credentials that are not allowed for this command
     HAS_AUTH
-  | -- | transmission has no required entity ID (e.g. SMP queue)
-    NO_ENTITY
+  | -- | transmission has no required queue ID
+    NO_QUEUE
   deriving (Eq, Generic, Read, Show)
 
 instance ToJSON CommandError where
@@ -899,64 +530,34 @@ transmissionP = do
     trn signature signed = do
       sessId <- smpP
       corrId <- smpP
-      entityId <- smpP
+      queueId <- smpP
       command <- A.takeByteString
-      pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
+      pure RawTransmission {signature, signed, sessId, corrId, queueId, command}
 
-class (ProtocolEncoding msg, ProtocolEncoding (ProtoCommand msg), Show msg) => Protocol msg where
-  type ProtoCommand msg = cmd | cmd -> msg
-  type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-  protocolPing :: ProtoCommand msg
-  protocolError :: msg -> Maybe ErrorType
-
-type ProtoServer msg = ProtocolServer (ProtoType msg)
-
-instance Protocol BrokerMsg where
-  type ProtoCommand BrokerMsg = Cmd
-  type ProtoType BrokerMsg = 'PSMP
-  protocolClientHandshake = smpClientHandshake
-  protocolPing = Cmd SSender PING
-  protocolError = \case
-    ERR e -> Just e
-    _ -> Nothing
-
-class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
+class Protocol msg where
   type Tag msg
-  encodeProtocol :: Version -> msg -> ByteString
-  protocolP :: Version -> Tag msg -> Parser msg
+  encodeProtocol :: msg -> ByteString
+  protocolP :: Tag msg -> Parser msg
   checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
 
-instance PartyI p => ProtocolEncoding (Command p) where
+instance PartyI p => Protocol (Command p) where
   type Tag (Command p) = CommandTag p
-  encodeProtocol v = \case
-    NEW rKey dhKey auth_ -> case auth_ of
-      Just auth
-        | v >= 5 -> new <> e ('A', auth)
-        | otherwise -> new
-      _ -> new
-      where
-        new = e (NEW_, ' ', rKey, dhKey)
+  encodeProtocol = \case
+    NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
-    NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
-    NDEL -> e NDEL_
-    GET -> e GET_
-    ACK msgId
-      | v == 1 -> e ACK_
-      | otherwise -> e (ACK_, ' ', msgId)
+    NKEY k -> e (NKEY_, ' ', k)
+    ACK -> e ACK_
     OFF -> e OFF_
     DEL -> e DEL_
-    SEND flags msg
-      | v == 1 -> e (SEND_, ' ', Tail msg)
-      | otherwise -> e (SEND_, ' ', flags, ' ', Tail msg)
+    SEND msg -> e (SEND_, ' ', Tail msg)
     PING -> e PING_
     NSUB -> e NSUB_
     where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
+  protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag)
 
   checkCredentials (sig, _, queueId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
@@ -965,8 +566,8 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | not (B.null queueId) -> Left $ CMD HAS_AUTH
       | otherwise -> Right cmd
     -- SEND must have queue ID, signature is not always required
-    SEND {}
-      | B.null queueId -> Left $ CMD NO_ENTITY
+    SEND _
+      | B.null queueId -> Left $ CMD NO_QUEUE
       | otherwise -> Right cmd
     -- PING must not have queue ID or signature
     PING
@@ -977,48 +578,35 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding Cmd where
+instance Protocol Cmd where
   type Tag Cmd = CmdTag
-  encodeProtocol v (Cmd _ c) = encodeProtocol v c
+  encodeProtocol (Cmd _ c) = encodeProtocol c
 
-  protocolP v = \case
+  protocolP = \case
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
-        NEW_
-          | v >= 5 -> new <*> optional (A.char 'A' *> smpP)
-          | otherwise -> new <*> pure Nothing
-          where
-            new = NEW <$> _smpP <*> smpP
+        NEW_ -> NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
-        NKEY_ -> NKEY <$> _smpP <*> smpP
-        NDEL_ -> pure NDEL
-        GET_ -> pure GET
-        ACK_
-          | v == 1 -> pure $ ACK ""
-          | otherwise -> ACK <$> _smpP
+        NKEY_ -> NKEY <$> _smpP
+        ACK_ -> pure ACK
         OFF_ -> pure OFF
         DEL_ -> pure DEL
     CT SSender tag ->
       Cmd SSender <$> case tag of
-        SEND_
-          | v == 1 -> SEND noMsgFlags <$> (unTail <$> _smpP)
-          | otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
+        SEND_ -> SEND . unTail <$> _smpP
         PING_ -> pure PING
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
 
   checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
 
-instance ProtocolEncoding BrokerMsg where
+instance Protocol BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
-  encodeProtocol v = \case
+  encodeProtocol = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
-    MSG RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body}
-      | v == 1 -> e (MSG_, ' ', msgId, msgTs, Tail body)
-      | v == 2 -> e (MSG_, ' ', msgId, msgTs, msgFlags, ' ', Tail body)
-      | otherwise -> e (MSG_, ' ', msgId, Tail body)
-    NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
-    NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
+    MSG msgId ts msgBody -> e (MSG_, ' ', msgId, ts, Tail msgBody)
+    NID nId -> e (NID_, ' ', nId)
+    NMSG -> e NMSG_
     END -> e END_
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
@@ -1027,25 +615,18 @@ instance ProtocolEncoding BrokerMsg where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP v = \case
-    MSG_ -> do
-      msgId <- _smpP
-      MSG <$> case v of
-        1 -> RcvMessage msgId <$> smpP <*> pure noMsgFlags <*> bodyP
-        2 -> RcvMessage msgId <$> smpP <*> smpP <*> (A.space *> bodyP)
-        _ -> RcvMessage msgId (MkSystemTime 0 0) noMsgFlags <$> bodyP
-      where
-        bodyP = EncRcvMsgBody . unTail <$> smpP
+  protocolP = \case
+    MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP)
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
-    NID_ -> NID <$> _smpP <*> smpP
-    NMSG_ -> NMSG <$> _smpP <*> smpP
+    NID_ -> NID <$> _smpP
+    NMSG_ -> pure NMSG
     END_ -> pure END
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
     PONG_ -> pure PONG
 
   checkCredentials (_, _, queueId, _) cmd = case cmd of
-    -- IDS response should not have queue ID
+    -- IDS response must not have queue ID
     IDS _ -> Right cmd
     -- ERR response does not always have queue ID
     ERR _ -> Right cmd
@@ -1055,18 +636,18 @@ instance ProtocolEncoding BrokerMsg where
       | otherwise -> Left $ CMD HAS_AUTH
     -- other broker responses must have queue ID
     _
-      | B.null queueId -> Left $ CMD NO_ENTITY
+      | B.null queueId -> Left $ CMD NO_QUEUE
       | otherwise -> Right cmd
 
 _smpP :: Encoding a => Parser a
 _smpP = A.space *> smpP
 
 -- | Parse SMP protocol commands and broker messages
-parseProtocol :: ProtocolEncoding msg => Version -> ByteString -> Either ErrorType msg
-parseProtocol v s =
+parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg
+parseProtocol s =
   let (tag, params) = B.break (== ' ') s
    in case decodeTag tag of
-        Just cmd -> parse (protocolP v cmd) (CMD SYNTAX) params
+        Just cmd -> parse (protocolP cmd) (CMD SYNTAX) params
         Nothing -> Left $ CMD UNKNOWN
 
 checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
@@ -1108,73 +689,43 @@ instance Encoding CommandError where
   smpEncode e = case e of
     UNKNOWN -> "UNKNOWN"
     SYNTAX -> "SYNTAX"
-    PROHIBITED -> "PROHIBITED"
     NO_AUTH -> "NO_AUTH"
     HAS_AUTH -> "HAS_AUTH"
-    NO_ENTITY -> "NO_ENTITY"
+    NO_QUEUE -> "NO_QUEUE"
   smpP =
     A.takeTill (== ' ') >>= \case
       "UNKNOWN" -> pure UNKNOWN
       "SYNTAX" -> pure SYNTAX
-      "PROHIBITED" -> pure PROHIBITED
       "NO_AUTH" -> pure NO_AUTH
       "HAS_AUTH" -> pure HAS_AUTH
-      "NO_ENTITY" -> pure NO_ENTITY
-      "NO_QUEUE" -> pure NO_ENTITY
+      "NO_QUEUE" -> pure NO_QUEUE
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO (NonEmpty (Either TransportError ()))
-tPut th trs
-  | batch th = tPutBatch [] $ L.map tEncode trs
-  | otherwise = forM trs $ tPutBlock th . tEncode
-  where
-    tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO (NonEmpty (Either TransportError ()))
-    tPutBatch rs ts = do
-      let (n, s, ts_) = encodeBatch 0 "" ts
-      r <- if n == 0 then pure [Left TELargeMsg] else replicate n <$> tPutBlock th (lenEncode n `B.cons` s)
-      let rs' = rs <> r
-      case ts_ of
-        Just ts' -> tPutBatch rs' ts'
-        _ -> pure $ L.fromList rs'
-    encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
-    encodeBatch n s ts@(t :| ts_)
-      | n == 255 = (n, s, Just ts)
-      | otherwise =
-        let s' = s <> smpEncode (Large t)
-            n' = n + 1
-         in if B.length s' > blockSize th - 1
-              then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
-              else case L.nonEmpty ts_ of
-                Just ts' -> encodeBatch n' s' ts'
-                _ -> (n', s', Nothing)
-    tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
+tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
+tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
 
-encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
-encodeTransmission v sessionId (CorrId corrId, queueId, command) =
-  smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
+encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString
+encodeTransmission sessionId (CorrId corrId, queueId, command) =
+  smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
-tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
-tGetParse th
-  | batch th = either ((:| []) . Left) id <$> runExceptT getBatch
-  | otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
-  where
-    getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
-    getBatch = do
-      s <- ExceptT $ tGetBlock th
-      ts <- liftEither $ parse smpP TEBadBlock s
-      pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
+tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
+tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
-tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
+tGet ::
+  forall cmd c m.
+  (Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) =>
+  THandle c ->
+  m (SignedTransmission cmd)
+tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
   where
     decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case
-      Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
+      Right RawTransmission {signature, signed, sessId, corrId, queueId, command}
         | sessId == sessionId ->
-          let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
+          let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature
            in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
         | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
       Left _ -> tError ""
@@ -1183,6 +734,6 @@ tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM deco
     tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
 
     tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
-    tParseValidate signed t@(sig, corrId, entityId, command) = do
-      let cmd = parseProtocol v command >>= checkCredentials t
-      pure (sig, signed, (CorrId corrId, entityId, cmd))
+    tParseValidate signed t@(sig, corrId, queueId, command) = do
+      let cmd = parseProtocol command >>= checkCredentials t
+      pure (sig, signed, (CorrId corrId, queueId, cmd))

src/Simplex/Messaging/Server.hs

@@ -5,8 +5,6 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -25,61 +23,34 @@
 -- and optional append only log of SMP queue records.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
-module Simplex.Messaging.Server
-  ( runSMPServer,
-    runSMPServerBlocking,
-    disconnectTransport,
-    verifyCmdSignature,
-    dummyVerifyCmd,
-  )
-where
+module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where
 
-import Control.Logger.Simple
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
-import Data.Bifunctor (first)
-import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
-import Data.List (intercalate)
-import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.Time.Clock.System (getSystemTime)
 import Data.Type.Equality
-import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding (Encoding (smpEncode))
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
-import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
-import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
-import System.Exit (exitFailure)
-import System.IO (hPutStrLn)
-import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
-import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
@@ -87,7 +58,7 @@ import UnliftIO.STM
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
-runSMPServer :: ServerConfig -> IO ()
+runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m ()
 runSMPServer cfg = do
   started <- newEmptyTMVarIO
   runSMPServerBlocking started cfg
@@ -96,41 +67,39 @@ runSMPServer cfg = do
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
-
-type M a = ReaderT Env IO a
-
-smpServer :: TMVar Bool -> M ()
-smpServer started = do
-  s <- asks server
-  cfg@ServerConfig {transports} <- asks config
-  restoreServerStats
-  restoreServerMessages
-  raceAny_
-    ( serverThread s subscribedQ subscribers subscriptions cancelSub :
-      serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
-      map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
-    )
-    `finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
+runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
+runSMPServerBlocking started cfg@ServerConfig {transports} = do
+  env <- newEnv cfg
+  runReaderT smpServer env
   where
-    runServer :: (ServiceName, ATransport) -> M ()
+    smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
+    smpServer = do
+      s <- asks server
+      raceAny_
+        ( serverThread s subscribedQ subscribers subscriptions cancelSub :
+          serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
+          map runServer transports
+        )
+        `finally` withLog closeStoreLog
+
+    runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
       runTransportServer started tcpPort serverParams (runClient t)
 
     serverThread ::
-      forall s.
+      forall m' s.
+      MonadUnliftIO m' =>
       Server ->
       (Server -> TBQueue (QueueId, Client)) ->
-      (Server -> TMap QueueId Client) ->
-      (Client -> TMap QueueId s) ->
-      (s -> IO ()) ->
-      M ()
+      (Server -> TVar (M.Map QueueId Client)) ->
+      (Client -> TVar (M.Map QueueId s)) ->
+      (s -> m' ()) ->
+      m' ()
     serverThread s subQ subs clientSubs unsub = forever $ do
       atomically updateSubscribers
-        $>>= endPreviousSubscriptions
-        >>= liftIO . mapM_ unsub
+        >>= fmap join . mapM endPreviousSubscriptions
+        >>= mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
@@ -141,85 +110,36 @@ smpServer started = do
                   else do
                     yes <- readTVar $ connected c'
                     pure $ if yes then Just (qId, c') else Nothing
-          TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
-        endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
+          stateTVar (subs s) (\cs -> (M.lookup qId cs, M.insert qId clnt cs))
+            >>= fmap join . mapM clientToBeNotified
+        endPreviousSubscriptions :: (QueueId, Client) -> m' (Maybe s)
         endPreviousSubscriptions (qId, c) = do
           void . forkIO . atomically $
-            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
-          atomically $ TM.lookupDelete qId (clientSubs c)
+            writeTBQueue (sndQ c) (CorrId "", qId, END)
+          atomically . stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss)
 
-    expireMessagesThread_ :: ServerConfig -> [M ()]
-    expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
-    expireMessagesThread_ _ = []
-
-    expireMessages :: ExpirationConfig -> M ()
-    expireMessages expCfg = do
-      ms <- asks msgStore
-      quota <- asks $ msgQueueQuota . config
-      let interval = checkInterval expCfg * 1000000
-      forever $ do
-        threadDelay interval
-        old <- liftIO $ expireBeforeEpoch expCfg
-        rIds <- M.keysSet <$> readTVarIO ms
-        forM_ rIds $ \rId ->
-          atomically (getMsgQueue ms rId quota)
-            >>= atomically . (`deleteExpiredMsgs` old)
-
-    serverStatsThread_ :: ServerConfig -> [M ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
-      [logServerStats logStatsStartTime interval serverStatsLogFile]
-    serverStatsThread_ _ = []
-
-    logServerStats :: Int -> Int -> FilePath -> M ()
-    logServerStats startAt logInterval statsFilePath = do
-      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
-      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
-      let interval = 1000000 * logInterval
-      withFile statsFilePath AppendMode $ \h -> liftIO $ do
-        hSetBuffering h LineBuffering
-        forever $ do
-          ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          qCreated' <- atomically $ swapTVar qCreated 0
-          qSecured' <- atomically $ swapTVar qSecured 0
-          qDeleted' <- atomically $ swapTVar qDeleted 0
-          msgSent' <- atomically $ swapTVar msgSent 0
-          msgRecv' <- atomically $ swapTVar msgRecv 0
-          ps <- atomically $ periodStatCounts activeQueues ts
-          hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayCount ps, weekCount ps, monthCount ps]
-          threadDelay interval
-
-    runClient :: Transport c => TProxy c -> c -> M ()
+    runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
     runClient _ h = do
       kh <- asks serverIdentity
-      smpVRange <- asks $ smpServerVRange . config
-      liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
+      liftIO (runExceptT $ serverHandshake h kh) >>= \case
         Right th -> runClientTransport th
         Left _ -> pure ()
 
-runClientTransport :: Transport c => THandle c -> M ()
-runClientTransport th@THandle {thVersion, sessionId} = do
+runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
+runClientTransport th@THandle {sessionId} = do
   q <- asks $ tbqSize . config
-  ts <- liftIO getSystemTime
-  c <- atomically $ newClient q thVersion sessionId ts
+  c <- atomically $ newClient q sessionId
   s <- asks server
-  expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
+  raceAny_ [send th c, client c s, receive th c]
     `finally` clientDisconnected c
-  where
-    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th c activeAt expCfg]
-    disconnectThread_ _ _ = []
 
-clientDisconnected :: Client -> M ()
+clientDisconnected :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
 clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
-  liftIO $ mapM_ cancelSub subs
-  atomically $ writeTVar subscriptions M.empty
+  mapM_ cancelSub subs
   cs <- asks $ subscribers . server
-  atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
+  atomically . mapM_ (modifyTVar cs . M.update deleteCurrentClient) $ M.keys subs
   where
     deleteCurrentClient :: Client -> Maybe Client
     deleteCurrentClient c'
@@ -229,85 +149,55 @@ clientDisconnected c@Client {subscriptions, connected} = do
 sameClientSession :: Client -> Client -> Bool
 sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
-cancelSub :: TVar Sub -> IO ()
-cancelSub sub =
-  readTVarIO sub >>= \case
-    Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
-    _ -> return ()
+cancelSub :: MonadUnliftIO m => Sub -> m ()
+cancelSub = \case
+  Sub {subThread = SubThread t} -> killThread t
+  _ -> return ()
 
-receive :: Transport c => THandle c -> Client -> M ()
-receive th Client {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- L.toList <$> tGet th
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-  as <- partitionEithers <$> mapM cmdAction ts
-  write sndQ $ fst as
-  write rcvQ $ snd as
+receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
+receive th Client {rcvQ, sndQ} = forever $ do
+  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
+  case cmdOrError of
+    Left e -> write sndQ (corrId, queueId, ERR e)
+    Right cmd -> do
+      verified <- verifyTransmission sig signed queueId cmd
+      if verified
+        then write rcvQ (corrId, queueId, cmd)
+        else write sndQ (corrId, queueId, ERR AUTH)
   where
-    cmdAction :: SignedTransmission Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
-    cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
-      case cmdOrError of
-        Left e -> pure $ Left (corrId, queueId, ERR e)
-        Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
-          where
-            verified = \case
-              VRVerified qr -> Right (qr, (corrId, queueId, cmd))
-              VRFailed -> Left (corrId, queueId, ERR AUTH)
-    write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
+    write q t = atomically $ writeTBQueue q t
 
-send :: Transport c => THandle c -> Client -> IO ()
-send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
-  ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-  -- TODO the line below can return Lefts, but we ignore it and do not disconnect the client
-  void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-  where
-    tOrder :: Transmission BrokerMsg -> Int
-    tOrder (_, _, cmd) = case cmd of
-      MSG {} -> 0
-      _ -> 1
+send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
+send h Client {sndQ, sessionId} = forever $ do
+  t <- atomically $ readTBQueue sndQ
+  liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
 
-disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
-disconnectTransport THandle {connection} c activeAt expCfg = do
-  let interval = checkInterval expCfg * 1000000
-  forever . liftIO $ do
-    threadDelay interval
-    old <- expireBeforeEpoch expCfg
-    ts <- readTVarIO $ activeAt c
-    when (systemSeconds ts < old) $ closeConnection connection
-
-data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
-
-verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
+verifyTransmission ::
+  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
 verifyTransmission sig_ signed queueId cmd = do
   case cmd of
-    Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
-    Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
-    Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
-    Cmd SSender PING -> pure $ VRVerified Nothing
-    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
+    Cmd SRecipient (NEW k _) -> pure $ verifySignature k
+    Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
+    Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
+    Cmd SSender PING -> pure True
+    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
     verifyCmd party f = do
       st <- asks queueStore
-      q_ <- atomically (getQueue st party queueId)
-      pure $ case q_ of
-        Right q -> Just q `verified` f q
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+      q <- atomically $ getQueue st party queueId
+      pure $ either (const $ maybe False dummyVerify sig_ `seq` False) f q
     verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
-    verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
-    verified q cond = if cond then VRVerified q else VRFailed
-
-verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
-verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
-  where
+    verifyMaybe = maybe (isNothing sig_) verifySignature
+    verifySignature :: C.APublicVerifyKey -> Bool
+    verifySignature key = maybe False (verify key) sig_
     verify :: C.APublicVerifyKey -> C.ASignature -> Bool
     verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =
       case (testEquality a a', C.signatureSize k == C.signatureSize s) of
         (Just Refl, True) -> C.verify' k s signed
-        _ -> dummyVerifyCmd signed sig `seq` False
-
-dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
-dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
+        _ -> dummyVerify sig `seq` False
+    dummyVerify :: C.ASignature -> Bool
+    dummyVerify (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
 
 -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
 -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
@@ -323,43 +213,33 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
+client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
-      >>= mapM processCommand
+      >>= processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
-    processCommand (qr_, (corrId, queueId, cmd)) = do
+    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
+    processCommand (corrId, queueId, cmd) = do
       st <- asks queueStore
       case cmd of
         Cmd SSender command ->
           case command of
-            SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
+            SEND msgBody -> sendMessage st msgBody
             PING -> pure (corrId, "", PONG)
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
           case command of
-            NEW rKey dhKey auth ->
-              ifM
-                allowNew
-                (createQueue st rKey dhKey)
-                (pure (corrId, queueId, ERR AUTH))
-              where
-                allowNew = do
-                  ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
-                  pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
-            SUB -> withQueue (`subscribeQueue` queueId)
-            GET -> withQueue getMessage
-            ACK msgId -> withQueue (`acknowledgeMsg` msgId)
+            NEW rKey dhKey -> createQueue st rKey dhKey
+            SUB -> subscribeQueue queueId
+            ACK -> acknowledgeMsg
             KEY sKey -> secureQueue_ st sKey
-            NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
-            NDEL -> deleteQueueNotifier_ st
+            NKEY nKey -> addQueueNotifier_ st nKey
             OFF -> suspendQueue_ st
             DEL -> delQueueAndMsgs st
       where
         createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg)
-        createQueue st recipientKey dhKey = time "NEW" $ do
+        createQueue st recipientKey dhKey = do
           (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvDhSecret = C.dh' dhKey privDhKey
               qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
@@ -381,15 +261,12 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             addQueueRetry n qik qRec = do
               ids@(rId, _) <- getIds
               -- create QueueRec record with these ids and keys
-              let qr = qRec ids
-              atomically (addQueue st qr) >>= \case
+              atomically (addQueue st $ qRec ids) >>= \case
                 Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
                 Left e -> pure $ ERR e
                 Right _ -> do
                   withLog (`logCreateById` rId)
-                  stats <- asks serverStats
-                  atomically $ modifyTVar (qCreated stats) (+ 1)
-                  subscribeQueue qr rId $> IDS (qik ids)
+                  subscribeQueue rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -403,243 +280,141 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               liftM2 (,) (randomId n) (randomId n)
 
         secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
-        secureQueue_ st sKey = time "KEY" $ do
+        secureQueue_ st sKey = do
           withLog $ \s -> logSecureQueue s queueId sKey
-          stats <- asks serverStats
-          atomically $ modifyTVar (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
-        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
-        addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
-          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
-          let rcvNtfDhSecret = C.dh' dhKey privDhKey
-          (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
+        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
+        addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
           where
-            addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> m BrokerMsg
-            addNotifierRetry 0 _ _ = pure $ ERR INTERNAL
-            addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
-              notifierId <- randomId =<< asks (queueIdBytes . config)
-              let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
-              atomically (addQueueNotifier st queueId ntfCreds) >>= \case
-                Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
+            addNotifierRetry :: Int -> m BrokerMsg
+            addNotifierRetry 0 = pure $ ERR INTERNAL
+            addNotifierRetry n = do
+              nId <- randomId =<< asks (queueIdBytes . config)
+              atomically (addQueueNotifier st queueId nId nKey) >>= \case
+                Left DUPLICATE_ -> addNotifierRetry $ n - 1
                 Left e -> pure $ ERR e
                 Right _ -> do
-                  withLog $ \s -> logAddNotifier s queueId ntfCreds
-                  pure $ NID notifierId rcvPublicDhKey
-
-        deleteQueueNotifier_ :: QueueStore -> m (Transmission BrokerMsg)
-        deleteQueueNotifier_ st = do
-          withLog (`logDeleteNotifier` queueId)
-          okResp <$> atomically (deleteQueueNotifier st queueId)
+                  withLog $ \s -> logAddNotifier s queueId nId nKey
+                  pure $ NID nId
 
         suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
-          withLog (`logSuspendQueue` queueId)
+          withLog (`logDeleteQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue qr rId = do
-          atomically (TM.lookup rId subscriptions) >>= \case
-            Nothing ->
-              newSub >>= deliver
-            Just sub ->
-              readTVarIO sub >>= \case
-                Sub {subThread = ProhibitSub} ->
-                  -- cannot use SUB in the same connection where GET was used
-                  pure (corrId, rId, ERR $ CMD PROHIBITED)
-                s ->
-                  atomically (tryTakeTMVar $ delivered s) >> deliver sub
-          where
-            newSub :: m (TVar Sub)
-            newSub = time "SUB newSub" . atomically $ do
+        subscribeQueue :: RecipientId -> m (Transmission BrokerMsg)
+        subscribeQueue rId =
+          atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId
+
+        getSubscription :: RecipientId -> STM Sub
+        getSubscription rId = do
+          subs <- readTVar subscriptions
+          case M.lookup rId subs of
+            Just s -> tryTakeTMVar (delivered s) $> s
+            Nothing -> do
               writeTBQueue subscribedQ (rId, clnt)
-              sub <- newTVar =<< newSubscription NoSub
-              TM.insert rId sub subscriptions
-              pure sub
-            deliver :: TVar Sub -> m (Transmission BrokerMsg)
-            deliver sub = do
-              q <- getStoreMsgQueue "SUB" rId
-              msg_ <- atomically $ tryPeekMsg q
-              deliverMessage "SUB" qr rId sub q msg_
-
-        getMessage :: QueueRec -> m (Transmission BrokerMsg)
-        getMessage qr = time "GET" $ do
-          atomically (TM.lookup queueId subscriptions) >>= \case
-            Nothing ->
-              atomically newSub >>= getMessage_
-            Just sub ->
-              readTVarIO sub >>= \case
-                s@Sub {subThread = ProhibitSub} ->
-                  atomically (tryTakeTMVar $ delivered s)
-                    >> getMessage_ s
-                -- cannot use GET in the same connection where there is an active subscription
-                _ -> pure (corrId, queueId, ERR $ CMD PROHIBITED)
-          where
-            newSub :: STM Sub
-            newSub = do
-              s <- newSubscription ProhibitSub
-              sub <- newTVar s
-              TM.insert queueId sub subscriptions
-              pure s
-            getMessage_ :: Sub -> m (Transmission BrokerMsg)
-            getMessage_ s = do
-              q <- getStoreMsgQueue "GET" queueId
-              atomically $
-                tryPeekMsg q >>= \case
-                  Just msg ->
-                    let encMsg = encryptMsg qr msg
-                     in setDelivered s msg $> (corrId, queueId, MSG encMsg)
-                  _ -> pure (corrId, queueId, OK)
-
-        withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
-        withQueue action = maybe (pure $ err AUTH) action qr_
+              s <- newSubscription
+              writeTVar subscriptions $ M.insert rId s subs
+              return s
 
         subscribeNotifications :: m (Transmission BrokerMsg)
-        subscribeNotifications = time "NSUB" . atomically $ do
-          unlessM (TM.member queueId ntfSubscriptions) $ do
+        subscribeNotifications = atomically $ do
+          subs <- readTVar ntfSubscriptions
+          when (isNothing $ M.lookup queueId subs) $ do
             writeTBQueue ntfSubscribedQ (queueId, clnt)
-            TM.insert queueId () ntfSubscriptions
+            writeTVar ntfSubscriptions $ M.insert queueId () subs
           pure ok
 
-        acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg qr msgId = time "ACK" $ do
-          atomically (TM.lookup queueId subscriptions) >>= \case
-            Nothing -> pure $ err NO_MSG
-            Just sub ->
-              atomically (getDelivered sub) >>= \case
-                Just s -> do
-                  q <- getStoreMsgQueue "ACK" queueId
-                  case s of
-                    Sub {subThread = ProhibitSub} -> do
-                      msgDeleted <- atomically $ tryDelMsg q msgId
-                      when msgDeleted updateStats
-                      pure ok
-                    _ -> do
-                      (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
-                      when msgDeleted updateStats
-                      deliverMessage "ACK" qr queueId sub q msg_
-                _ -> pure $ err NO_MSG
-          where
-            getDelivered :: TVar Sub -> STM (Maybe Sub)
-            getDelivered sub = do
-              s@Sub {delivered} <- readTVar sub
-              tryTakeTMVar delivered $>>= \msgId' ->
-                if msgId == msgId' || B.null msgId
-                  then pure $ Just s
-                  else putTMVar delivered msgId' $> Nothing
-            updateStats :: m ()
-            updateStats = do
-              stats <- asks serverStats
-              atomically $ modifyTVar (msgRecv stats) (+ 1)
-              atomically $ updatePeriodStats (activeQueues stats) queueId
+        acknowledgeMsg :: m (Transmission BrokerMsg)
+        acknowledgeMsg =
+          atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
+            >>= \case
+              Just (Just s) -> deliverMessage tryDelPeekMsg queueId s
+              _ -> return $ err NO_MSG
 
-        sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage qr msgFlags msgBody
+        withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
+        withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
+
+        sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage st msgBody
           | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
-          | otherwise = case status qr of
-            QueueOff -> return $ err AUTH
-            QueueActive ->
-              mapM mkMessage (C.maxLenBS msgBody) >>= \case
-                Left _ -> pure $ err LARGE_MSG
-                Right msg -> do
-                  resp@(_, _, sent) <- time "SEND" $ do
-                    q <- getStoreMsgQueue "SEND" $ recipientId qr
-                    expireMessages q
-                    atomically $ ifM (isFull q) (pure $ err QUOTA) (writeMsg q msg $> ok)
-                  when (sent == OK) . time "SEND ok" $ do
-                    when (notification msgFlags) $
-                      atomically . trySendNotification msg =<< asks idsDrg
-                    stats <- asks serverStats
-                    atomically $ modifyTVar (msgSent stats) (+ 1)
-                    atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
-                  pure resp
+          | otherwise = do
+            qr <- atomically $ getQueue st SSender queueId
+            either (return . err) storeMessage qr
           where
-            mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
-            mkMessage body = do
-              msgId <- randomId =<< asks (msgIdBytes . config)
-              msgTs <- liftIO getSystemTime
-              pure $ Message msgId msgTs msgFlags body
+            storeMessage :: QueueRec -> m (Transmission BrokerMsg)
+            storeMessage qr = case status qr of
+              QueueOff -> return $ err AUTH
+              QueueActive ->
+                mkMessage >>= \case
+                  Left _ -> pure $ err LARGE_MSG
+                  Right msg -> do
+                    ms <- asks msgStore
+                    quota <- asks $ msgQueueQuota . config
+                    atomically $ do
+                      q <- getMsgQueue ms (recipientId qr) quota
+                      ifM (isFull q) (pure $ err QUOTA) $ do
+                        trySendNotification
+                        writeMsg q msg
+                        pure ok
+              where
+                mkMessage :: m (Either C.CryptoError Message)
+                mkMessage = do
+                  msgId <- randomId =<< asks (msgIdBytes . config)
+                  ts <- liftIO getSystemTime
+                  let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
+                  pure $ Message msgId ts <$> c
 
-            expireMessages :: MsgQueue -> m ()
-            expireMessages q = do
-              msgExp <- asks $ messageExpiration . config
-              old <- liftIO $ mapM expireBeforeEpoch msgExp
-              atomically $ mapM_ (deleteExpiredMsgs q) old
+                trySendNotification :: STM ()
+                trySendNotification =
+                  forM_ (notifier qr) $ \(nId, _) ->
+                    mapM_ (writeNtf nId) . M.lookup nId =<< readTVar notifiers
 
-            trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
-            trySendNotification msg ntfNonceDrg =
-              forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
-                mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
+                writeNtf :: NotifierId -> Client -> STM ()
+                writeNtf nId Client {sndQ = q} =
+                  unlessM (isFullTBQueue sndQ) $
+                    writeTBQueue q (CorrId "", nId, NMSG)
 
-            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
-            writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-              unlessM (isFullTBQueue q) $ do
-                (nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
-                writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
-
-            mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-            mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
-              cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
-              let msgMeta = NMsgMeta {msgId, msgTs}
-                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
-              pure . (cbNonce,) $ fromRight "" encNMsgMeta
-
-        deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do
-          readTVarIO sub >>= \case
-            s@Sub {subThread = NoSub} ->
-              case msg_ of
-                Just msg ->
-                  let encMsg = encryptMsg qr msg
-                   in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
-                _ -> forkSub $> ok
-            _ -> pure ok
+        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg)
+        deliverMessage tryPeek rId = \case
+          Sub {subThread = NoSub} -> do
+            ms <- asks msgStore
+            quota <- asks $ msgQueueQuota . config
+            q <- atomically $ getMsgQueue ms rId quota
+            atomically (tryPeek q) >>= \case
+              Nothing -> forkSub q $> ok
+              Just msg -> atomically setDelivered $> (corrId, rId, msgCmd msg)
+          _ -> pure ok
           where
-            forkSub :: m ()
-            forkSub = do
-              atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
-              t <- mkWeakThreadId =<< forkIO subscriber
-              atomically . modifyTVar sub $ \case
+            forkSub :: MsgQueue -> m ()
+            forkSub q = do
+              atomically . setSub $ \s -> s {subThread = SubPending}
+              t <- forkIO $ subscriber q
+              atomically . setSub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
-              where
-                subscriber = do
-                  msg <- atomically $ peekMsg q
-                  time "subscriber" . atomically $ do
-                    let encMsg = encryptMsg qr msg
-                    writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
-                    s <- readTVar sub
-                    void $ setDelivered s msg
-                    writeTVar sub s {subThread = NoSub}
 
-        time :: T.Text -> m a -> m a
-        time name = timed name queueId
+            subscriber :: MsgQueue -> m ()
+            subscriber q = atomically $ do
+              msg <- peekMsg q
+              writeTBQueue sndQ (CorrId "", rId, msgCmd msg)
+              setSub (\s -> s {subThread = NoSub})
+              void setDelivered
 
-        encryptMsg :: QueueRec -> Message -> RcvMessage
-        encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody}
-          | thVersion == 1 || thVersion == 2 = encrypt msgBody
-          | otherwise = encrypt $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
-          where
-            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
-            encrypt body =
-              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId) body
-               in RcvMessage msgId msgTs msgFlags encBody
+            setSub :: (Sub -> Sub) -> STM ()
+            setSub f = modifyTVar subscriptions $ M.adjust f rId
 
-        setDelivered :: Sub -> Message -> STM Bool
-        setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
+            setDelivered :: STM (Maybe Bool)
+            setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
 
-        getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue
-        getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
-          ms <- asks msgStore
-          quota <- asks $ msgQueueQuota . config
-          atomically $ getMsgQueue ms rId quota
+            msgCmd :: Message -> BrokerMsg
+            msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
 
         delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
         delQueueAndMsgs st = do
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
-          stats <- asks serverStats
-          atomically $ modifyTVar (qDeleted stats) (+ 1)
           atomically $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -659,95 +434,14 @@ withLog action = do
   env <- ask
   liftIO . mapM_ action $ storeLog (env :: Env)
 
-timed :: MonadUnliftIO m => T.Text -> RecipientId -> m a -> m a
-timed name qId a = do
-  t <- liftIO getSystemTime
-  r <- a
-  t' <- liftIO getSystemTime
-  let int = diff t t'
-  when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int]
-  pure r
-  where
-    diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
-    sec = 1000_000000
-
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
-  atomically (C.pseudoRandomBytes n gVar)
+  atomically (randomBytes n gVar)
 
-saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
-saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
-  where
-    saveMessages f = do
-      logInfo $ "saving messages to file " <> T.pack f
-      ms <- asks msgStore
-      liftIO . withFile f WriteMode $ \h ->
-        readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
-      logInfo "messages saved"
-      where
-        saveQueueMsgs ms h rId =
-          atomically (flushMsgQueue ms rId)
-            >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
-
-restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
-restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
-  where
-    restoreMessages f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring messages from file " <> T.pack f
-      st <- asks queueStore
-      ms <- asks msgStore
-      quota <- asks $ msgQueueQuota . config
-      runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
-        Left e -> do
-          logError . T.pack $ "error restoring messages: " <> e
-          liftIO exitFailure
-        _ -> do
-          renameFile f $ f <> ".bak"
-          logInfo "messages restored"
-      where
-        restoreMsg st ms quota s = do
-          r <- liftEither . first (msgErr "parsing") $ strDecode s
-          case r of
-            MLRv3 rId msg -> addToMsgQueue rId msg
-            MLRv1 rId encMsg -> do
-              qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
-              msg' <- updateMsgV1toV3 qr encMsg
-              addToMsgQueue rId msg'
-          where
-            addToMsgQueue rId msg = do
-              full <- atomically $ do
-                q <- getMsgQueue ms rId quota
-                ifM (isFull q) (pure True) (writeMsg q msg $> False)
-              when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
-            updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
-              let nonce = C.cbNonce msgId
-              msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
-              pure Message {msgId, msgTs, msgFlags, msgBody}
-            msgErr :: Show e => String -> e -> String
-            msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
-
-saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-saveServerStats =
-  asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
-  where
-    saveStats f stats = do
-      logInfo $ "saving server stats to file " <> T.pack f
-      B.writeFile f $ strEncode stats
-      logInfo "server stats saved"
-
-restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
-  where
-    restoreStats f = whenM (doesFileExist f) $ do
-      logInfo $ "restoring server stats from file " <> T.pack f
-      liftIO (strDecode <$> B.readFile f) >>= \case
-        Right d -> do
-          s <- asks serverStats
-          atomically $ setServerStats s d
-          renameFile f $ f <> ".bak"
-          logInfo "server stats restored"
-        Left e -> do
-          logInfo $ "error restoring server stats: " <> T.pack e
-          liftIO exitFailure
+randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
+randomBytes n gVar = do
+  g <- readTVar gVar
+  let (bytes, g') = randomBytesGenerate n g
+  writeTVar gVar g'
+  return bytes

src/Simplex/Messaging/Server/CLI.hs

@@ -1,234 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Simplex.Messaging.Server.CLI where
-
-import Control.Monad
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
-import Data.Ini (Ini, lookupValue)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.X509.Validation (Fingerprint (..))
-import Network.Socket (HostName, ServiceName)
-import Options.Applicative
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
-import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
-import Simplex.Messaging.Transport.Server (loadFingerprint)
-import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (whenM)
-import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
-import System.Exit (exitFailure)
-import System.FilePath (combine)
-import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
-import System.Process (readCreateProcess, shell)
-
-exitError :: String -> IO ()
-exitError msg = putStrLn msg >> exitFailure
-
-confirmOrExit :: String -> IO ()
-confirmOrExit s =
-  withPrompt (s <> "\nContinue (Y/n): ") $ do
-    ok <- getLine
-    when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
-
-data SignAlgorithm = ED448 | ED25519
-  deriving (Read, Show)
-
-data X509Config = X509Config
-  { commonName :: HostName,
-    signAlgorithm :: SignAlgorithm,
-    caKeyFile :: FilePath,
-    caCrtFile :: FilePath,
-    serverKeyFile :: FilePath,
-    serverCrtFile :: FilePath,
-    fingerprintFile :: FilePath,
-    opensslCaConfFile :: FilePath,
-    opensslServerConfFile :: FilePath,
-    serverCsrFile :: FilePath
-  }
-
-defaultX509Config :: X509Config
-defaultX509Config =
-  X509Config
-    { commonName = "127.0.0.1",
-      signAlgorithm = ED448,
-      caKeyFile = "ca.key",
-      caCrtFile = "ca.crt",
-      serverKeyFile = "server.key",
-      serverCrtFile = "server.crt",
-      fingerprintFile = "fingerprint",
-      opensslCaConfFile = "openssl_ca.conf",
-      opensslServerConfFile = "openssl_server.conf",
-      serverCsrFile = "server.csr"
-    }
-
-getCliCommand' :: Parser cmd -> String -> IO cmd
-getCliCommand' cmdP version =
-  customExecParser
-    (prefs showHelpOnEmpty)
-    ( info
-        (helper <*> versionOption <*> cmdP)
-        (header version <> fullDesc)
-    )
-  where
-    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
-
-createServerX509 :: FilePath -> X509Config -> IO ByteString
-createServerX509 cfgPath x509cfg = do
-  createOpensslCaConf
-  createOpensslServerConf
-  let alg = show $ signAlgorithm (x509cfg :: X509Config)
-  -- CA certificate (identity/offline)
-  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
-  run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
-  -- server certificate (online)
-  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile
-  run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile
-  run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile
-  saveFingerprint
-  where
-    run cmd = void $ readCreateProcess (shell cmd) ""
-    c = combine cfgPath . ($ x509cfg)
-    createOpensslCaConf =
-      writeFile
-        (c opensslCaConfFile)
-        "[req]\n\
-        \distinguished_name = req_distinguished_name\n\
-        \prompt = no\n\n\
-        \[req_distinguished_name]\n\
-        \CN = SMP server CA\n\
-        \O = SimpleX\n\n\
-        \[v3]\n\
-        \subjectKeyIdentifier = hash\n\
-        \authorityKeyIdentifier = keyid:always\n\
-        \basicConstraints = critical,CA:true\n"
-    -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-    -- IP and FQDN can't both be used as server address interchangeably even if IP is added
-    -- as Subject Alternative Name, unless the following validation hook is disabled:
-    -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
-    createOpensslServerConf =
-      writeFile
-        (c opensslServerConfFile)
-        ( "[req]\n\
-          \distinguished_name = req_distinguished_name\n\
-          \prompt = no\n\n\
-          \[req_distinguished_name]\n"
-            <> ("CN = " <> commonName x509cfg <> "\n\n")
-            <> "[v3]\n\
-               \basicConstraints = CA:FALSE\n\
-               \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
-               \extendedKeyUsage = serverAuth\n"
-        )
-
-    saveFingerprint = do
-      Fingerprint fp <- loadFingerprint $ c caCrtFile
-      withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
-      pure fp
-
-warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
-warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} =
-  putStrLn $
-    "----------\n\
-    \You should store CA private key securely and delete it from the server.\n\
-    \If server TLS credential is compromised this key can be used to sign a new one, \
-    \keeping the same server identity and established connections.\n\
-    \CA private key location:\n"
-      <> combine cfgPath caKeyFile
-      <> "\n----------"
-
-data IniOptions = IniOptions
-  { enableStoreLog :: Bool,
-    port :: ServiceName,
-    enableWebsockets :: Bool
-  }
-
-mkIniOptions :: Ini -> IniOptions
-mkIniOptions ini =
-  IniOptions
-    { enableStoreLog = (== "on") $ strictIni "STORE_LOG" "enable" ini,
-      port = T.unpack $ strictIni "TRANSPORT" "port" ini,
-      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
-    }
-
-strictIni :: Text -> Text -> Ini -> Text
-strictIni section key ini =
-  fromRight (error . T.unpack $ "no key " <> key <> " in section " <> section) $
-    lookupValue section key ini
-
-readStrictIni :: Read a => Text -> Text -> Ini -> a
-readStrictIni section key = read . T.unpack . strictIni section key
-
-iniOnOff :: Text -> Text -> Ini -> Maybe Bool
-iniOnOff section name ini = case lookupValue section name ini of
-  Right "on" -> Just True
-  Right "off" -> Just False
-  Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s
-  _ -> Nothing
-
-withPrompt :: String -> IO a -> IO a
-withPrompt s a = putStr s >> hFlush stdout >> a
-
-onOffPrompt :: String -> Bool -> IO Bool
-onOffPrompt prompt def =
-  withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $
-    getLine >>= \case
-      "" -> pure def
-      "y" -> pure True
-      "Y" -> pure True
-      "n" -> pure False
-      "N" -> pure False
-      _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def
-
-onOff :: Bool -> String
-onOff True = "on"
-onOff _ = "off"
-
-settingIsOn :: Text -> Text -> Ini -> Maybe ()
-settingIsOn section name ini
-  | iniOnOff section name ini == Just True = Just ()
-  | otherwise = Nothing
-
-checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
-checkSavedFingerprint cfgPath x509cfg = do
-  savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
-  Fingerprint fp <- loadFingerprint (c caCrtFile)
-  when (B.pack savedFingerprint /= strEncode fp) $
-    exitError "Stored fingerprint is invalid."
-  pure fp
-  where
-    c = combine cfgPath . ($ x509cfg)
-
-iniTransports :: Ini -> [(String, ATransport)]
-iniTransports ini =
-  let port = T.unpack $ strictIni "TRANSPORT" "port" ini
-      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
-   in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
-
-printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
-printServerConfig transports logFile = do
-  putStrLn $ case logFile of
-    Just f -> "Store log: " <> f
-    _ -> "Store log disabled."
-  forM_ transports $ \(p, ATransport t) ->
-    putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
-
-deleteDirIfExists :: FilePath -> IO ()
-deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
-
-printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO ()
-printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash} _) = do
-  putStrLn serverVersion
-  B.putStrLn $ "Fingerprint: " <> strEncode keyHash
-  B.putStrLn $ "Server address: " <> strEncode srv
-
-clearDirIfExists :: FilePath -> IO ()
-clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)

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

@@ -9,30 +9,21 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
-import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock.System (SystemTime)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural
 import Simplex.Messaging.Crypto (KeyHash (..))
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.STM
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
+import Simplex.Messaging.Server.QueueStore (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
-import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport)
 import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
-import Simplex.Messaging.Version
 import System.IO (IOMode (..))
-import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
@@ -42,48 +33,13 @@ data ServerConfig = ServerConfig
     msgQueueQuota :: Natural,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    storeLogFile :: Maybe FilePath,
-    storeMsgsFile :: Maybe FilePath,
-    -- | set to False to prohibit creating new queues
-    allowNewQueues :: Bool,
-    -- | simple password that the clients need to pass in handshake to be able to create new queues
-    newQueueBasicAuth :: Maybe BasicAuth,
-    -- | time after which the messages can be removed from the queues and check interval, seconds
-    messageExpiration :: Maybe ExpirationConfig,
-    -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
-    -- and check interval, seconds
-    inactiveClientExpiration :: Maybe ExpirationConfig,
-    -- | log SMP server usage statistics, only aggregates are logged, seconds
-    logStatsInterval :: Maybe Int,
-    -- | time of the day when the stats are logged first, to log at consistent times,
-    -- irrespective of when the server is started (seconds from 00:00 UTC)
-    logStatsStartTime :: Int,
-    -- | file to log stats
-    serverStatsLogFile :: FilePath,
-    -- | file to save and restore stats
-    serverStatsBackupFile :: Maybe FilePath,
-    -- | CA certificate private key is not needed for initialization
+    storeLog :: Maybe (StoreLog 'ReadMode),
+    -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath,
-    -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    certificateFile :: FilePath
   }
 
-defaultMessageExpiration :: ExpirationConfig
-defaultMessageExpiration =
-  ExpirationConfig
-    { ttl = 30 * 86400, -- seconds, 30 days
-      checkInterval = 43200 -- seconds, 12 hours
-    }
-
-defaultInactiveClientExpiration :: ExpirationConfig
-defaultInactiveClientExpiration =
-  ExpirationConfig
-    { ttl = 86400, -- seconds, 24 hours
-      checkInterval = 43200 -- seconds, 12 hours
-    }
-
 data Env = Env
   { config :: ServerConfig,
     server :: Server,
@@ -92,83 +48,80 @@ data Env = Env
     msgStore :: STMMsgStore,
     idsDrg :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    tlsServerParams :: T.ServerParams,
-    serverStats :: ServerStats
+    tlsServerParams :: T.ServerParams
   }
 
 data Server = Server
   { subscribedQ :: TBQueue (RecipientId, Client),
-    subscribers :: TMap RecipientId Client,
+    subscribers :: TVar (Map RecipientId Client),
     ntfSubscribedQ :: TBQueue (NotifierId, Client),
-    notifiers :: TMap NotifierId Client
+    notifiers :: TVar (Map NotifierId Client)
   }
 
 data Client = Client
-  { subscriptions :: TMap RecipientId (TVar Sub),
-    ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
-    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
-    thVersion :: Version,
+  { subscriptions :: TVar (Map RecipientId Sub),
+    ntfSubscriptions :: TVar (Map NotifierId ()),
+    rcvQ :: TBQueue (Transmission Cmd),
+    sndQ :: TBQueue (Transmission BrokerMsg),
     sessionId :: ByteString,
-    connected :: TVar Bool,
-    activeAt :: TVar SystemTime
+    connected :: TVar Bool
   }
 
-data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
+data SubscriptionThread = NoSub | SubPending | SubThread ThreadId
 
 data Sub = Sub
   { subThread :: SubscriptionThread,
-    delivered :: TMVar MsgId
+    delivered :: TMVar ()
   }
 
 newServer :: Natural -> STM Server
 newServer qSize = do
   subscribedQ <- newTBQueue qSize
-  subscribers <- TM.empty
+  subscribers <- newTVar M.empty
   ntfSubscribedQ <- newTBQueue qSize
-  notifiers <- TM.empty
+  notifiers <- newTVar M.empty
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
-newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
-newClient qSize thVersion sessionId ts = do
-  subscriptions <- TM.empty
-  ntfSubscriptions <- TM.empty
+newClient :: Natural -> ByteString -> STM Client
+newClient qSize sessionId = do
+  subscriptions <- newTVar M.empty
+  ntfSubscriptions <- newTVar M.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
-  activeAt <- newTVar ts
-  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected}
 
-newSubscription :: SubscriptionThread -> STM Sub
-newSubscription subThread = do
+newSubscription :: STM Sub
+newSubscription = do
   delivered <- newEmptyTMVar
-  return Sub {subThread, delivered}
+  return Sub {subThread = NoSub, delivered}
 
 newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
-newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
+newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do
   server <- atomically $ newServer (serverTbqSize config)
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
-  s' <- restoreQueues queueStore `mapM` storeLog
+  s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   let serverIdentity = KeyHash fp
-  serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
-  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams, serverStats}
+  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams}
   where
     restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
-    restoreQueues QueueStore {queues, senders, notifiers} s = do
-      (qs, s') <- liftIO $ readWriteStoreLog s
-      atomically $ do
-        writeTVar queues =<< mapM newTVar qs
-        writeTVar senders $ M.foldr' addSender M.empty qs
-        writeTVar notifiers $ M.foldr' addNotifier M.empty qs
+    restoreQueues queueStore s = do
+      (queues, s') <- liftIO $ readWriteStoreLog s
+      atomically $
+        modifyTVar queueStore $ \d ->
+          d
+            { queues,
+              senders = M.foldr' addSender M.empty queues,
+              notifiers = M.foldr' addNotifier M.empty queues
+            }
       pure s'
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)
     addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
     addNotifier q = case notifier q of
       Nothing -> id
-      Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)
+      Just (nId, _) -> M.insert nId (recipientId q)

src/Simplex/Messaging/Server/Expiration.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Server.Expiration where
-
-import Control.Monad.IO.Class
-import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
-
-data ExpirationConfig = ExpirationConfig
-  { -- time after which the entity can be expired, seconds
-    ttl :: Int64,
-    -- interval to check expiration, seconds
-    checkInterval :: Int
-  }
-
-expireBeforeEpoch :: ExpirationConfig -> IO Int64
-expireBeforeEpoch ExpirationConfig {ttl} = subtract ttl . systemSeconds <$> liftIO getSystemTime

src/Simplex/Messaging/Server/Main.hs

@@ -1,283 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module Simplex.Messaging.Server.Main where
-
-import Control.Monad (void)
-import Crypto.Random (getRandomBytes)
-import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Network.Socket (HostName)
-import Options.Applicative
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
-import Simplex.Messaging.Server (runSMPServer)
-import Simplex.Messaging.Server.CLI
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
-import Simplex.Messaging.Transport.Client (TransportHost (..))
-import Simplex.Messaging.Util (safeDecodeUtf8)
-import System.Directory (createDirectoryIfMissing, doesFileExist)
-import System.FilePath (combine)
-import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
-import Text.Read (readMaybe)
-
-smpServerCLI :: FilePath -> FilePath -> IO ()
-smpServerCLI cfgPath logPath =
-  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
-    Init opts ->
-      doesFileExist iniFile >>= \case
-        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
-        _ -> initializeServer opts
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError runServer
-        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    Delete -> do
-      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
-      deleteDirIfExists cfgPath
-      deleteDirIfExists logPath
-      putStrLn "Deleted configuration and log files"
-  where
-    iniFile = combine cfgPath "smp-server.ini"
-    serverVersion = "SMP server v" <> simplexMQVersion
-    defaultServerPort = "5223"
-    executableName = "smp-server"
-    storeLogFilePath = combine logPath "smp-server-store.log"
-    initializeServer opts
-      | scripted opts = initialize opts
-      | otherwise = do
-        putStrLn "Use `smp-server init -h` for available options."
-        void $ withPrompt "SMP server will be initialized (press Enter)" getLine
-        enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
-        logStats <- onOffPrompt "Enable logging daily statistics" False
-        putStrLn "Require a password to create new messaging queues?"
-        password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
-        let host = fromMaybe (ip opts) (fqdn opts)
-        host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
-        initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
-      where
-        serverPassword =
-          getLine >>= \case
-            "" -> pure $ Just SPRandom
-            "r" -> pure $ Just SPRandom
-            "n" -> pure Nothing
-            s ->
-              case strDecode $ encodeUtf8 $ T.pack s of
-                Right auth -> pure . Just $ ServerPassword auth
-                _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
-        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do
-          clearDirIfExists cfgPath
-          clearDirIfExists logPath
-          createDirectoryIfMissing True cfgPath
-          createDirectoryIfMissing True logPath
-          let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
-          fp <- createServerX509 cfgPath x509cfg
-          basicAuth <- mapM createServerPassword password
-          let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
-              srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
-          writeFile iniFile $ iniFileContent host basicAuth
-          putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
-          warnCAPrivateKeyFile cfgPath x509cfg
-          printServiceInfo serverVersion srv
-          where
-            createServerPassword = \case
-              ServerPassword s -> pure s
-              SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString)
-            iniFileContent host basicAuth =
-              "[STORE_LOG]\n\
-              \# The server uses STM memory for persistence,\n\
-              \# that will be lost on restart (e.g., as with redis).\n\
-              \# This option enables saving memory to append only log,\n\
-              \# and restoring it when the server is started.\n\
-              \# Log is compacted on start (deleted objects are removed).\n"
-                <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
-                   \# they are preserved in the .bak file until the next restart.\n"
-                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
-                <> "# Log daily server statistics to CSV file\n"
-                <> ("log_stats: " <> onOff logStats <> "\n\n")
-                <> "[AUTH]\n"
-                <> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n"
-                <> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n"
-                <> "new_queues: on\n\n"
-                <> "# Use create_password option to enable basic auth to create new messaging queues.\n"
-                <> "# The password should be used as part of server address in client configuration:\n"
-                <> "# smp://fingerprint:password@host1,host2\n"
-                <> "# The password will not be shared with the connecting contacts, you must share it only\n"
-                <> "# with the users who you want to allow creating messaging queues on your server.\n"
-                <> ( case basicAuth of
-                       Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
-                       _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
-                   )
-                <> "\n\n"
-                <> "[TRANSPORT]\n"
-                <> "# host is only used to print server address on start\n"
-                <> ("host: " <> host <> "\n")
-                <> ("port: " <> defaultServerPort <> "\n")
-                <> "websockets: off\n\n"
-                <> "[INACTIVE_CLIENTS]\n\
-                   \# TTL and interval to check inactive clients\n\
-                   \disconnect: off\n"
-                <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-                <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
-    runServer ini = do
-      hSetBuffering stdout LineBuffering
-      hSetBuffering stderr LineBuffering
-      fp <- checkSavedFingerprint cfgPath defaultX509Config
-      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
-          port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig
-          srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
-      printServiceInfo serverVersion srv
-      printServerConfig transports storeLogFile
-      putStrLn $ case inactiveClientExpiration of
-        Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
-        _ -> "not expiring inactive clients"
-      putStrLn $
-        "creating new queues "
-          <> if allowNewQueues cfg
-            then maybe "allowed" (const "requires password") newQueueBasicAuth
-            else "NOT allowed"
-      runSMPServer cfg
-      where
-        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-        logStats = settingIsOn "STORE_LOG" "log_stats" ini
-        c = combine cfgPath . ($ defaultX509Config)
-        serverConfig =
-          ServerConfig
-            { transports = iniTransports ini,
-              tbqSize = 16,
-              serverTbqSize = 64,
-              msgQueueQuota = 128,
-              queueIdBytes = 24,
-              msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
-              caCertificateFile = c caCrtFile,
-              privateKeyFile = c serverKeyFile,
-              certificateFile = c serverCrtFile,
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile =
-                let messagesPath = combine logPath "smp-server-messages.log"
-                 in case iniOnOff "STORE_LOG" "restore_messages" ini of
-                      Just True -> Just messagesPath
-                      Just False -> Nothing
-                      -- if the setting is not set, it is enabled when store log is enabled
-                      _ -> enableStoreLog $> messagesPath,
-              -- allow creating new queues by default
-              allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
-              newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of
-                Right auth -> either error Just . strDecode $ encodeUtf8 auth
-                _ -> Nothing,
-              messageExpiration = Just defaultMessageExpiration,
-              inactiveClientExpiration =
-                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
-                  $> ExpirationConfig
-                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
-                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                    },
-              logStatsInterval = logStats $> 86400, -- seconds
-              logStatsStartTime = 0, -- seconds from 00:00 UTC
-              serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
-              serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
-              smpServerVRange = supportedSMPServerVRange
-            }
-
-data CliCommand
-  = Init InitOptions
-  | Start
-  | Delete
-
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    logStats :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName,
-    password :: Maybe ServerPassword,
-    scripted :: Bool
-  }
-  deriving (Show)
-
-data ServerPassword = ServerPassword BasicAuth | SPRandom
-  deriving (Show)
-
-cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
-cliCommandP cfgPath logPath iniFile =
-  hsubparser
-    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
-        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
-        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
-    )
-  where
-    initP :: Parser InitOptions
-    initP = do
-      enableStoreLog <-
-        switch
-          ( long "store-log"
-              <> short 'l'
-              <> help "Enable store log for persistence"
-          )
-      logStats <-
-        switch
-          ( long "daily-stats"
-              <> short 's'
-              <> help "Enable logging daily server statistics"
-          )
-      signAlgorithm <-
-        option
-          (maybeReader readMaybe)
-          ( long "sign-algorithm"
-              <> short 'a'
-              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
-              <> value ED448
-              <> showDefault
-              <> metavar "ALG"
-          )
-      ip <-
-        strOption
-          ( long "ip"
-              <> help
-                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
-              <> value "127.0.0.1"
-              <> showDefault
-              <> metavar "IP"
-          )
-      fqdn <-
-        (optional . strOption)
-          ( long "fqdn"
-              <> short 'n'
-              <> help "Server FQDN used as Common Name for TLS online certificate"
-              <> showDefault
-              <> metavar "FQDN"
-          )
-      password <-
-        flag' Nothing (long "no-password" <> help "Allow creating new queues without password")
-          <|> Just
-            <$> option
-              parseBasicAuth
-              ( long "password"
-                  <> metavar "PASSWORD"
-                  <> help "Set password to create new messaging queues"
-                  <> value SPRandom
-              )
-      scripted <-
-        switch
-          ( long "yes"
-              <> short 'y'
-              <> help "Non-interactive initialization using command-line options"
-          )
-      pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
-    parseBasicAuth :: ReadM ServerPassword
-    parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack

src/Simplex/Messaging/Server/MsgStore.hs

@@ -1,33 +1,24 @@
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
-import Control.Applicative ((<|>))
-import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime)
 import Numeric.Natural
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (Message (..), MsgId, RcvMessage (..), RecipientId)
+import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)
 
-data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
-
-instance StrEncoding MsgLogRecord where
-  strEncode = \case
-    MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
-    MLRv1 rId msg -> strEncode (rId, msg)
-  strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
+data Message = Message
+  { msgId :: MsgId,
+    ts :: SystemTime,
+    msgBody :: MsgBody
+  }
 
 class MonadMsgStore s q m | s -> q where
   getMsgQueue :: s -> RecipientId -> Natural -> m q
   delMsgQueue :: s -> RecipientId -> m ()
-  flushMsgQueue :: s -> RecipientId -> m [Message]
 
 class MonadMsgQueue q m where
   isFull :: q -> m Bool
   writeMsg :: q -> Message -> m () -- non blocking
   tryPeekMsg :: q -> m (Maybe Message) -- non blocking
   peekMsg :: q -> m Message -- blocking
-  tryDelMsg :: q -> MsgId -> m Bool -- non blocking
-  tryDelPeekMsg :: q -> MsgId -> m (Bool, Maybe Message) -- atomic delete (== read) last and peek next message, if available
-  deleteExpiredMsgs :: q -> Int64 -> m ()
+  tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available

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

@@ -2,47 +2,40 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
-import Control.Concurrent.STM.TBQueue (flushTBQueue)
-import Control.Monad (when)
-import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
-import Data.Int (Int64)
-import Data.Time.Clock.System (SystemTime (systemSeconds))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Numeric.Natural
-import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
+import Simplex.Messaging.Protocol (RecipientId)
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import UnliftIO.STM
 
 newtype MsgQueue = MsgQueue {msgQueue :: TBQueue Message}
 
-type STMMsgStore = TMap RecipientId MsgQueue
+newtype MsgStoreData = MsgStoreData {messages :: Map RecipientId MsgQueue}
+
+type STMMsgStore = TVar MsgStoreData
 
 newMsgStore :: STM STMMsgStore
-newMsgStore = TM.empty
+newMsgStore = newTVar $ MsgStoreData M.empty
 
 instance MonadMsgStore STMMsgStore MsgQueue STM where
   getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
-  getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
+  getMsgQueue store rId quota = do
+    m <- messages <$> readTVar store
+    maybe (newQ m) return $ M.lookup rId m
     where
-      newQ = do
+      newQ m' = do
         q <- MsgQueue <$> newTBQueue quota
-        TM.insert rId q st
+        writeTVar store . MsgStoreData $ M.insert rId q m'
         return q
 
   delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-  delMsgQueue st rId = TM.delete rId st
-
-  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
-  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
+  delMsgQueue store rId =
+    modifyTVar store $ MsgStoreData . M.delete rId . messages
 
 instance MonadMsgQueue MsgQueue STM where
   isFull :: MsgQueue -> STM Bool
@@ -57,27 +50,6 @@ instance MonadMsgQueue MsgQueue STM where
   peekMsg :: MsgQueue -> STM Message
   peekMsg = peekTBQueue . msgQueue
 
-  tryDelMsg :: MsgQueue -> MsgId -> STM Bool
-  tryDelMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      Just Message {msgId}
-        | msgId == msgId' || B.null msgId' -> tryReadTBQueue q $> True
-        | otherwise -> pure False
-      _ -> pure False
-
   -- atomic delete (== read) last and peek next message if available
-  tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
-  tryDelPeekMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      msg_@(Just Message {msgId})
-        | msgId == msgId' || B.null msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
-        | otherwise -> pure (False, msg_)
-      _ -> pure (False, Nothing)
-
-  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
-  deleteExpiredMsgs (MsgQueue q) old = loop
-    where
-      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
-      delOldMsg Message {msgTs} =
-        when (systemSeconds msgTs < old) $
-          tryReadTBQueue q >> loop
+  tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
+  tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,11 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.QueueStore where
 
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
@@ -14,31 +12,16 @@ data QueueRec = QueueRec
     rcvDhSecret :: RcvDhSecret,
     senderId :: SenderId,
     senderKey :: Maybe SndPublicVerifyKey,
-    notifier :: Maybe NtfCreds,
-    status :: ServerQueueStatus
+    notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
+    status :: QueueStatus
   }
-  deriving (Eq, Show)
 
-data NtfCreds = NtfCreds
-  { notifierId :: NotifierId,
-    notifierKey :: NtfPublicVerifyKey,
-    rcvNtfDhSecret :: RcvNtfDhSecret
-  }
-  deriving (Eq, Show)
-
-instance StrEncoding NtfCreds where
-  strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
-  strP = do
-    (notifierId, notifierKey, rcvNtfDhSecret) <- strP
-    pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
-
-data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
+data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
 
 class MonadQueueStore s m where
   addQueue :: s -> QueueRec -> m (Either ErrorType ())
   getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec)
   secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec)
-  addQueueNotifier :: s -> RecipientId -> NtfCreds -> m (Either ErrorType QueueRec)
-  deleteQueueNotifier :: s -> RecipientId -> m (Either ErrorType ())
+  addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec)
   suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
   deleteQueue :: s -> RecipientId -> m (Either ErrorType ())

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,91 +11,107 @@
 
 module Simplex.Messaging.Server.QueueStore.STM where
 
-import Control.Monad
-import Data.Functor (($>))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, ($>>=))
 import UnliftIO.STM
 
-data QueueStore = QueueStore
-  { queues :: TMap RecipientId (TVar QueueRec),
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId
+data QueueStoreData = QueueStoreData
+  { queues :: Map RecipientId QueueRec,
+    senders :: Map SenderId RecipientId,
+    notifiers :: Map NotifierId RecipientId
   }
 
+type QueueStore = TVar QueueStoreData
+
 newQueueStore :: STM QueueStore
-newQueueStore = do
-  queues <- TM.empty
-  senders <- TM.empty
-  notifiers <- TM.empty
-  pure QueueStore {queues, senders, notifiers}
+newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty}
 
 instance MonadQueueStore QueueStore STM where
   addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
-  addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
-    ifM hasId (pure $ Left DUPLICATE_) $ do
-      qVar <- newTVar q
-      TM.insert rId qVar queues
-      TM.insert sId rId senders
-      pure $ Right ()
-    where
-      hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
+  addQueue store qRec@QueueRec {recipientId = rId, senderId = sId} = do
+    cs@QueueStoreData {queues, senders} <- readTVar store
+    if M.member rId queues || M.member sId senders
+      then return $ Left DUPLICATE_
+      else do
+        writeTVar store $
+          cs
+            { queues = M.insert rId qRec queues,
+              senders = M.insert sId rId senders
+            }
+        return $ Right ()
 
   getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
-  getQueue QueueStore {queues, senders, notifiers} party qId =
-    toResult <$> (mapM readTVar =<< getVar)
+  getQueue st party qId = do
+    cs <- readTVar st
+    pure $ case party of
+      SRecipient -> getRcpQueue cs qId
+      SSender -> getPartyQueue cs senders
+      SNotifier -> getPartyQueue cs notifiers
     where
-      getVar = case party of
-        SRecipient -> TM.lookup qId queues
-        SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
-        SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
+      getPartyQueue ::
+        QueueStoreData ->
+        (QueueStoreData -> Map QueueId RecipientId) ->
+        Either ErrorType QueueRec
+      getPartyQueue cs recipientIds =
+        case M.lookup qId $ recipientIds cs of
+          Just rId -> getRcpQueue cs rId
+          Nothing -> Left AUTH
 
   secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
-  secureQueue QueueStore {queues} rId sKey =
-    withQueue rId queues $ \qVar ->
-      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'
+  secureQueue store rId sKey =
+    updateQueues store rId $ \cs c ->
+      case senderKey c of
+        Just _ -> (Left AUTH, cs)
+        _ -> (Right c, cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})
 
-  addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
-  addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
-    ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
-      withQueue rId queues $ \qVar -> do
-        q <- readTVar qVar
-        forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
-        writeTVar qVar q {notifier = Just ntfCreds}
-        TM.insert nId rId notifiers
-        pure $ Just q
-
-  deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  deleteQueueNotifier QueueStore {queues, notifiers} rId =
-    withQueue rId queues $ \qVar -> do
-      q <- readTVar qVar
-      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-      writeTVar qVar q {notifier = Nothing}
-      pure $ Just ()
+  addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)
+  addQueueNotifier store rId nId nKey = do
+    cs@QueueStoreData {queues, notifiers} <- readTVar store
+    if M.member nId notifiers
+      then pure $ Left DUPLICATE_
+      else case M.lookup rId queues of
+        Nothing -> pure $ Left AUTH
+        Just q -> case notifier q of
+          Just _ -> pure $ Left AUTH
+          _ -> do
+            writeTVar store $
+              cs
+                { queues = M.insert rId q {notifier = Just (nId, nKey)} queues,
+                  notifiers = M.insert nId rId notifiers
+                }
+            pure $ Right q
 
   suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  suspendQueue QueueStore {queues} rId =
-    withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
+  suspendQueue store rId =
+    updateQueues store rId $ \cs c ->
+      (Right (), cs {queues = M.insert rId c {status = QueueOff} (queues cs)})
 
   deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  deleteQueue QueueStore {queues, senders, notifiers} rId = 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 ()
-      _ -> pure $ Left AUTH
+  deleteQueue store rId =
+    updateQueues store rId $ \cs c ->
+      ( Right (),
+        cs
+          { queues = M.delete rId (queues cs),
+            senders = M.delete (senderId c) (senders cs)
+          }
+      )
 
-toResult :: Maybe a -> Either ErrorType a
-toResult = maybe (Left AUTH) Right
+updateQueues ::
+  QueueStore ->
+  RecipientId ->
+  (QueueStoreData -> QueueRec -> (Either ErrorType a, QueueStoreData)) ->
+  STM (Either ErrorType a)
+updateQueues store rId update = do
+  cs <- readTVar store
+  let conn = getRcpQueue cs rId
+  either (return . Left) (_update cs) conn
+  where
+    _update cs c = do
+      let (res, cs') = update cs c
+      writeTVar store cs'
+      return res
 
-withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
-withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
+getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
+getRcpQueue cs rId = maybe (Left AUTH) Right . M.lookup rId $ queues cs

src/Simplex/Messaging/Server/Stats.hs

@@ -1,168 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Server.Stats where
-
-import Control.Applicative (optional)
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Time.Calendar.Month.Compat (pattern MonthDay)
-import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
-import Data.Time.Clock (UTCTime (..))
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RecipientId)
-import UnliftIO.STM
-
-data ServerStats = ServerStats
-  { fromTime :: TVar UTCTime,
-    qCreated :: TVar Int,
-    qSecured :: TVar Int,
-    qDeleted :: TVar Int,
-    msgSent :: TVar Int,
-    msgRecv :: TVar Int,
-    activeQueues :: PeriodStats RecipientId
-  }
-
-data ServerStatsData = ServerStatsData
-  { _fromTime :: UTCTime,
-    _qCreated :: Int,
-    _qSecured :: Int,
-    _qDeleted :: Int,
-    _msgSent :: Int,
-    _msgRecv :: Int,
-    _activeQueues :: PeriodStatsData RecipientId
-  }
-
-newServerStats :: UTCTime -> STM ServerStats
-newServerStats ts = do
-  fromTime <- newTVar ts
-  qCreated <- newTVar 0
-  qSecured <- newTVar 0
-  qDeleted <- newTVar 0
-  msgSent <- newTVar 0
-  msgRecv <- newTVar 0
-  activeQueues <- newPeriodStats
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
-
-getServerStatsData :: ServerStats -> STM ServerStatsData
-getServerStatsData s = do
-  _fromTime <- readTVar $ fromTime s
-  _qCreated <- readTVar $ qCreated s
-  _qSecured <- readTVar $ qSecured s
-  _qDeleted <- readTVar $ qDeleted s
-  _msgSent <- readTVar $ msgSent s
-  _msgRecv <- readTVar $ msgRecv s
-  _activeQueues <- getPeriodStatsData $ activeQueues s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
-
-setServerStats :: ServerStats -> ServerStatsData -> STM ()
-setServerStats s d = do
-  writeTVar (fromTime s) (_fromTime d)
-  writeTVar (qCreated s) (_qCreated d)
-  writeTVar (qSecured s) (_qSecured d)
-  writeTVar (qDeleted s) (_qDeleted d)
-  writeTVar (msgSent s) (_msgSent d)
-  writeTVar (msgRecv s) (_msgRecv d)
-  setPeriodStats (activeQueues s) (_activeQueues d)
-
-instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
-    B.unlines
-      [ "fromTime=" <> strEncode _fromTime,
-        "qCreated=" <> strEncode _qCreated,
-        "qSecured=" <> strEncode _qSecured,
-        "qDeleted=" <> strEncode _qDeleted,
-        "msgSent=" <> strEncode _msgSent,
-        "msgRecv=" <> strEncode _msgRecv,
-        "activeQueues:",
-        strEncode _activeQueues
-      ]
-  strP = do
-    _fromTime <- "fromTime=" *> strP <* A.endOfLine
-    _qCreated <- "qCreated=" *> strP <* A.endOfLine
-    _qSecured <- "qSecured=" *> strP <* A.endOfLine
-    _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
-    _msgSent <- "msgSent=" *> strP <* A.endOfLine
-    _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    r <- optional ("activeQueues:" <* A.endOfLine)
-    _activeQueues <- case r of
-      Just _ -> strP <* optional A.endOfLine
-      _ -> do
-        _day <- "dayMsgQueues=" *> strP <* A.endOfLine
-        _week <- "weekMsgQueues=" *> strP <* A.endOfLine
-        _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
-        pure PeriodStatsData {_day, _week, _month}
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
-
-data PeriodStats a = PeriodStats
-  { day :: TVar (Set a),
-    week :: TVar (Set a),
-    month :: TVar (Set a)
-  }
-
-newPeriodStats :: STM (PeriodStats a)
-newPeriodStats = do
-  day <- newTVar S.empty
-  week <- newTVar S.empty
-  month <- newTVar S.empty
-  pure PeriodStats {day, week, month}
-
-data PeriodStatsData a = PeriodStatsData
-  { _day :: Set a,
-    _week :: Set a,
-    _month :: Set a
-  }
-
-getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
-getPeriodStatsData s = do
-  _day <- readTVar $ day s
-  _week <- readTVar $ week s
-  _month <- readTVar $ month s
-  pure PeriodStatsData {_day, _week, _month}
-
-setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
-setPeriodStats s d = do
-  writeTVar (day s) (_day d)
-  writeTVar (week s) (_week d)
-  writeTVar (month s) (_month d)
-
-instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
-  strEncode PeriodStatsData {_day, _week, _month} =
-    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
-  strP = do
-    _day <- "day=" *> strP <* A.endOfLine
-    _week <- "week=" *> strP <* A.endOfLine
-    _month <- "month=" *> strP
-    pure PeriodStatsData {_day, _week, _month}
-
-data PeriodStatCounts = PeriodStatCounts
-  { dayCount :: String,
-    weekCount :: String,
-    monthCount :: String
-  }
-
-periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
-periodStatCounts ps ts = do
-  let d = utctDay ts
-      (_, wDay) = mondayStartWeek d
-      MonthDay _ mDay = d
-  dayCount <- periodCount 1 $ day ps
-  weekCount <- periodCount wDay $ week ps
-  monthCount <- periodCount mDay $ month ps
-  pure PeriodStatCounts {dayCount, weekCount, monthCount}
-  where
-    periodCount :: Int -> TVar (Set a) -> STM String
-    periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
-    periodCount _ _ = pure ""
-
-updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
-updatePeriodStats stats pId = do
-  updatePeriod day
-  updatePeriod week
-  updatePeriod month
-  where
-    updatePeriod pSel = modifyTVar (pSel stats) (S.insert pId)

src/Simplex/Messaging/Server/StoreLog.hs

@@ -13,13 +13,10 @@ module Simplex.Messaging.Server.StoreLog
     openReadStoreLog,
     storeLogFilePath,
     closeStoreLog,
-    writeStoreLogRecord,
     logCreateQueue,
     logSecureQueue,
     logAddNotifier,
-    logSuspendQueue,
     logDeleteQueue,
-    logDeleteNotifier,
     readWriteStoreLog,
   )
 where
@@ -37,7 +34,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
+import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..))
 import Simplex.Messaging.Transport (trimCR)
 import System.Directory (doesFileExist)
 import System.IO
@@ -51,10 +48,8 @@ data StoreLog (a :: IOMode) where
 data StoreLogRecord
   = CreateQueue QueueRec
   | SecureQueue QueueId SndPublicVerifyKey
-  | AddNotifier QueueId NtfCreds
-  | SuspendQueue QueueId
+  | AddNotifier QueueId NotifierId NtfPublicVerifyKey
   | DeleteQueue QueueId
-  | DeleteNotifier QueueId
 
 instance StrEncoding QueueRec where
   strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
@@ -67,7 +62,7 @@ instance StrEncoding QueueRec where
       ]
       <> maybe "" notifierStr notifier
     where
-      notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
+      notifierStr (nId, nKey) = " nid=" <> strEncode nId <> " nk=" <> strEncode nKey
 
   strP = do
     recipientId <- "rid=" *> strP_
@@ -75,31 +70,24 @@ instance StrEncoding QueueRec where
     rcvDhSecret <- "rdh=" *> strP_
     senderId <- "sid=" *> strP_
     senderKey <- "sk=" *> strP
-    notifier <- optional $ " notifier=" *> strP
+    notifier <- optional $ (,) <$> (" nid=" *> strP_) <*> ("nk=" *> strP)
     pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive}
 
 instance StrEncoding StoreLogRecord where
   strEncode = \case
     CreateQueue q -> strEncode (Str "CREATE", q)
     SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
-    AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
-    SuspendQueue rId -> strEncode (Str "SUSPEND", rId)
+    AddNotifier rId nId nKey -> strEncode (Str "NOTIFIER", rId, nId, nKey)
     DeleteQueue rId -> strEncode (Str "DELETE", rId)
-    DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
 
   strP =
     "CREATE " *> (CreateQueue <$> strP)
       <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
-      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
-      <|> "SUSPEND " *> (SuspendQueue <$> strP)
+      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP_ <*> strP)
       <|> "DELETE " *> (DeleteQueue <$> strP)
-      <|> "NDELETE " *> (DeleteNotifier <$> strP)
 
 openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
-openWriteStoreLog f = do
-  h <- openFile f WriteMode
-  hSetBuffering h LineBuffering
-  pure $ WriteStoreLog f h
+openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
 
 openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
 openReadStoreLog f = do
@@ -116,7 +104,7 @@ closeStoreLog = \case
   WriteStoreLog _ h -> hClose h
   ReadStoreLog _ h -> hClose h
 
-writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
+writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO ()
 writeStoreLogRecord (WriteStoreLog _ h) r = do
   B.hPutStrLn h $ strEncode r
   hFlush h
@@ -127,18 +115,12 @@ logCreateQueue s = writeStoreLogRecord s . CreateQueue
 logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
 logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
 
-logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO ()
-logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds
-
-logSuspendQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
-logSuspendQueue s = writeStoreLogRecord s . SuspendQueue
+logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NtfPublicVerifyKey -> IO ()
+logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey
 
 logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 
-logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
-logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
-
 readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
 readWriteStoreLog s@(ReadStoreLog f _) = do
   qs <- readQueues s
@@ -167,9 +149,7 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo
     procLogRecord m = \case
       CreateQueue q -> M.insert (recipientId q) q m
       SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
-      AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
-      SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
+      AddNotifier qId nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m
       DeleteQueue qId -> M.delete qId m
-      DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
     printError :: LogParsingError -> IO ()
     printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/TMap.hs

@@ -1,87 +0,0 @@
-module Simplex.Messaging.TMap
-  ( TMap,
-    empty,
-    singleton,
-    clear,
-    Simplex.Messaging.TMap.null,
-    Simplex.Messaging.TMap.lookup,
-    member,
-    insert,
-    delete,
-    lookupInsert,
-    lookupDelete,
-    adjust,
-    update,
-    alter,
-    alterF,
-    union,
-  )
-where
-
-import Control.Concurrent.STM
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-
-type TMap k a = TVar (Map k a)
-
-empty :: STM (TMap k a)
-empty = newTVar M.empty
-{-# INLINE empty #-}
-
-singleton :: k -> a -> STM (TMap k a)
-singleton k v = newTVar $ M.singleton k v
-{-# INLINE singleton #-}
-
-clear :: TMap k a -> STM ()
-clear m = writeTVar m M.empty
-{-# INLINE clear #-}
-
-null :: TMap k a -> STM Bool
-null m = M.null <$> readTVar m
-{-# INLINE null #-}
-
-lookup :: Ord k => k -> TMap k a -> STM (Maybe a)
-lookup k m = M.lookup k <$> readTVar m
-{-# INLINE lookup #-}
-
-member :: Ord k => k -> TMap k a -> STM Bool
-member k m = M.member k <$> readTVar m
-{-# INLINE member #-}
-
-insert :: Ord k => k -> a -> TMap k a -> STM ()
-insert k v m = modifyTVar' m $ M.insert k v
-{-# INLINE insert #-}
-
-delete :: Ord k => k -> TMap k a -> STM ()
-delete k m = modifyTVar' m $ M.delete k
-{-# INLINE delete #-}
-
-lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a)
-lookupInsert k v m = stateTVar m $ \mv -> (M.lookup k mv, M.insert k v mv)
-{-# INLINE lookupInsert #-}
-
-lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
-lookupDelete k m = stateTVar m $ \mv -> (M.lookup k mv, M.delete k mv)
-{-# INLINE lookupDelete #-}
-
-adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM ()
-adjust f k m = modifyTVar' m $ M.adjust f k
-{-# INLINE adjust #-}
-
-update :: Ord k => (a -> Maybe a) -> k -> TMap k a -> STM ()
-update f k m = modifyTVar' m $ M.update f k
-{-# INLINE update #-}
-
-alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM ()
-alter f k m = modifyTVar' m $ M.alter f k
-{-# INLINE alter #-}
-
-alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM ()
-alterF f k m = do
-  mv <- M.alterF f k =<< readTVar m
-  writeTVar m $! mv
-{-# INLINE alterF #-}
-
-union :: Ord k => Map k a -> TMap k a -> STM ()
-union m' m = modifyTVar' m $ M.union m'
-{-# INLINE union #-}

src/Simplex/Messaging/Transport.hs

@@ -26,7 +26,8 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
 module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
-    supportedSMPServerVRange,
+    smpBlockSize,
+    supportedSMPVersions,
     simplexMQVersion,
 
     -- * Transport connection class
@@ -37,7 +38,6 @@ module Simplex.Messaging.Transport
 
     -- * TLS Transport
     TLS (..),
-    SessionId,
     connectTLS,
     closeTLS,
     supportedParameters,
@@ -46,15 +46,12 @@ module Simplex.Messaging.Transport
     -- * SMP transport
     THandle (..),
     TransportError (..),
-    HandshakeError (..),
-    smpServerHandshake,
-    smpClientHandshake,
+    serverHandshake,
+    clientHandshake,
     tPutBlock,
     tGetBlock,
     serializeTransportError,
     transportErrorP,
-    sendHandshake,
-    getHandshake,
 
     -- * Trim trailing CR
     trimCR,
@@ -83,7 +80,7 @@ import qualified Network.TLS.Extra as TE
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
-import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
+import Simplex.Messaging.Util (bshow)
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 import UnliftIO.Exception (Exception)
@@ -95,11 +92,11 @@ import UnliftIO.STM
 smpBlockSize :: Int
 smpBlockSize = 16384
 
-supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 5
+supportedSMPVersions :: VersionRange
+supportedSMPVersions = mkVersionRange 1 1
 
 simplexMQVersion :: String
-simplexMQVersion = "4.0.0"
+simplexMQVersion = "1.0.2"
 
 -- * Transport connection class
 
@@ -118,7 +115,7 @@ class Transport c where
   getClientConnection :: T.Context -> IO c
 
   -- | tls-unique channel binding per RFC5929
-  tlsUnique :: c -> SessionId
+  tlsUnique :: c -> ByteString
 
   -- | Close connection
   closeConnection :: c -> IO ()
@@ -157,7 +154,7 @@ connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
 connectTLS params sock =
   E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
     T.handshake ctx
-      `catchAll` \e -> putStrLn ("exception: " <> show e) >> E.throwIO e
+      `E.catch` \(e :: E.SomeException) -> putStrLn ("exception: " <> show e) >> E.throwIO e
     pure ctx
 
 getTLS :: TransportPeer -> T.Context -> IO TLS
@@ -178,9 +175,8 @@ withTlsUnique peer cxt f =
 
 closeTLS :: T.Context -> IO ()
 closeTLS ctx =
-  T.bye ctx -- sometimes socket was closed before 'TLS.bye' so we catch the 'Broken pipe' error here
-    `E.finally` T.contextClose ctx
-    `catchAll_` pure ()
+  (T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'
+    `E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here
 
 supportedParameters :: T.Supported
 supportedParameters =
@@ -217,11 +213,10 @@ instance Transport TLS where
       readChunks :: ByteString -> IO ByteString
       readChunks b
         | B.length b >= n = pure b
-        | otherwise =
-          T.recvData tlsContext >>= \case
-            -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-            "" -> ioe_EOF
-            s -> readChunks $ b <> s
+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
+        e -> E.throwIO e
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -255,21 +250,14 @@ trimCR s = if B.last s == '\r' then B.init s else s
 -- | The handle for SMP encrypted transport connection over Transport .
 data THandle c = THandle
   { connection :: c,
-    sessionId :: SessionId,
-    blockSize :: Int,
-    -- | agreed server protocol version
-    thVersion :: Version,
-    -- | send multiple transmissions in a single block
-    -- based on protocol and protocol version
-    batch :: Bool
+    sessionId :: ByteString,
+    -- | agreed SMP server protocol version
+    smpVersion :: Version
   }
 
--- | TLS-unique channel binding
-type SessionId = ByteString
-
 data ServerHandshake = ServerHandshake
   { smpVersionRange :: VersionRange,
-    sessionId :: SessionId
+    sessionId :: ByteString
   }
 
 data ClientHandshake = ClientHandshake
@@ -344,55 +332,53 @@ serializeTransportError = \case
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
-tPutBlock THandle {connection = c, blockSize} block =
+tPutBlock THandle {connection = c} block =
   bimapM (const $ pure TELargeMsg) (cPut c) $
-    C.pad block blockSize
+    C.pad block smpBlockSize
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} =
-  cGet c blockSize >>= \case
+tGetBlock THandle {connection = c} =
+  cGet c smpBlockSize >>= \case
     "" -> ioe_EOF
     msg -> pure . first (const TELargeMsg) $ C.unPad msg
 
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-smpServerHandshake c kh smpVRange = do
-  let th@THandle {sessionId} = smpTHandle c
-  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
+serverHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+serverHandshake c kh = do
+  let th@THandle {sessionId} = tHandle c
+  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
   getHandshake th >>= \case
     ClientHandshake {smpVersion, keyHash}
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
-      | smpVersion `isCompatible` smpVRange -> do
-        pure $ smpThHandle th smpVersion
+      | smpVersion `isCompatible` supportedSMPVersions -> do
+        pure (th :: THandle c) {smpVersion}
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | 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 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-smpClientHandshake c keyHash smpVRange = do
-  let th@THandle {sessionId} = smpTHandle c
+clientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+clientHandshake c keyHash = do
+  let th@THandle {sessionId} = tHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
   if sessionId /= sessId
     then throwE TEBadSession
-    else case smpVersionRange `compatibleVersion` smpVRange of
+    else case smpVersionRange `compatibleVersion` supportedSMPVersions of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure $ smpThHandle th smpVersion
+        pure (th :: THandle c) {smpVersion}
       Nothing -> throwE $ TEHandshake VERSION
 
-smpThHandle :: forall c. THandle c -> Version -> THandle c
-smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
-
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
 getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
 getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
-smpTHandle :: Transport c => c -> THandle c
-smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}
+tHandle :: Transport c => c -> THandle c
+tHandle c =
+  THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0}

src/Simplex/Messaging/Transport/Client.hs

@@ -1,121 +1,38 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Client
   ( runTransportClient,
-    runTLSTransportClient,
-    smpClientHandshake,
-    defaultSMPPort,
-    defaultSocksProxy,
-    SocksProxy,
-    TransportHost (..),
-    TransportHosts (..),
-    TransportHosts_ (..),
+    clientHandshake,
   )
 where
 
-import Control.Applicative (optional)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Default (def)
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as L
-import Data.Maybe (fromMaybe)
-import Data.String
-import Data.Word (Word8)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import GHC.IO.Exception (IOErrorType (..))
 import Network.Socket
-import Network.Socks5
 import qualified Network.TLS as T
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.KeepAlive
-import Simplex.Messaging.Util (bshow, (<$?>))
 import System.IO.Error
-import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
-data TransportHost
-  = THIPv4 (Word8, Word8, Word8, Word8)
-  | THOnionHost ByteString
-  | THDomainName HostName
-  deriving (Eq, Ord, Show)
-
-instance Encoding TransportHost where
-  smpEncode = smpEncode . strEncode
-  smpP = parseAll strP <$?> smpP
-
-instance StrEncoding TransportHost where
-  strEncode = \case
-    THIPv4 (a1, a2, a3, a4) -> B.intercalate "." $ map bshow [a1, a2, a3, a4]
-    THOnionHost host -> host
-    THDomainName host -> B.pack host
-  strP =
-    A.choice
-      [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
-        THOnionHost <$> ((<>) <$> A.takeTill (== '.') <*> A.string ".onion"),
-        THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      ]
-    where
-      ipNum = A.decimal <* A.char '.'
-
-instance ToJSON TransportHost where
-  toEncoding = strToJEncoding
-  toJSON = strToJSON
-
-newtype TransportHosts = TransportHosts {thList :: NonEmpty TransportHost}
-
-instance StrEncoding TransportHosts where
-  strEncode = strEncodeList . L.toList . thList
-  strP = TransportHosts . L.fromList <$> strP `A.sepBy1'` A.char ','
-
-newtype TransportHosts_ = TransportHosts_ {thList_ :: [TransportHost]}
-
-instance StrEncoding TransportHosts_ where
-  strEncode = strEncodeList . thList_
-  strP = TransportHosts_ <$> strP `A.sepBy'` A.char ','
-
-instance IsString TransportHost where fromString = parseString strDecode
-
-instance IsString (NonEmpty TransportHost) where fromString = parseString strDecode
-
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: (Transport c, MonadUnliftIO m) => Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTransportClient = runTLSTransportClient supportedParameters Nothing
-
-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ socksProxy_ host port keyHash keepAliveOpts client = do
-  let clientParams = mkTLSClientParams tlsParams caStore_ (B.unpack $ strEncode host) port keyHash
-      connectTCP = case socksProxy_ of
-        Just proxy -> connectSocksClient proxy $ hostAddr host
-        _ -> connectTCPClient . B.unpack $ strEncode host
-  c <- liftIO $ do
-    sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) keepAliveOpts
-    connectTLS clientParams sock >>= getClientConnection
+runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> (c -> m a) -> m a
+runTransportClient host port keyHash client = do
+  let clientParams = mkTLSClientParams host port keyHash
+  c <- liftIO $ startTCPClient host port clientParams
   client c `E.finally` liftIO (closeConnection c)
-  where
-    hostAddr = \case
-      THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
-      THOnionHost h -> SocksAddrDomainName h
-      THDomainName h -> SocksAddrDomainName $ B.pack h
 
-connectTCPClient :: HostName -> ServiceName -> IO Socket
-connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c
+startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -125,60 +42,25 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
       let hints = defaultHints {addrSocketType = Stream}
        in getAddrInfo (Just hints) (Just host) (Just port)
 
-    tryOpen :: IOException -> [AddrInfo] -> IO Socket
+    tryOpen :: IOException -> [AddrInfo] -> IO c
     tryOpen e [] = E.throwIO e
     tryOpen _ (addr : as) =
       E.try (open addr) >>= either (`tryOpen` as) pure
 
-    open :: AddrInfo -> IO Socket
+    open :: AddrInfo -> IO c
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      pure sock
+      ctx <- connectTLS clientParams sock
+      getClientConnection ctx
 
-defaultSMPPort :: PortNumber
-defaultSMPPort = 5223
-
-connectSocksClient :: SocksProxy -> SocksHostAddress -> ServiceName -> IO Socket
-connectSocksClient (SocksProxy addr) hostAddr _port = do
-  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
-  fst <$> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
-
-defaultSocksHost :: HostAddress
-defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
-
-defaultSocksProxy :: SocksProxy
-defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
-
-newtype SocksProxy = SocksProxy SockAddr
-  deriving (Eq)
-
-instance Show SocksProxy where show (SocksProxy addr) = show addr
-
-instance StrEncoding SocksProxy where
-  strEncode = B.pack . show
-  strP = do
-    host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
-    port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
-    pure . SocksProxy $ SockAddrInet port host
-    where
-      ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
-      ipNum = A.decimal <* A.char '.'
-
-instance ToJSON SocksProxy where
-  toJSON = strToJSON
-  toEncoding = strToJEncoding
-
-instance FromJSON SocksProxy where
-  parseJSON = strParseJSON "SocksProxy"
-
-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
-mkTLSClientParams supported caStore_ host port keyHash_ = do
+mkTLSClientParams :: HostName -> ServiceName -> C.KeyHash -> T.ClientParams
+mkTLSClientParams host port keyHash = do
   let p = B.pack port
   (T.defaultParamsClient host p)
-    { T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
-      T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
-      T.clientSupported = supported
+    { T.clientShared = def,
+      T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p},
+      T.clientSupported = supportedParameters
     }
 
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
@@ -193,7 +75,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_,
     x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
       where
         hooks = XV.defaultHooks
-        checks = XV.defaultChecks {XV.checkFQHN = False}
+        checks = XV.defaultChecks
         certStore = XS.makeCertificateStore sc
         cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
         serviceID = (host, port)

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -1,36 +0,0 @@
-module Simplex.Messaging.Transport.HTTP2 where
-
-import qualified Control.Exception as E
-import Data.Default (def)
-import Foreign (mallocBytes)
-import Network.HPACK (BufferSize)
-import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
-import qualified Network.TLS as T
-import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
-import qualified System.TimeManager as TI
-
-withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
-withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
-
-allocTlsConfig :: TLS -> BufferSize -> IO Config
-allocTlsConfig c sz = do
-  buf <- mallocBytes sz
-  tm <- TI.initialize $ 30 * 1000000
-  pure
-    Config
-      { confWriteBuffer = buf,
-        confBufferSize = sz,
-        confSendAll = cPut c,
-        confReadN = cGet c,
-        confPositionReadMaker = defaultPositionReadMaker,
-        confTimeoutManager = tm
-      }
-
-http2TLSParams :: T.Supported
-http2TLSParams =
-  def
-    { T.supportedVersions = [T.TLS13, T.TLS12],
-      T.supportedCiphers = TE.ciphersuite_strong_det,
-      T.supportedSecureRenegotiation = False
-    }

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -1,128 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Transport.HTTP2.Client where
-
-import Control.Concurrent.Async
-import Control.Exception (IOException)
-import qualified Control.Exception as E
-import Control.Monad.Except
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Maybe (isNothing)
-import qualified Data.X509.CertificateStore as XS
-import Network.HPACK (HeaderTable)
-import Network.HTTP2.Client (ClientConfig (..), Request, Response)
-import qualified Network.HTTP2.Client as H
-import Network.Socket (HostName, ServiceName)
-import qualified Network.TLS as T
-import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.Client (TransportHost (..), runTLSTransportClient)
-import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
-import UnliftIO.STM
-import UnliftIO.Timeout
-
-data HTTP2Client = HTTP2Client
-  { action :: Async (),
-    connected :: TVar Bool,
-    host :: HostName,
-    port :: ServiceName,
-    config :: HTTP2ClientConfig,
-    reqQ :: TBQueue (Request, TMVar HTTP2Response)
-  }
-
-data HTTP2Response = HTTP2Response
-  { response :: Response,
-    respBody :: ByteString,
-    respTrailers :: Maybe HeaderTable
-  }
-
-data HTTP2ClientConfig = HTTP2ClientConfig
-  { qSize :: Natural,
-    connTimeout :: Int,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    caStoreFile :: FilePath,
-    suportedTLSParams :: T.Supported
-  }
-  deriving (Show)
-
-defaultHTTP2ClientConfig :: HTTP2ClientConfig
-defaultHTTP2ClientConfig =
-  HTTP2ClientConfig
-    { qSize = 64,
-      connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
-      caStoreFile = "/etc/ssl/cert.pem",
-      suportedTLSParams = http2TLSParams
-    }
-
-data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
-  deriving (Show)
-
-getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
-  (atomically mkHTTPS2Client >>= runClient)
-    `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
-  where
-    mkHTTPS2Client :: STM HTTP2Client
-    mkHTTPS2Client = do
-      connected <- newTVar False
-      reqQ <- newTBQueue $ qSize config
-      pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
-
-    runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
-    runClient c = do
-      cVar <- newEmptyTMVarIO
-      caStore <- XS.readCertificateStore caStoreFile
-      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
-      action <-
-        async $
-          runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
-            `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
-      conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
-      pure $ case conn_ of
-        Just (Right ()) -> Right c {action}
-        Just (Left e) -> Left e
-        Nothing -> Left HCNetworkError1
-
-    client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    client c cVar sendReq = do
-      atomically $ do
-        writeTVar (connected c) True
-        putTMVar cVar $ Right ()
-      process c sendReq `E.finally` disconnected
-
-    process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    process HTTP2Client {reqQ} sendReq = forever $ do
-      (req, respVar) <- atomically $ readTBQueue reqQ
-      sendReq req $ \r -> do
-        let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
-        respBody <- getResponseBody r ""
-        respTrailers <- H.getResponseTrailers r
-        writeResp respBody respTrailers
-
-    getResponseBody :: Response -> ByteString -> IO ByteString
-    getResponseBody r s =
-      H.getResponseBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getResponseBody r $ s <> chunk
-
--- | Disconnects client from the server and terminates client threads.
-closeHTTP2Client :: HTTP2Client -> IO ()
--- TODO disconnect
-closeHTTP2Client = uninterruptibleCancel . action
-
-sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
-sendRequest HTTP2Client {reqQ, config} req = do
-  resp <- newEmptyTMVarIO
-  atomically $ writeTBQueue reqQ (req, resp)
-  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
-
-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTP2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore Nothing (THDomainName host) port Nothing keepAliveOpts $ \c ->
-    withTlsConfig c 16384 (`run` client)
-  where
-    run = H.run $ ClientConfig "https" (B.pack host) 20

src/Simplex/Messaging/Transport/HTTP2/Server.hs

@@ -1,70 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Transport.HTTP2.Server where
-
-import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
-import Control.Concurrent.STM
-import Control.Monad
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Network.HPACK (HeaderTable)
-import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
-import qualified Network.HTTP2.Server as H
-import Network.Socket
-import qualified Network.TLS as T
-import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
-import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
-
-type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
-
-data HTTP2ServerConfig = HTTP2ServerConfig
-  { qSize :: Natural,
-    http2Port :: ServiceName,
-    serverSupported :: T.Supported,
-    caCertificateFile :: FilePath,
-    privateKeyFile :: FilePath,
-    certificateFile :: FilePath
-  }
-  deriving (Show)
-
-data HTTP2Request = HTTP2Request
-  { request :: Request,
-    reqBody :: ByteString,
-    reqTrailers :: Maybe HeaderTable,
-    sendResponse :: Response -> IO ()
-  }
-
-data HTTP2Server = HTTP2Server
-  { action :: Async (),
-    reqQ :: TBQueue HTTP2Request
-  }
-
-getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
-  tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
-  started <- newEmptyTMVarIO
-  reqQ <- newTBQueueIO qSize
-  action <- async $
-    runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
-      reqBody <- getRequestBody r ""
-      reqTrailers <- H.getRequestTrailers r
-      atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
-  void . atomically $ takeTMVar started
-  pure HTTP2Server {action, reqQ}
-  where
-    getRequestBody :: Request -> ByteString -> IO ByteString
-    getRequestBody r s =
-      H.getRequestBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getRequestBody r $ s <> chunk
-
-closeHTTP2Server :: HTTP2Server -> IO ()
-closeHTTP2Server = uninterruptibleCancel . action
-
-runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port serverParams http2Server =
-  runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
-  where
-    server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
-    server req _aux sendResp = http2Server req (`sendResp` [])