v2.3.1

* log weekly and monthly active queues

* update

.github/CODEOWNERS

@@ -0,0 +1 @@
+* @epoberezkin @efim-poberezkin

.github/FUNDING.yml

@@ -1 +1,2 @@
+github: simplex-chat
 open_collective: simplex-chat

.github/changelog_conf.json

@@ -1,4 +1,4 @@
 {
   "template": "${{UNCATEGORIZED}}",
-  "pr_template": "- ${{TITLE}}\n"
+  "pr_template": "- ${{TITLE}}"
 }

.github/workflows/build.yml

@@ -4,19 +4,42 @@ on:
   push:
     branches:
       - master
+      - stable
     tags:
       - "v*"
   pull_request:
 
 jobs:
-  prepare-release:
-    if: startsWith(github.ref, 'refs/tags/v')
-    runs-on: ubuntu-latest
+  build:
+    runs-on: ubuntu-20.04
     steps:
       - name: Clone project
         uses: actions/checkout@v2
 
+      - name: Setup Stack
+        uses: haskell/actions/setup@v1
+        with:
+          ghc-version: "8.10.7"
+          enable-stack: true
+          stack-version: "latest"
+
+      - name: Cache dependencies
+        uses: actions/cache@v2
+        with:
+          path: ~/.stack
+          key: ${{ hashFiles('stack.yaml') }}
+
+      - name: Build & test
+        id: build_test
+        shell: bash
+        run: |
+          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
+          mv ${install_root}/bin/ntf-server ntf-server-ubuntu-20_04-x86-64
+
       - name: Build changelog
+        if: startsWith(github.ref, 'refs/tags/v')
         id: build_changelog
         uses: mikepenz/release-changelog-builder-action@v1
         with:
@@ -27,57 +50,31 @@ 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')
         uses: softprops/action-gh-release@v1
         with:
-          body: ${{ steps.build_changelog.outputs.changelog }}
+          body: |
+            See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md).
+
+            Commits:
+            ${{ steps.build_changelog.outputs.changelog }}
+          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 }}
-
-  build:
-    name: build-${{ matrix.os }}
-    if: always()
-    needs: prepare-release
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        include:
-          - os: ubuntu-20.04
-            asset_name: smp-server-ubuntu-20_04-x86-64
-          - os: ubuntu-18.04
-            asset_name: smp-server-ubuntu-18_04-x86-64
-    steps:
-      - name: Clone project
-        uses: actions/checkout@v2
-
-      - name: Setup Stack
-        uses: haskell/actions/setup@v1
-        with:
-          ghc-version: '8.8.4'
-          enable-stack: true
-          stack-version: 'latest'
-
-      - name: Cache dependencies
-        uses: actions/cache@v2
-        with:
-          path: ~/.stack
-          key: ${{ matrix.os }}-${{ hashFiles('stack.yaml') }}
-
-      - name: Build & test
-        id: build_test
-        run: |
-          stack build --test --force-dirty
-          echo "::set-output name=LOCAL_INSTALL_ROOT::$(stack path --local-install-root)"
-
-      - name: Upload binaries to release
-        if: startsWith(github.ref, 'refs/tags/v')
-        uses: svenstaro/upload-release-action@v2
-        with:
-          repo_token: ${{ secrets.GITHUB_TOKEN }}
-          file: ${{ steps.build_test.outputs.LOCAL_INSTALL_ROOT }}/bin/smp-server
-          asset_name: ${{ matrix.asset_name }}
-          tag: ${{ github.ref }}

.gitignore

@@ -2,3 +2,5 @@
 *.db
 *.db.bak
 *.session.sql
+tests/tmp
+dist-newstyle/

CHANGELOG.md

@@ -1,3 +1,153 @@
+# 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.
+  - Messages delivered from the servers to the recipients are additionally encrypted to avoid cipher-text correlation between sent and received messages.
+- To prevent any traffic correlation by content size, SimpleX uses fixed transport block size of 16kb (16384 bytes) with padding on all encryption layers:
+  - application messages are padded to 15788 bytes before E2E double-ratchet encryption.
+  - messages between SMP clients are padded to 16032 bytes before E2E encryption in each SMP queue.
+  - messages from the server to the recipient are padded to padded to 16088 bytes before the additional encryption layer (see above).
+- TLS 1.2+ with tls-unique channel binding in each command to prevent replay attacks.
+- 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).
+
+# 0.5.2
+
+- Fix message delivery logic that blocked delivery of all server messages when server per-queue quota exceeded, making it concurrent per SMP queue, not per server.
+
+# 0.5.1
+
+- Fix server subscription logic bug that was leading to memory leak / resource exhaustion in some edge cases.
+
+# 0.5.0
+
+- No changes in SMP server implementation - it is backwards compatible with v0.4.1
+- SMP agent changes:
+  - URI syntax for SMP queues and connection requests.
+  - long-term connections links ("contacts") in SMP agent protocol.
+  - agent command changes:
+    - `REQ` notification and `ACPT` command are used only with long-term connection links.
+    - `CONF` notification and `LET` commands are used for normal duplex connections.
+
+# 0.4.1
+
+- Include migrations in the package
+
 # 0.4.0
 
 - SMP server implementation and [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) changes:

README.md

@@ -3,37 +3,67 @@
 [![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild)
 [![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplexmq)](https://github.com/simplex-chat/simplexmq/releases)
 
+📢 SimpleXMQ v1 is released - with many security, privacy and efficiency improvements, new functionality - see [release notes](https://github.com/simplex-chat/simplexmq/releases/tag/v1.0.0).
+
+**Please note**: v1 is not backwards compatible, but it has the version negotiation built into all protocol layers for forwards compatibility of this version and backwards compatibility of the future versions, that will be backwards compatible for at least two versions back.
+
+If you have a server deployed please deploy a new server to a new host and retire the previous version once it is no longer used.
+
 ## 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](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 8 client commands and 6 server responses.
+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.
 
 SimpleXMQ is implemented in Haskell - it benefits from robust software transactional memory (STM) and concurrency primitives that Haskell provides.
 
 ## SimpleXMQ roadmap
 
-- Streams - high performance message queues. See [Streams RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-02-28-streams.md) for details.
-- "Small" connection groups, when each message will be sent by the SMP agent to multiple connections with a single client command. See [Groups RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-03-18-groups.md) for details.
-- SMP agents cluster to share connections and message management by multiple agents (for example, it would enable multi-device use for [simplex-chat](https://github.com/simplex-chat/simplex-chat)).
-- SMP queue redundancy and rotation in SMP agent duplex connections.
-- "Large" groups design and implementation. 
+- SimpleX service protocol and application template - to enable users building services and chat bots that work over SimpleX protocol stack. The first such service will be a notification service for a mobile app.
+- SMP queue redundancy and rotation in SMP agent connections.
+- SMP agents synchronization to share connections and messages between multiple agents (it would allow using multiple devices for [simplex-chat](https://github.com/simplex-chat/simplex-chat)).
 
 ## Components
 
 ### SMP server
 
-[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. It 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.
+[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
 
-To enable the queue logging, uncomment `enable: on` option in `smp-server.ini` configuration file that is created the first time the server is started.
+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]`.
 
-On the first start the server generates an RSA key pair for encrypted transport handshake and outputs hash of the public key every time it runs - this hash should be used as part of the server address: `<hostname>:5223#<key hash>`.
+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](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
 
+#### Running SMP server on MacOS
+
+SMP server requires OpenSSL library for initialization. On MacOS OpenSSL library may be replaced with LibreSSL, which doesn't support required algorithms. Before initializing SMP server verify you have OpenSSL installed:
+
+```sh
+openssl version
+```
+
+If it says "LibreSSL", please install original OpenSSL:
+
+```sh
+brew update
+brew install openssl
+echo 'PATH="/opt/homebrew/opt/openssl@3/bin:$PATH"' >> ~/.zprofile # or follow whatever instructions brew suggests
+. ~/.zprofile # or restart your terminal to start a new session
+```
+
+Now `openssl version` should be saying "OpenSSL". You can now run `smp-server init` to initialize your SMP server.
+
 ### SMP client library
 
 [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.
@@ -50,49 +80,86 @@ See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for
 
 ## Using SMP server and SMP agent
 
-You can either run your own SMP server locally or deploy using [Linode StackScript](#deploy-smp-server-on-linode), or try local SMP agent with the deployed demo server:
+You can either run your own SMP server locally or deploy using [Linode StackScript](https://cloud.linode.com/stackscripts/748014), or try local SMP agent with the deployed servers:
 
-`smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=`
+`smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im`
+
+`smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im`
+
+`smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im`
 
 It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
 
-[<img alt="linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
+## Deploy SMP server on Linux
+
+You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
+
+- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
+
+  If you're using other Linux distribution and the binary is incompatible with it, you can build from source using [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
+
+  ```shell
+  curl -sSL https://get.haskellstack.org/ | sh
+  ...
+  stack 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.
+
+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="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
 
-You can get Linode [free credits](https://www.linode.com/lp/affiliate-referral/?irclickid=02-QkdTEpxyLW0W0EOSREQreUkB2DtzGE2lGTE0&irgwc=1&utm_source=impact) to deploy SMP server.
+\* You can use free credit Linode offers when [creating a new account](https://www.linode.com/) to deploy an SMP server.
 
-Deployment on [Linode](https://www.linode.com/) is performed via StackScripts, which serve as recipes for Linode instances, also called Linodes. To deploy SMP server on Linode:
+Deployment on Linode is performed via StackScripts, which serve as recipes for Linode instances, also called Linodes. To deploy SMP server on Linode:
 
 - 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](#SMP-server) 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) for attaching server info as tags to Linode (server address, public key hash, version) and adding A record to your 2nd level domain (Note: 2nd level e.g. `example.com` domain should be [created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scope should be read/write access to "linodes" (to update linode tags - you need them), and "domains" (to add A record for the 3rd level domain, e.g. `smp`).
-    - Domain name to use instead of Linode ip address, e.g. `smp.example.com`.
-- Choose the region and plan according to your requirements (for regular use Shared CPU Nanode should be sufficient).
-- Provide ssh key to be able to connect to your Linode via ssh. This step is required if you haven't provided a Linode API token, because you will need to login to your Linode and get a public key hash either from the welcome message or from the file `/etc/opt/simplex/pub_key_hash` on your Linode after SMP server starts.
+  - 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.
-- Get `hostname` and `hash` either from Linode tags (click on a tag and copy it's value from the browser search panel) or via ssh. Linode has a good [guide](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) about ssh.
-- Great, your own SMP server is ready! Use `address#hash` as SMP server address in the client.
+- Get `address` and `fingerprint` either from Linode tags (click on a tag and copy it's value from the browser search panel) or via ssh.
+- Great, your own SMP server is ready! If you provided FQDN use `smp://<fingerprint>@<fqdn>` as SMP server address in the client, otherwise use `smp://<fingerprint>@<ip_address>`.
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
-[<img alt="linode" 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
 
-You can deploy SMP server using [SimpleX Server 1-click app](https://marketplace.digitalocean.com/apps/simplex-server) from DigitalOcean marketplace:
+> 🚧 DigitalOcean snapshot is currently not up to date, it will soon be updated 🏗️
+
+\* When creating a DigitalOcean account you can use [this link](https://try.digitalocean.com/freetrialoffer/) to get free credit. (You would still be required either to provide your credit card details or make a confirmation pre-payment with PayPal)
+
+To deploy SMP server use [SimpleX Server 1-click app](https://marketplace.digitalocean.com/apps/simplex-server) from DigitalOcean marketplace:
 
 - Create a DigitalOcean account or login with an already existing one.
 - Click 'Create SimpleX server Droplet' button.
-- Choose the region and plan according to your requirements (cheapest Regular plan should be sufficient).
-- Provide ssh key and confirm Droplet creation. 
-- SSH to created Droplet (`ssh root@<droplet_ip_address>`) to get SMP server public key hash - either from the welcome message or from `/etc/opt/simplex/pub_key_hash`. DigitalOcean has a good guide on [how to login to Droplet via ssh](https://docs.digitalocean.com/products/droplets/how-to/connect-with-ssh/).
-- Great, your own SMP server is ready! Use `ip_address#hash` as SMP server address in the client.
+- Choose the region and plan according to your requirements (Basic plan should be sufficient).
+- Finalize Droplet creation.
+- Open "Console" on your Droplet management page to get SMP server fingerprint - either from the welcome message or from `/etc/opt/simplex/fingerprint`. Alternatively you can manually SSH to created Droplet, see [DigitalOcean instruction](https://docs.digitalocean.com/products/droplets/how-to/connect-with-ssh/).
+- Great, your own SMP server is ready! Use `smp://<fingerprint>@<ip_address>` as SMP server address in the client.
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
+> **Please note:** SMP server uses server address as a Common Name for server certificate generated during initialization. If you would like your server address to be FQDN instead of IP address, you can log in to your Droplet and run the commands below to re-initialize the server. Alternatively you can use [Linode StackScript](https://cloud.linode.com/stackscripts/748014) which allows this parameterization.
+
+```sh
+smp-server delete
+smp-server init [-l] -n <fqdn>
+```
+
 ## SMP server design
 
 ![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)

apps/ntf-server/Main.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main where
+
+import Control.Logger.Simple
+import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import Simplex.Messaging.Notifications.Server (runNtfServer)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
+import System.FilePath (combine)
+
+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 $ protocolServerCLI ntfServerCLIConfig runNtfServer
+
+ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig
+ntfServerCLIConfig =
+  let caCrtFile = combine cfgPath "ca.crt"
+      serverKeyFile = combine cfgPath "server.key"
+      serverCrtFile = combine cfgPath "server.crt"
+   in ServerCLIConfig
+        { cfgDir = cfgPath,
+          logDir = logPath,
+          iniFile = combine cfgPath "ntf-server.ini",
+          storeLogFile = combine logPath "ntf-server-store.log",
+          caKeyFile = combine cfgPath "ca.key",
+          caCrtFile,
+          serverKeyFile,
+          serverCrtFile,
+          fingerprintFile = combine cfgPath "fingerprint",
+          defaultServerPort = "443",
+          executableName = "ntf-server",
+          serverVersion = "SMP notifications server v0.1.0",
+          mkIniFile = \enableStoreLog defaultServerPort ->
+            "[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\
+            \# The messages are not logged.\n"
+              <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+              <> "[TRANSPORT]\n\
+                 \port: "
+              <> defaultServerPort
+              <> "\n\
+                 \websockets: off\n",
+          mkServerConfig = \_storeLogFile transports _ ->
+            NtfServerConfig
+              { transports,
+                subIdBytes = 24,
+                regCodeBytes = 32,
+                clientQSize = 16,
+                subQSize = 64,
+                pushQSize = 128,
+                smpAgentCfg = defaultSMPClientAgentConfig,
+                apnsConfig = defaultAPNSPushClientConfig,
+                inactiveClientExpiration = Nothing,
+                caCertificateFile = caCrtFile,
+                privateKeyFile = serverKeyFile,
+                certificateFile = serverCrtFile
+              }
+        }

apps/smp-agent/Main.hs

@@ -6,12 +6,19 @@ module Main where
 
 import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
-import Simplex.Messaging.Agent (runSMPAgent)
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Transport (TCP, Transport (..))
+import Simplex.Messaging.Agent.Server (runSMPAgent)
+import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
-cfg = defaultAgentConfig {smpServers = L.fromList ["localhost:5223#bU0K+bRg24xWW//lS0umO1Zdw/SXqpJNtm1/RrPLViE="]}
+cfg = defaultAgentConfig
+
+servers :: InitialAgentServers
+servers =
+  InitialAgentServers
+    { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
+      ntf = []
+    }
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -20,4 +27,4 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $ runSMPAgent (transport @TCP) cfg
+  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers

apps/smp-server/Main.hs

@@ -1,276 +1,107 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Main where
 
-import Control.Monad.Except
-import Control.Monad.Trans.Except
-import qualified Crypto.Store.PKCS8 as S
-import Data.ByteString.Base64 (encode)
-import qualified Data.ByteString.Char8 as B
-import Data.Char (toLower)
-import Data.Ini (Ini, lookupValue, readIniFile)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.X509 (PrivKey (PrivKeyRSA))
-import Network.Socket (ServiceName)
-import Options.Applicative
-import qualified Simplex.Messaging.Crypto as C
+import Control.Logger.Simple
+import Data.Functor (($>))
+import Data.Ini (lookupValue)
 import Simplex.Messaging.Server (runSMPServer)
-import Simplex.Messaging.Server.Env.STM
-import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath)
-import Simplex.Messaging.Transport (ATransport (..), TCP, Transport (..))
-import Simplex.Messaging.Transport.WebSockets (WS)
-import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
-import System.Exit (exitFailure)
+import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (simplexMQVersion)
 import System.FilePath (combine)
-import System.IO (IOMode (..), hFlush, stdout)
-import Text.Read (readEither)
 
-defaultServerPort :: ServiceName
-defaultServerPort = "5223"
+cfgPath :: FilePath
+cfgPath = "/etc/opt/simplex"
 
-defaultBlockSize :: Int
-defaultBlockSize = 4096
+logPath :: FilePath
+logPath = "/var/opt/simplex"
 
-serverConfig :: ServerConfig
-serverConfig =
-  ServerConfig
-    { tbqSize = 16,
-      msgQueueQuota = 256,
-      queueIdBytes = 12,
-      msgIdBytes = 6,
-      -- below parameters are set based on ini file /etc/opt/simplex/smp-server.ini
-      transports = undefined,
-      storeLog = undefined,
-      blockSize = undefined,
-      serverPrivateKey = undefined
-    }
-
-newKeySize :: Int
-newKeySize = 2048 `div` 8
-
-cfgDir :: FilePath
-cfgDir = "/etc/opt/simplex"
-
-logDir :: FilePath
-logDir = "/var/opt/simplex"
-
-defaultStoreLogFile :: FilePath
-defaultStoreLogFile = combine logDir "smp-server-store.log"
-
-iniFile :: FilePath
-iniFile = combine cfgDir "smp-server.ini"
-
-defaultKeyFile :: FilePath
-defaultKeyFile = combine cfgDir "server_key"
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  opts <- getServerOpts
-  case serverCommand opts of
-    ServerInit ->
-      runExceptT (getConfig opts) >>= \case
-        Right cfg -> do
-          putStrLn "Error: server is already initialized. Start it with `smp-server start` command"
-          printConfig cfg
-          exitFailure
-        Left _ -> do
-          cfg <- initializeServer opts
-          putStrLn "Server was initialized. Start it with `smp-server start` command"
-          printConfig cfg
-    ServerStart ->
-      runExceptT (getConfig opts) >>= \case
-        Right cfg -> runServer cfg
-        Left e -> do
-          putStrLn $ "Server is not initialized: " <> e
-          putStrLn "Initialize server with `smp-server init` command"
-          exitFailure
-    ServerDelete -> do
-      deleteServer
-      putStrLn "Server key, config file and store log deleted"
+  setLogLevel LogInfo
+  withGlobalLogging logCfg . protocolServerCLI smpServerCLIConfig $ \cfg@ServerConfig {inactiveClientExpiration} -> do
+    putStrLn $ case inactiveClientExpiration of
+      Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
+      _ -> "not expiring inactive clients"
+    runSMPServer cfg
 
-getConfig :: ServerOpts -> ExceptT String IO ServerConfig
-getConfig opts = do
-  ini <- readIni
-  pk <- readKey ini
-  storeLog <- liftIO $ openStoreLog opts ini
-  pure $ makeConfig ini pk storeLog
-
-makeConfig :: IniOpts -> C.FullPrivateKey -> Maybe (StoreLog 'ReadMode) -> ServerConfig
-makeConfig IniOpts {serverPort, blockSize, enableWebsockets} pk storeLog =
-  let transports = (serverPort, transport @TCP) : [("80", transport @WS) | enableWebsockets]
-   in serverConfig {serverPrivateKey = pk, storeLog, blockSize, transports}
-
-printConfig :: ServerConfig -> IO ()
-printConfig ServerConfig {serverPrivateKey, storeLog} = do
-  B.putStrLn $ "transport key hash: " <> serverKeyHash serverPrivateKey
-  putStrLn $ case storeLog of
-    Just s -> "store log: " <> storeLogFilePath s
-    Nothing -> "store log disabled"
-
-initializeServer :: ServerOpts -> IO ServerConfig
-initializeServer opts = do
-  createDirectoryIfMissing False cfgDir
-  ini <- createIni opts
-  pk <- createKey ini
-  storeLog <- openStoreLog opts ini
-  pure $ makeConfig ini pk storeLog
-
-runServer :: ServerConfig -> IO ()
-runServer cfg = do
-  printConfig cfg
-  forM_ (transports cfg) $ \(port, ATransport t) ->
-    putStrLn $ "listening on port " <> port <> " (" <> transportName t <> ")"
-  runSMPServer cfg
-
-deleteServer :: IO ()
-deleteServer = do
-  ini <- runExceptT readIni
-  deleteIfExists iniFile
-  case ini of
-    Right IniOpts {storeLogFile, serverKeyFile} -> do
-      deleteIfExists storeLogFile
-      deleteIfExists serverKeyFile
-    Left _ -> do
-      deleteIfExists defaultKeyFile
-      deleteIfExists defaultStoreLogFile
-
-data IniOpts = IniOpts
-  { enableStoreLog :: Bool,
-    storeLogFile :: FilePath,
-    serverKeyFile :: FilePath,
-    serverPort :: ServiceName,
-    blockSize :: Int,
-    enableWebsockets :: Bool
-  }
-
-readIni :: ExceptT String IO IniOpts
-readIni = do
-  fileExists iniFile
-  ini <- ExceptT $ readIniFile iniFile
-  let enableStoreLog = (== Right "on") $ lookupValue "STORE_LOG" "enable" ini
-      storeLogFile = opt defaultStoreLogFile "STORE_LOG" "file" ini
-      serverKeyFile = opt defaultKeyFile "TRANSPORT" "key_file" ini
-      serverPort = opt defaultServerPort "TRANSPORT" "port" ini
-      enableWebsockets = (== Right "on") $ lookupValue "TRANSPORT" "websockets" ini
-  blockSize <- liftEither . readEither $ opt (show defaultBlockSize) "TRANSPORT" "block_size" ini
-  pure IniOpts {enableStoreLog, storeLogFile, serverKeyFile, serverPort, blockSize, enableWebsockets}
-  where
-    opt :: String -> Text -> Text -> Ini -> String
-    opt def section key ini = either (const def) T.unpack $ lookupValue section key ini
-
-createIni :: ServerOpts -> IO IniOpts
-createIni ServerOpts {enableStoreLog} = 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\n"
-      <> (if enableStoreLog then "" else "# ")
-      <> "enable: on\n\
-         \# file: "
-      <> defaultStoreLogFile
-      <> "\n\n\
-         \[TRANSPORT]\n\n\
-         \# key_file: "
-      <> defaultKeyFile
-      <> "\n\
-         \# port: "
-      <> defaultServerPort
-      <> "\n\
-         \# block_size: "
-      <> show defaultBlockSize
-      <> "\n\
-         \websockets: on\n"
-  pure
-    IniOpts
-      { enableStoreLog,
-        storeLogFile = defaultStoreLogFile,
-        serverKeyFile = defaultKeyFile,
-        serverPort = defaultServerPort,
-        blockSize = defaultBlockSize,
-        enableWebsockets = True
-      }
-
-readKey :: IniOpts -> ExceptT String IO C.FullPrivateKey
-readKey IniOpts {serverKeyFile} = do
-  fileExists serverKeyFile
-  liftIO (S.readKeyFile serverKeyFile) >>= \case
-    [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.FullPrivateKey pk
-    [_] -> err "not RSA key"
-    [] -> err "invalid key file format"
-    _ -> err "more than one key"
-  where
-    err :: String -> ExceptT String IO b
-    err e = throwE $ e <> ": " <> serverKeyFile
-
-createKey :: IniOpts -> IO C.FullPrivateKey
-createKey IniOpts {serverKeyFile} = do
-  (_, pk) <- C.generateKeyPair newKeySize
-  S.writeKeyFile S.TraditionalFormat serverKeyFile [PrivKeyRSA $ C.rsaPrivateKey pk]
-  pure pk
-
-fileExists :: FilePath -> ExceptT String IO ()
-fileExists path = do
-  exists <- liftIO $ doesFileExist path
-  unless exists . throwE $ "file " <> path <> " not found"
-
-deleteIfExists :: FilePath -> IO ()
-deleteIfExists path = doesFileExist path >>= (`when` removeFile path)
-
-confirm :: String -> IO ()
-confirm msg = do
-  putStr $ msg <> " (y/N): "
-  hFlush stdout
-  ok <- getLine
-  when (map toLower ok /= "y") exitFailure
-
-serverKeyHash :: C.FullPrivateKey -> B.ByteString
-serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey'
-
-openStoreLog :: ServerOpts -> IniOpts -> IO (Maybe (StoreLog 'ReadMode))
-openStoreLog ServerOpts {enableStoreLog = l} IniOpts {enableStoreLog = l', storeLogFile = f}
-  | l || l' = do
-    createDirectoryIfMissing True logDir
-    Just <$> openReadStoreLog f
-  | otherwise = pure Nothing
-
-data ServerOpts = ServerOpts
-  { serverCommand :: ServerCommand,
-    enableStoreLog :: Bool
-  }
-
-data ServerCommand = ServerInit | ServerStart | ServerDelete
-
-serverOpts :: Parser ServerOpts
-serverOpts =
-  ServerOpts
-    <$> subparser
-      ( command "init" (info (pure ServerInit) (progDesc "Initialize server: generate server key and ini file"))
-          <> command "start" (info (pure ServerStart) (progDesc "Start server (ini: /etc/opt/simplex/smp-server.ini)"))
-          <> command "delete" (info (pure ServerDelete) (progDesc "Delete server key, ini file and store log"))
-      )
-    <*> switch
-      ( long "store-log"
-          <> short 'l'
-          <> help "enable store log for SMP queues persistence"
-      )
-
-getServerOpts :: IO ServerOpts
-getServerOpts = customExecParser p opts
-  where
-    p = prefs showHelpOnEmpty
-    opts =
-      info
-        (serverOpts <**> helper)
-        ( fullDesc
-            <> header "Simplex Messaging Protocol (SMP) Server"
-        )
+smpServerCLIConfig :: ServerCLIConfig ServerConfig
+smpServerCLIConfig =
+  let caCrtFile = combine cfgPath "ca.crt"
+      serverKeyFile = combine cfgPath "server.key"
+      serverCrtFile = combine cfgPath "server.crt"
+   in ServerCLIConfig
+        { cfgDir = cfgPath,
+          logDir = logPath,
+          iniFile = combine cfgPath "smp-server.ini",
+          storeLogFile = combine logPath "smp-server-store.log",
+          caKeyFile = combine cfgPath "ca.key",
+          caCrtFile,
+          serverKeyFile,
+          serverCrtFile,
+          fingerprintFile = combine cfgPath "fingerprint",
+          defaultServerPort = "5223",
+          executableName = "smp-server",
+          serverVersion = "SMP server v" <> simplexMQVersion,
+          mkIniFile = \enableStoreLog defaultServerPort ->
+            "[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: " <> (if enableStoreLog then "on" else "off  # on") <> "\n")
+              <> "# The messages are optionally saved and restored when the server restarts,\n\
+                 \# they are deleted after restarting.\n"
+              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")
+              <> "[TRANSPORT]\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"),
+          mkServerConfig = \storeLogFile transports ini ->
+            ServerConfig
+              { transports,
+                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 = caCrtFile,
+                privateKeyFile = serverKeyFile,
+                certificateFile = serverCrtFile,
+                storeLogFile,
+                storeMsgsFile =
+                  let messagesPath = combine logPath "smp-server-messages.log"
+                   in case lookupValue "STORE_LOG" "restore_messages" ini of
+                        Right "on" -> Just messagesPath
+                        Right _ -> Nothing
+                        -- if the setting is not set, it is enabled when store log is enabled
+                        _ -> storeLogFile $> messagesPath,
+                allowNewQueues = True,
+                messageExpiration = Just defaultMessageExpiration,
+                inactiveClientExpiration =
+                  if lookupValue "INACTIVE_CLIENTS" "disconnect" ini == Right "on"
+                    then
+                      Just
+                        ExpirationConfig
+                          { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
+                            checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
+                          }
+                    else Nothing,
+                logStatsInterval = Just 86400, -- seconds
+                logStatsStartTime = 0 -- seconds from 00:00 UTC
+              }
+        }

cabal.project

@@ -0,0 +1,6 @@
+packages: .
+
+source-repository-package
+    type: git
+    location: https://github.com/simplex-chat/aeson.git
+    tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7

migrations/20210101_initial.sql

@@ -1,117 +0,0 @@
-CREATE TABLE IF NOT EXISTS servers(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  key_hash BLOB,
-  PRIMARY KEY (host, port)
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS rcv_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  rcv_id BLOB NOT NULL,
-  conn_alias BLOB NOT NULL,
-  rcv_private_key BLOB NOT NULL,
-  snd_id BLOB,
-  snd_key BLOB,
-  decrypt_key BLOB NOT NULL,
-  verify_key BLOB,
-  status TEXT NOT NULL,
-  PRIMARY KEY (host, port, rcv_id),
-  FOREIGN KEY (host, port) REFERENCES servers (host, port),
-  FOREIGN KEY (conn_alias)
-    REFERENCES connections (conn_alias)
-    ON DELETE CASCADE
-    DEFERRABLE INITIALLY DEFERRED,
-  UNIQUE (host, port, snd_id)
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS snd_queues(
-  host TEXT NOT NULL,
-  port TEXT NOT NULL,
-  snd_id BLOB NOT NULL,
-  conn_alias BLOB NOT NULL,
-  snd_private_key BLOB NOT NULL,
-  encrypt_key BLOB NOT NULL,
-  sign_key BLOB NOT NULL,
-  status TEXT NOT NULL,
-  PRIMARY KEY (host, port, snd_id),
-  FOREIGN KEY (host, port) REFERENCES servers (host, port),
-  FOREIGN KEY (conn_alias)
-    REFERENCES connections (conn_alias)
-    ON DELETE CASCADE
-    DEFERRABLE INITIALLY DEFERRED
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS connections(
-  conn_alias BLOB NOT NULL,
-  rcv_host TEXT,
-  rcv_port TEXT,
-  rcv_id BLOB,
-  snd_host TEXT,
-  snd_port TEXT,
-  snd_id BLOB,
-  last_internal_msg_id INTEGER NOT NULL,
-  last_internal_rcv_msg_id INTEGER NOT NULL,
-  last_internal_snd_msg_id INTEGER NOT NULL,
-  last_external_snd_msg_id INTEGER NOT NULL,
-  last_rcv_msg_hash BLOB NOT NULL,
-  last_snd_msg_hash BLOB NOT NULL,
-  PRIMARY KEY (conn_alias),
-  FOREIGN KEY (rcv_host, rcv_port, rcv_id) REFERENCES rcv_queues (host, port, rcv_id),
-  FOREIGN KEY (snd_host, snd_port, snd_id) REFERENCES snd_queues (host, port, snd_id)
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS messages(
-  conn_alias BLOB NOT NULL,
-  internal_id INTEGER NOT NULL,
-  internal_ts TEXT NOT NULL,
-  internal_rcv_id INTEGER,
-  internal_snd_id INTEGER,
-  body TEXT NOT NULL,  -- deprecated
-  PRIMARY KEY (conn_alias, internal_id),
-  FOREIGN KEY (conn_alias)
-    REFERENCES connections (conn_alias)
-    ON DELETE CASCADE,
-  FOREIGN KEY (conn_alias, internal_rcv_id)
-    REFERENCES rcv_messages (conn_alias, internal_rcv_id)
-    ON DELETE CASCADE
-    DEFERRABLE INITIALLY DEFERRED,
-  FOREIGN KEY (conn_alias, internal_snd_id)
-    REFERENCES snd_messages (conn_alias, internal_snd_id)
-    ON DELETE CASCADE
-    DEFERRABLE INITIALLY DEFERRED
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS rcv_messages(
-  conn_alias BLOB NOT NULL,
-  internal_rcv_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  external_snd_id INTEGER NOT NULL,
-  external_snd_ts TEXT NOT NULL,
-  broker_id BLOB NOT NULL,
-  broker_ts TEXT NOT NULL,
-  rcv_status TEXT NOT NULL,
-  ack_brocker_ts TEXT,
-  ack_sender_ts TEXT,
-  internal_hash BLOB NOT NULL,
-  external_prev_snd_hash BLOB NOT NULL,
-  integrity BLOB NOT NULL,
-  PRIMARY KEY (conn_alias, internal_rcv_id),
-  FOREIGN KEY (conn_alias, internal_id)
-    REFERENCES messages (conn_alias, internal_id)
-    ON DELETE CASCADE
-) WITHOUT ROWID;
-
-CREATE TABLE IF NOT EXISTS snd_messages(
-  conn_alias BLOB NOT NULL,
-  internal_snd_id INTEGER NOT NULL,
-  internal_id INTEGER NOT NULL,
-  snd_status TEXT NOT NULL,
-  sent_ts TEXT,
-  delivered_ts TEXT,
-  internal_hash BLOB NOT NULL,
-  PRIMARY KEY (conn_alias, internal_snd_id),
-  FOREIGN KEY (conn_alias, internal_id)
-    REFERENCES messages (conn_alias, internal_id)
-    ON DELETE CASCADE
-) WITHOUT ROWID;

migrations/20210624_confirmations.sql

@@ -1,9 +0,0 @@
-CREATE TABLE conn_confirmations (
-  confirmation_id BLOB NOT NULL PRIMARY KEY,
-  conn_alias BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  sender_key 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'))
-) WITHOUT ROWID;

migrations/20210809_snd_messages.sql

@@ -1,3 +0,0 @@
-ALTER TABLE messages ADD msg_body BLOB NOT NULL DEFAULT x'';  -- this field replaces body TEXT
--- TODO possibly migrate the data from body if it is possible in migration
-ALTER TABLE snd_messages ADD previous_msg_hash BLOB NOT NULL DEFAULT x'';

migrations/README.md

@@ -1,9 +0,0 @@
-# SQLite database migrations
-
-These migrations are [embedded](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs) into the executable and run when SMP agent starts (as a separate executable or as a part of [simplex-chat](https://github.com/simplex-chat/simplex-chat) app).
-
-Migration file names must have a format `YYYYMMDD-name.sql` - they will be executed in the order or lexicographic sorting of the names, the files with any other extension than `.sql` are ignored.
-
-The proposed approach is to minimize the number of migrations and merge them together when possible, to align with the agent releases.
-
-**Please note**: Adding or editing migrations will NOT update the migrations embedded into the executable, unless the [Migrations](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs) module is rebuilt - use `stack build --force-dirty` (in addition to edited files it seems to rebuild the files with TH splices and their dependencies, not all files as with `stack clean`).

package.yaml

@@ -1,7 +1,7 @@
 name: simplexmq
-version: 0.4.0
+version: 2.3.1
 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:
@@ -15,36 +15,44 @@ homepage: https://github.com/simplex-chat/simplexmq#readme
 license: AGPL-3
 author: simplex.chat
 maintainer: chat@simplex.chat
-copyright: 2020 simplex.chat
+copyright: 2020-2022 simplex.chat
 category: Chat, Network, Web, System, Cryptography
 extra-source-files:
   - README.md
   - CHANGELOG.md
 
 dependencies:
+  - aeson == 2.0.*
   - ansi-terminal >= 0.10 && < 0.12
   - asn1-encoding == 0.9.*
   - asn1-types == 0.3.*
   - async == 2.2.*
-  - attoparsec == 0.13.*
+  - attoparsec == 0.14.*
   - 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-sqlite == 2.3.*
   - directory == 1.3.*
-  - file-embed == 0.0.14.*
   - filepath == 1.4.*
+  - http-types == 0.12.*
+  - http2 == 3.0.*
   - generic-random >= 1.3 && < 1.5
+  - ini == 0.4.*
   - iso8601-time == 0.1.*
   - memory == 0.15.*
   - mtl == 2.2.*
-  - network == 3.1.*
+  - network >= 3.1.2.7 && < 3.2
   - network-transport == 0.5.*
+  - optparse-applicative >= 0.15 && < 0.17
   - QuickCheck == 2.14.*
+  - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
   - sqlite-simple == 0.4.*
@@ -52,11 +60,27 @@ dependencies:
   - 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.*
+
+flags:
+  swift:
+    description: Enable swift JSON format
+    manual: True
+    default: False
+
+when:
+  - condition: flag(swift)
+    cpp-options:
+      - -DswiftJSON
 
 library:
   source-dirs: src
@@ -66,9 +90,14 @@ executables:
     source-dirs: apps/smp-server
     main: Main.hs
     dependencies:
-      - cryptostore == 0.2.*
-      - ini == 0.4.*
-      - optparse-applicative >= 0.15 && < 0.17
+      - simplexmq
+    ghc-options:
+      - -threaded
+
+  ntf-server:
+    source-dirs: apps/ntf-server
+    main: Main.hs
+    dependencies:
       - simplexmq
     ghc-options:
       - -threaded

protocol/agent-protocol.md

@@ -12,10 +12,15 @@
     - [HELLO message](#hello-message)
     - [REPLY message](#reply-message)
     - [MSG message](#msg-message)
+    - [INV message](#inv-message)
+    - [ACK message](#ack-message)
+    - [NEW message](#new-message)
+    - [DEL message](#del-message)
 - [SMP agent commands](#smp-agent-commands)
   - [Client commands and server responses](#client-commands-and-server-responses)
     - [NEW command and INV response](#new-command-and-inv-response)
     - [JOIN command](#join-command)
+    - [CONF notification and LET command](#conf-notification-and-let-command)
     - [REQ notification and ACPT command](#req-notification-and-acpt-command)
     - [INFO and CON notifications](#info-and-con-notifications)
     - [SUB command](#sub-command)
@@ -24,71 +29,68 @@
     - [END notification](#end-notification)
     - [OFF command](#off-command)
     - [DEL command](#del-command)
-- [Connection invitation](#connection-invitation)
+- [Connection request](#connection-request)
 
 ## Abstract
 
 The purpose of SMP agent protocol is to define the syntax and the semantics of communications between the client and the agent that connects to [SMP](./simplex-messaging.md) servers.
 
 It provides:
-- convenient protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the protocol.
-- management of E2E encryption between SMP agents, generating ephemeral RSA keys for each connection.
-- SMP command authentication on SMP servers, generating ephemeral RSA keys for each SMP queue.
-- TCP transport handshake and encryption with SMP servers.
+- protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the agent protocol.
+- management of E2E encryption between SMP agents, generating ephemeral asymmetric keys for each connection.
+- SMP command authentication on SMP servers, generating ephemeral keys for each SMP queue.
+- TCP/TLS transport handshake with SMP servers.
 - validation of message integrity.
 
-SMP agent protocols provides no encryption or any security on the client side - it is assumed that the agent is executed in the trusted and secure environment.
-
-The future versions of this protocol could provide:
-- managing redundant SMP queues with more than 1 queue in each direction.
-- managing simple symmetric groups as a foundation for chat groups and device synchronization.
-- agent cluster - synchronizing states of multiple agents.
-- secure "synchronous" streams with symmetric message encryption and connection-level authentication (requires extending [SMP protocol](./simplex-messaging.md)) - it can be used, e.g., for file transfers.
+SMP agent protocol provides no encryption or security on the client side - it is assumed that the agent is executed in the trusted and secure environment, in one of three ways:
+- via TCP network using secure connection.
+- via local port (when the agent runs on the same device as a separate process).
+- via agent library, when the agent logic is included directly into the client application - [SimpleX Chat for terminal](https://github.com/simplex-chat/simplex-chat) uses this approach.
 
 ## SMP agent
 
-SMP agent is a client-side process or library that communicates via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) with other SMP agents according to the commands received from its users. This protocol is a middle layer in SMP protocols stack (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections").
+SMP agents communicate with each other via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) according to the commands received from its users. This protocol is a middle layer in SimpleX protocols (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections").
 
-The agent must have a persistent storage to manage the states of known connections and of the client-side information of two SMP queues that each connection consists of, and also the buffer of the most recent messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hash and id of the last received message.
+The agent must have a persistent storage to manage the states of known connections and of the client-side information of SMP queues that each connection consists of, and also the buffer of the most recent sent and received messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hashes and IDs of the last received and sent messages.
 
 ## SMP servers management
 
-SMP agent protocol commands do not contain SMP servers that the agent will use to establish the connections between their users. The servers are part of the agent configuration and can be dynamically added and removed by the agent implementation:
+SMP agent protocol commands do not contain the addresses of the SMP servers that the agent will use to create and use the connections (excluding the server address in queue URIs used in JOIN command). The list of the servers is a part of the agent configuration and can be dynamically changed by the agent implementation:
 - by the client applications via any API that is outside of scope of this protocol.
-- by the agents themselves based on servers availability and latency.
+- by the agents themselves based on availability and latency of the configured servers.
 
 ## SMP agent protocol components
 
 SMP agent protocol has 3 main parts:
 
-- the syntax and semantics of messages that SMP agents exchange between each other in order to:
-  - negotiate establishing unidirectional (simplex) encrypted queues on SMP server(s)
+- the syntax and semantics of the messages that SMP agents exchange with each other in order to:
+  - negotiate establishing unidirectional (simplex) encrypted queues on SMP servers.
   - exchange client messages and delivery notifications, providing sequential message IDs and message integrity (by including the hash of the previous message).
-- the syntax and semantics of the commands (a higher level interface than SMP protocol) that are sent over TCP or other sequential protocol by agent clients to the agents. This protocol allows to create and manage multiple connections, each consisting of two simplex SMP queues.
-- the syntax and semantics of the message that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including SMP server, queue ID and encryption key) to ensure [E2E encryption][1] the integrity of SMP queues and protection against active attacks ([MITM attacks][2]).
+- the syntax and semantics of the commands that are sent by the agent clients to the agents. This protocol allows to create and manage multiple connections, each consisting of two or more SMP queues.
+- the syntax and semantics of the message that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including queue URIs) to protect [E2E encryption][1] from active attacks ([MITM attacks][2]).
 
 ## Duplex connection procedure
 
 ![Duplex connection procedure](./diagrams/duplex-messaging/duplex-creating.svg)
 
-The procedure of establishing a duplex connection is explained on the example of Alice and Bob creating a bi-directional connection comprised of two unidirectional (simplex) queues, using SMP agents (A and B) to facilitate it, and two different SMP servers (which could be the same server). It is shown on the diagram above and has these steps:
+The procedure of establishing a duplex connection is explained on the example of Alice and Bob creating a bi-directional connection consisting of two unidirectional (simplex) queues, using SMP agents (A and B) to facilitate it, and two different SMP servers (which could be the same server). It is shown on the diagram above and has these steps:
 
-1. Alice requests the new connection from the SMP agent A using `NEW` command.
-2. Agent A creates an SMP connection on the server (using [SMP protocol](./simplex-messaging.md)) and responds to Alice with the invitation that contains queue information and the encryption key Bob's agent B should use. The invitation format is described in [Connection invitation](#connection-invitation).
-3. Alice sends the invitation to Bob via any secure channel they have (out-of-band message).
-4. Bob sends `JOIN` command with the invitation as a parameter to agent B to accept the connection.
-5. Establishing Alice's SMP connection (with SMP protocol commands):
-  - Agent B sends an "SMP confirmation" to the SMP queue specified in the invitation - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info.
-  - Agent A receives the SMP confirmation containing Bob's key and info.
+1. Alice requests the new connection from the SMP agent A using SMP NEW command.
+2. Agent A creates an SMP connection on the server (using [SMP protocol](./simplex-messaging.md)) and responds to Alice with the invitation that contains queue information and the encryption key Bob's agent B should use. The invitation format is described in [Connection request](#connection-request).
+3. Alice sends the [connection request](#connection-request) to Bob via any secure channel (out-of-band message).
+4. Bob sends `JOIN` command with the connection request as a parameter to agent B to accept the connection.
+5. Establishing Alice's SMP queue (with SMP protocol commands):
+  - Agent B sends an "SMP confirmation" with SMP SEND command to the SMP queue specified in the connection request - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, etc.). This message is encrypted using key passed in the connection request (or with the derived key, in which case public key for key derivation should be sent in clear text).
+  - Agent A receives the SMP confirmation containing Bob's key and info as SMP MSG.
   - Agent A notifies Alice sending REQ notification with Bob's info.
   - Alice accepts connection request with ACPT command.
-  - Agent A secures the queue.
+  - Agent A secures the queue with SMP KEY command.
   - Agent B tries sending authenticated SMP SEND command with agent `HELLO` message until it succeeds. Once it succeeds, Bob's agent "knows" the queue is secured.
 6. Agent B creates a new SMP queue on the server.
 7. Establish Bob's SMP queue:
-  - Agent B sends `REPLY` message with the invitation to this 2nd queue to Alice's agent (via the 1st queue).
-  - Agent A, having received this `REPLY` message, sends unauthenticated message to SMP queue with Alice agent's ephemeral key that will be used to authenticate Alice's commands to the queue, as described in SMP protocol, and Alice's info.
-  - Bob's agent receives the key and Alice's information and secures the queue.
+  - Agent B sends `REPLY` message (SMP SEND command) with the connection request to this 2nd queue to Alice's agent (via the 1st queue) - this connection request SHOULD use "simplex" URI scheme.
+  - Agent A, having received `REPLY` message, sends unauthenticated message (SMP SEND) to SMP queue with Alice agent's ephemeral key that will be used to authenticate Alice's commands to the queue, as described in SMP protocol, and Alice's info.
+  - Bob's agent receives the key and Alice's information and secures the queue (SMP KEY).
   - Bob's agent sends the notification `INFO` with Alice's information to Bob.
   - Alice's agent keeps sending `HELLO` message until it succeeds.
 8. Agents A and B notify Alice and Bob that connection is established.
@@ -97,17 +99,21 @@ The procedure of establishing a duplex connection is explained on the example of
 
 At this point the duplex connection between Alice and Bob is established, they can use `SEND` command to send messages. The diagram also shows how the connection status changes for both parties, where the first part is the status of the SMP queue to receive messages, and the second part - the status of the queue to send messages.
 
-The most communication happens between the agents and servers, from the point of view of Alice and Bob they have only 3 steps to do:
+The most communication happens between the agents and servers, from the point of view of Alice and Bob there are 4 steps (not including notifications):
 
 1. Alice requests a new connection with `NEW` command and receives the invitation.
-2. Alice passes invitation out-of-band to Bob.
-3. Bob accepts the connection by sending `JOIN` command with the invitation to his agent.
+2. Alice passes connection request out-of-band to Bob.
+3. Bob accepts the connection with `JOIN` command with the connection request to his agent.
+4. Alice accepts the connection with `ACPT` command.
+5. Both parties receive `CON` notification once duplex connection is established.
+
+Clients SHOULD support establishing duplex connection asynchronously (when parties are intermittently offline) by persisting intermediate states and resuming SMP queue subscriptions.
 
 ## Communication between SMP agents
 
-SMP agents communicate via SMP servers managing creation, deletion and operations of SMP queues.
+To establish duplex connections and to send messages on behalf of their clients, SMP agents communicate via SMP servers.
 
-Agents can use SMP message client body (the part of the SMP message after header - see [SMP protocol](./simplex-messaging.md)) to transmit agent client messages and exchange messages between each other.
+Agents use SMP message client body (the part of the SMP message after header - see [SMP protocol](./simplex-messaging.md)) to transmit agent client messages and exchange messages between each other.
 
 Each SMP message client body, once decrypted, contains 3 parts (one of them may include binary message body), as defined by `decryptedSmpMessageBody` syntax:
 
@@ -115,8 +121,9 @@ Each SMP message client body, once decrypted, contains 3 parts (one of them may
 - `agentMessage` - a command/message to the other SMP agent:
   - to establish the connection with two SMP queues (`helloMsg`, `replyQueueMsg`)
   - to send and to acknowledge user messages (`clientMsg`, `acknowledgeMsg`)
-  - to notify another agent about queue deletion (`deleteQueueMsg`)
-- `msgPadding` - an optional message padding to make all SMP messages have consistent size as an additional privacy protection measure.
+  - to manage SMP queue rotation (`newQueueMessage`, `deleteQueueMsg`)
+  - to manage encryption key rotation (TODO)
+- `msgPadding` - an optional message padding to make all SMP messages have constant size, to prevent servers from observing the actual message size. The only case the message padding can be absent is when the message has exactly the maximum size, in all other cases the message MUST be padded to a fixed size.
 
 ### Messages between SMP agents
 
@@ -124,62 +131,69 @@ Message syntax below uses [ABNF][3] with [case-sensitive strings extension][4].
 
 ```abnf
 decryptedSmpMessageBody = agentMsgHeader CRLF agentMessage CRLF msgPadding
-agentMsgHeader = agentMsgId SP agentTimestamp SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent
+agentMsgHeader = agentMsgId SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent
 agentMsgId = 1*DIGIT
-agentTimestamp = <date-time> ; RFC3339
 previousMsgHash = encoded
 encoded = <base64 encoded>
 
-agentMessage = helloMsg / replyQueueMsg / deleteQueueMsg / clientMsg / acknowledgeMsg
+agentMessage = helloMsg / replyQueueMsg /
+               clientMsg / invitationMsg /
+               newQueueMessage / deleteQueueMsg 
 
 msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size)
 
-helloMsg = %s"HELLO" SP signatureVerificationKey [SP %s"NO_ACK"]
-; NO_ACK means that acknowledgements to client messages will NOT be sent in this connection by the agent that sent `HELLO` message.
-signatureVerificationKey = encoded
+helloMsg = %s"H"
 
-replyQueueMsg = %s"REPLY" SP <queueInfo> ; `queueInfo` is the same as in out-of-band message, see SMP protocol
+replyQueueMsg = %s"R" connectionRequest ; `connectionRequest` is defined below
 ; this message can only be sent by the second connection party
 
-deleteQueueMsg = %s"DEL" ; notification that recipient queue will be deleted
-; no need to notify the other party about suspending queue separately, as suspended and deleted queues are the same to the sender 
-; NOT SUPPORTED with the current implementation
-
-clientMsg = %s"MSG" SP size CRLF clientMsgBody CRLF ; CRLF is in addition to CRLF in decryptedSmpMessageBody
-size = 1*DIGIT
+clientMsg = %s"M" clientMsgBody
 clientMsgBody = *OCTET
 
-acknowledgeMsg = %s"ACK" SP agentMsgId SP ackStatus
-; NOT SUPPORTED with the current implementation
+; TODO remove and move to "public" header
+invitationMsg = %s"INV" SP connReqInvitation SP connInfo
+; `connReqInvitation` and `connInfo` are defined below
 
-ackStatus = %s"OK" / ackError
+newQueueMsg = %s"N" queueURI
+; this message can be sent by any party to add SMP queue to the connection.
+; NOT SUPPORTED in the current implementation
 
-ackError = %s"ERR" SP ackErrorType
-
-ackErrorType = ackUnknownMsg / ackProhibitedMsg / ackSyntaxErr
-
-ackUnknownMsg = %s"UNKNOWN"
-
-ackProhibitedMsg = %s"PROHIBITED" ; e.g. "HELLO" or "REPLY"
-
-ackSyntaxErr = %s"SYNTAX" SP syntaxErrCode
-syntaxErrCode = 1*DIGIT ; TODO
+deleteQueueMsg = %s"D" queueURI
+; notification that the queue with passed URI will be deleted
+; no need to notify the other party about suspending queue separately, as suspended and deleted queues are indistinguishable to the sender
+; NOT SUPPORTED in the current implementation
 ```
 
 #### HELLO message
 
-This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). It contains the verification key that the sender will use to cryptographically sign the messages.
+This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). It MAY contain the public key that the recipient would use to verify messages signed by the sender.
 
-Sending agent might need to retry sending HELLO message, as it would not have any other confirmation that the queue is secured other than the success of sending this message with the signed SEND command of SMP protocol.
+Sending agent might need to retry sending HELLO message, as it would not have any other confirmation that the queue is secured other than the success of sending this message with the signed SMP SEND command.
 
 #### REPLY message
 
-This is the message that is sent by the agent that received an out-of-band invitation to pass the invitation to the reply SMP queue to the agent that originated the connection (see diagram).
+This is the message that is sent by the agent that received an out-of-band connection request to pass the connection request for the reply SMP queues to the agent that originated the connection (see diagram).
 
 #### MSG message
 
 This is the agent envelope used to send client messages once the connection is established. Do not confuse it with the MSG response from SMP server to the agent and MSG response from SMP agent to the client that are sent in different contexts.
 
+#### INV message
+
+This message is sent to the SMP queue(s) in `connReqContact`, to establish a new connection via existing unsecured queue, that acts as a permanent connection link of a user.
+
+#### ACK message
+
+This message is sent to confirm the client message reception. It includes received message number, message hash and the reception status.
+
+#### NEW message
+
+This message is sent to add an additional SMP queue to the connection. Unlike REPLY message it can be sent at any time.
+
+#### DEL message 
+
+This message is sent to notify that the queue with passed URI will be deleted - having received this message, the receiving agent should no longer send messages to this queue. In case it was the last remaining send queue in the duplex connection, the agent MAY also delete the reply queue(s) in the connection.
+
 ## SMP agent commands
 
 This part describes the transmissions between users and client-side SMP agents: commands that the users send to create and operate duplex connections and SMP agent responses and messages they deliver.
@@ -189,31 +203,39 @@ Commands syntax below is provided using [ABNF][3] with [case-sensitive strings e
 Each transmission between the user and SMP agent must have this format/syntax:
 
 ```abnf
-agentTransmission = [corrId] CRLF [cAlias] CRLF agentCommand
+agentTransmission = [corrId] CRLF [connId] CRLF agentCommand
 
 corrId = 1*(%x21-7F) ; any characters other than control/whitespace
 
-cAlias = cId / cName
-cId = encoded
-cName = 1*(ALPHA / DIGIT / "_" / "-")
+connId = encoded
 
 agentCommand = (userCmd / agentMsg) CRLF
-userCmd = newCmd / joinCmd / acceptCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd
-agentMsg = invitation / connRequest / connInfo / connected / unsubscribed / connDown / connUp / messageId / sent / messageError / message / received / ok / error
+userCmd = newCmd / joinCmd / letCmd / acceptCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd
+agentMsg = invitation / confMsg / connReqMsg / connInfo / connected / unsubscribed / connDown / connUp / messageId / sent / messageError / message / received / ok / error
 
-newCmd = %s"NEW" [SP %s"NO_ACK"] ; response is `invitation` or `error`
+newCmd = %s"NEW" SP connectionMode [SP %s"NO_ACK"] ; response is `invitation` or `error`
 ; NO_ACK parameter currently not supported
 
-invitation = %s"INV" SP <queueInfo> ; `queueInfo` is the same as in out-of-band message, see SMP protocol
+connectionMode = %s"INV" / %s"CON"
 
-connRequest = %s"REQ" SP confirmationId SP msgBody
+invitation = %s"INV" SP connectionRequest ; `connectionRequest` is defined below
+
+confMsg = %s"CONF" SP confirmationId SP msgBody
 ; msgBody here is any binary information identifying connection request
 
+letCmd = %s"LET" SP confirmationId SP msgBody
+; msgBody here is any binary information identifying connecting party
+
 confirmationId = 1*DIGIT
 
-acceptCmd = %s"ACPT" SP confirmationId SP msgBody
+connReqMsg = %s"REQ" SP invitationId SP msgBody
+; msgBody here is any binary information identifying connection request
+
+acceptCmd = %s"ACPT" SP invitationId SP msgBody
 ; msgBody here is any binary information identifying connecting party
 
+invitationId = 1*DIGIT
+
 connInfo = %s"INFO" SP msgBody
 ; msgBody here is any binary information identifying connecting party
 
@@ -231,9 +253,10 @@ connDown = %s"DOWN"
 connUp = %s"UP"
 ; restored connection
 
-joinCmd = %s"JOIN" SP <queueInfo> [SP %s"NO_REPLY"] [SP %s"NO_ACK"]
-; `queueInfo` is the same as in out-of-band message, see SMP protocol
+joinCmd = %s"JOIN" SP connectionRequest SP connInfo [SP %s"NO_REPLY"] [SP %s"NO_ACK"]
+; `connectionRequest` and `connInfo` are defined below
 ; response is `connected` or `error`
+; parameters NO_REPLY and NO_ACK are currently not supported
 
 suspendCmd = %s"OFF" ; can be sent by either party, response `ok` or `error`
 
@@ -257,7 +280,7 @@ messageError = %s"MERR" SP agentMsgId SP <errorType>
 message = %s"MSG" SP msgIntegrity SP recipientMeta SP brokerMeta SP senderMeta SP binaryMsg
 recipientMeta = %s"R=" agentMsgId "," agentTimestamp ; receiving agent message metadata 
 brokerMeta = %s"B=" brokerMsgId "," brokerTimestamp ; broker (server) message metadata
-senderMeta = %s"S=" agentMsgId "," agentTimestamp ; sending agent message metadata 
+senderMeta = %s"S=" agentMsgId ; sending agent message ID 
 brokerMsgId = encoded
 brokerTimestamp = <date-time>
 msgIntegrity = ok / msgIntegrityError
@@ -275,9 +298,12 @@ previousMsgId = agentMsgId
 
 acknowledgeCmd = %s"ACK" SP agentMsgId ; ID assigned by receiving agent (in MSG "R")
 
-received = %s"RCVD" SP agentMsgId ; ID assigned by sending agent (in SENT response)
+received = %s"RCVD" SP agentMsgId SP msgIntegrity
+; ID assigned by sending agent (in SENT response)
 ; currently not implemented
 
+msgStatus = ok | error
+
 ok = %s"OK"
 
 error = %s"ERR" SP <errorType>
@@ -287,19 +313,27 @@ error = %s"ERR" SP <errorType>
 
 #### NEW command and INV response
 
-`NEW` command is used to create a connection and an invitation to be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party).
+`NEW` command is used to create a connection and a connection request to be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party).
 
 `INV` response is sent by the agent to the client of the initiating party.
 
+`NEW` command has `connectionMode` parameter to define the connection mode - to be used to communicate with a single contact (invitation mode, `connectionMode` is `INV`) or to accept connection requests from anybody (contact mode, `connectionMode` is `CON`). The type of connection request is determined by `connectionMode` parameter.
+
 #### JOIN command
 
-It is used to create a connection and accept the invitation received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party).
+It is used to create a connection and accept the connection request received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party).
+
+#### CONF notification and LET command
+
+When the joining party uses `JOIN` command to accept connection invitation created with `NEW INV` command, the initiating party will receive `CONF` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose.
+
+To continue with the connection the initiating party should use `LET` command.
 
 #### REQ notification and ACPT command
 
-When the joining party uses `JOIN` command, the initiating party will receive `REQ` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose.
+When the joining party uses `JOIN` command to connect to the contact created with `NEW CON` command, the initiating party will receive `REQ` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose.
 
-To continue with the connection the initiating party should use `ACPT` command.
+To continue with the connection the party that created the contact should use `ACPT` command.
 
 #### INFO and CON notifications
 
@@ -311,17 +345,17 @@ Once the connection is established and ready to accept client messages, both age
 
 This command can be used by the client to resume receiving messages from the connection that was created in another TCP/client session. Agent response to this command can be `OK` or `ERR` in case connection does not exist (or can only be used to send connections - e.g. when the reply queue was not created).
 
-#### SEND command and MID, SENT and MERR responses
+#### SEND command and MID, SENT, RCVD and MERR responses
 
 `SEND` command is used by the client to send messages.
 
-`MID` notification with the message ID (the sequential message number that includes both sent and received messages in the connection) is sent to the client to confirm that the message is accepted by the agent, before it is sent to the SMP server.
+`MID` response with the message ID (the sequential message number that includes both sent and received messages in the connection) is sent to the client to confirm that the message is accepted by the agent, before it is sent to the SMP server.
 
-`SENT` response is sent by the agent to confirm that the message was delivered to the SMP server. This notification contains the same message ID as `MID` notification. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session.
+`SENT` notification is sent by the agent to confirm that the message was delivered to at least one of SMP servers. This notification contains the same message ID as `MID` notification. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session.
 
-In case of the failure to send the message for any other reason than network connection or message queue quota - e.g. authentication error (`ERR AUTH`) or syntax error (`ERR CMD error`), the agent will send to the client `MERR` notification with the message ID, and this message delivery will no longer be attempted.
+`RCVD` notification is sent by the agent when it receives `ACK` message from the receiving agent. This notification contains reception status, only one successful notification will be sent, and multiple error notifications will be sent in case `ACK` had error status.
 
-In case of client disconnecting from the agent, the pending messages will not be sent until the client re-connects to the agent and subscribes to the connection that has pending messages.
+In case of the failure to send the message for any other reason than network connection or message queue quota - e.g. authentication error (`ERR AUTH`) or syntax error (`ERR CMD error`), the agent will send to the client `MERR` notification with the message ID, and this message delivery will no longer be attempted to this SMP queue.
 
 #### MSG notification
 
@@ -348,11 +382,36 @@ It is used to suspend the receiving SMP queue - sender will no longer be able to
 
 It is used to delete the connection and all messages in it, as well as the receiving SMP queue and all messages in it that were remaining on the server. Agent response to this command can be `OK` or `ERR`. This command is irreversible.
 
-## Connection invitation
+## Connection request
 
-Connection invitation `queueInfo` is generated by SMP agent in response to `newCmd` command (`"NEW"`), used by another party user with `joinCmd` command (`"JOIN"`), and then another invitation is sent by the agent in `replyQueueMsg` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users).
+Connection request `connectionRequest` is generated by SMP agent in response to `newCmd` command (`"NEW"`), used by another party user with `joinCmd` command (`"JOIN"`), and then another connection request is sent by the agent in `replyQueueMsg` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users).
 
-See SMP protocol [out-of-band messages](./simplex-messaging.md#out-of-band-messages) for connection invitation syntax.
+Connection request syntax:
+
+```
+connectionRequest = connectionScheme "/" connReqType "#/?smp=" smpQueues "&e2e=" e2eEncryption
+connReqType = %s"invitation" / %s"contact"
+; this parameter has the same meaning as connectionMode in agent commands
+; `NEW INV` creates `invitation` connection request, `NEW CON` - `contact`
+connectionScheme = (%s"https://" clientAppServer) | %s"simplex:"
+clientAppServer = hostname [ ":" port ]
+; client app server, e.g. simplex.chat
+e2eEncryption = encryptionScheme ":" publicKey
+encryptionScheme = %s"rsa" ; end-to-end encryption and key exchange protocols,
+                           ; the current hybrid encryption scheme (RSA-OAEP/AES-256-GCM-SHA256)
+                           ; will be replaced with double ratchet protocol and DH key exchange.
+publicKey = <base64url X509 SPKI key encoding>
+smpQueues = smpQueue [ "," 1*smpQueue ] ; SMP queues for the connection
+smpQueue = <URL-encoded queueURI defined in SMP protocol>
+```
+
+All parameters are passed via URI hash to avoid sending them to the server (in case "https" scheme is used) - they can be used by the client-side code and processed by the client application. Parameters `smp` and `e2e` can be present in any order, any unknown additional parameters SHOULD be ignored.
+
+`clientAppServer` is not an SMP server - it is a server that shows the instruction on how to download the client app that will connect using this connection request. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device.
+
+"simplex" URI scheme in `connectionProtocol` can be used instead of client app server, to connect without creating any web traffic. Client apps MUST support this URI scheme.
+
+See SMP protocol [out-of-band messages](./simplex-messaging.md#out-of-band-messages) for syntax of `queueURI`.
 
 [1]: https://en.wikipedia.org/wiki/End-to-end_encryption
 [2]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack

protocol/diagrams/notifications/register-token.mmd

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

@@ -0,0 +1,40 @@
+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/overview-tjr.md

@@ -0,0 +1,313 @@
+Revision 1, 2022-01-01
+
+Evgeny Poberezkin
+
+# SimpleX: messaging and application platform
+
+## Table of contents
+
+- [Introduction](#introduction)
+  - [What is SimpleX](#what-is-simplex)
+  - [SimpleX objectives](#simplex-objectives)
+  - [In Comparison](#in-comparison)
+- [Technical Details](#technical-details)
+  - [Trust in Servers](#trust-in-servers)
+  - [Client -> Server Communication](#client---server-communication)
+  - [SimpleX Messaging Protocol](#simplex-messaging-protocol)
+  - [SimpleX Agents](#simplex-agents)
+  - [Encryption Primitives Used](#encryption-primitives-used)
+- [Threat model](#threat-model)
+- [Acknowledgements](#acknowledgements)
+
+## Introduction
+
+#### What is SimpleX
+
+SimpleX as a whole is a platform upon which applications can be built. [SimpleX Chat](https://github.com/simplex-chat/simplex-chat) is one such application that also serves as an example and reference application.
+
+ - [SimpleX Messaging Protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) (SMP) is a protocol to send messages in one direction to a recipient, relying on a server in-between. The messages are delivered via uni-directional queues created by recipients.
+
+ - SMP runs over a transport protocol (shown below as TLS) that provides integrity, server authentication, confidentiality, and transport channel binding.
+
+ - A SimpleX Server is one of those servers.
+
+ - The SimpleX Network is the term used for the collective of SimpleX Servers that facilitate SMP.
+
+ - SimpleX Client libraries speak SMP to SimpleX Servers and provide a low-level API not generally intended to be used by applications.
+
+ - SimpleX Agents interface with SimpleX Clients to provide a more high-level API intended to be used by applications. Typically they are embedded as libraries, but are designed so they can also be abstracted into local services.
+
+
+*Diagram showing the SimpleX Chat app, with logical layers of the chat application interfacing with a SimpleX Agent library, which in turn interfaces with a SimpleX Client library. The Client library in turn speaks the Messaging Protocol to a SimpleX Server.*
+
+```
+  User's Computer                 Internet                    Third-Party Server
+------------------     |   ----------------------     |   -------------------------
+                       |                              |
+   SimpleX Chat        |                              |
+                       |                              |
++----------------+     |                              |
+|    Chat App    |     |                              |
++----------------+     |                              |
+|  SimpleX Agent |     |                              |
++----------------+    -------------- TLS ----------------    +----------------+
+| SimpleX Client | ------ SimpleX Messaging Protocol ------> | SimpleX Server |
++----------------+    -----------------------------------    +----------------+
+                       |                              |
+```
+
+#### SimpleX objectives
+
+1. Provide messaging infrastructure for distributed applications. This infrastructure needs to have the following qualities:
+
+   - Security against passive and active (man-in-the-middle) attacks: the parties should have reliable end-to-end encryption and be able to detect the presence of an active attacker who modified, deleted or added messages.
+
+   - Privacy: protect against traffic correlation attacks to determine the contacts that the users communicate with.
+
+   - Reliability: the messages should be delivered even if some participating network servers or receiving clients fail, with “at least once” delivery guarantee.
+
+   - Integrity: the messages sent in one direction are ordered in a way that sender and recipient agree on; the recipient can detect when a message was removed or changed.
+
+   - Asynchronous delivery: it should not be required that both communicating parties (client devices, services or applications) are online for reliable message delivery.
+
+   - Low latency: the delay introduced by the network should not be higher than 100ms-1s in addition to the underlying TCP network latency.
+
+2. Provide better communication security and privacy than the alternative instant messaging solutions.  In particular SimpleX provides better privacy of metadata (who talks to whom and when) and better security against active network attackers and malicious servers.
+
+3. Balance user experience with privacy requirements, prioritizing experience of mobile device users.
+
+#### In Comparison
+
+SimpleX network has a design similar to P2P networks, but unlike most P2P networks it consists of clients and servers without depending on any centralized component.
+In comparison to more traditional messaging applications (e.g. WhatsApp, Signal, Telegram) the key differences of SimpleX network are:
+
+- participants do not need to have globally unique addresses to communicate, instead they use redundant unidirectional (simplex) messaging queues, with a separate set of queues for each contact.
+
+- connection requests are passed out-of-band, non-optionally protecting key exchange against man-in-the-middle attack.
+
+- simple message queues provided by network servers are used by the clients to create more complex communication scenarios, such as duplex one-to-one communication, transmitting files, group communication without central servers, and content/communication channels.
+
+- servers do not store any user information (no user profiles or contacts, or messages once they are delivered), and primarily use in-memory persistence.
+
+- users can change servers with minimal disruption - even after an in-use server disappears, simply by changing the configuration on which servers the new queues are created.
+
+## Technical Details
+
+#### Trust in Servers
+
+Clients communicate directly with servers (but not with other clients) using SimpleX Messaging Protocol (SMP) running over some transport protocol that provides integrity, server authentication, confidentiality, and transport channel binding. By default, we assume this transport protocol is TLS.
+
+Users use multiple servers, and choose where to receive their messages. Accordingly, they send messages to their communication partners' chosen servers.
+
+Although end-to-end encryption is always present, users place a degree of trust in servers. This trust decision is very similar to a user's choice of email provider; however the trust placed in a SimpleX server is significantly less. Notably, there is no re-used identifier or credential between queues on the same (or different) servers. While a user *may* re-use a connection to fetch from multiple queues, or connect to a server from the same IP address, both are choices a user may opt into to break the promise of un-correlatable queues.
+
+Users may trust a server because:
+
+- They deploy and control the servers themselves from the available open-source code. This has the trade-offs of strong trust in the server but limited metadata obfuscation to a passive network observer. Techniques such as noise traffic, traffic mixing (incurring latency), and using an onion routing transport protocol can mitigate that latter.
+
+- They use servers from a trusted commercial provider. The more clients the provider has, the less metadata about the communication times is leaked to the network observers.
+
+- Users trust their contacts and the servers they chose.
+
+By default, servers do not retain access logs, and permanently delete messages and queues when requested.  Messages persist only in memory until they cross a threshold of time, typically on the order of days.[0] There is still a risk that a server maliciously records all queues and messages (even though encrypted) sent via the same transport connection to gain a partial knowledge of the user’s communications graph and other meta-data.
+
+SimpleX supports measures (managed transparently to the user at the agent level) to mitigate the trust placed in servers.  These include rotating the queues in use between users, noise traffic, and supporting overlay networks such as Tor.
+
+[0] While configurable by servers, a minimum value is enforced by the default software. SimpleX Agents provide redundant routing over queues to mitigate against message loss.
+
+
+#### Client -> Server Communication
+
+Utilizing TLS grants the SimpleX Messaging Protocol (SMP) server authentication and metadata protection to a passive network observer. But SMP does not rely on the transport protocol for message confidentiality or client authentication. The SMP protocol itself provides end-to-end confidentiality, authentication, and integrity of messages between communicating parties.
+
+Servers have long-lived, self-signed, offline certificates whose hash is pre-shared with clients over secure channels - either provided with the client library or provided in the secure introduction between clients.  The offline certificate signs an online certificate used in the transport protocol handshake. [0]
+
+If the transport protocol's confidentiality is broken, incoming and outgoing messages to the server cannot be correlated by message contents. Additionally, because of encryption at the SMP layer, impersonating the server is not sufficient to pass (and therefore correlate) a message from a sender to recipient - the only attack possible is to drop the messages. Only by additionally *compromising* the server can one pass and correlate messages.
+
+It's important to note that the SMP protocol does not do server authentication. Instead we rely upon the fact that an attacker who tricks the transport protocol into authenticating the server incorrectly cannot do anything with the SMP messages except drop them.
+
+After the connection is established, the client sends blocks of a fixed size 16Kb, and the server replies with the blocks of the same size to reduce metadata observable to a network adversary. The protocol has been designed to make traffic correlation attacks difficult, adapting ideas from Tor, remailers, and more general onion and mix networks. It does not try to replace Tor though - SimpleX servers can be deployed as onion services and SimpleX clients can communicate with servers over Tor to further improve participants privacy.
+
+By using fixed-size blocks, oversized for the expected content, the vast majority of traffic is uniform in nature. When enough traffic is transiting a server simultaneously, the server acts as a (very) low-latency mix node.  We can't rely on this behavior to make a security claim, but we have engineered to take advantage of it when we can. As mentioned, this holds true even if the transport connection is compromised.
+
+The protocol does not protect against attacks targeted at particular users with known identities - e.g., if the attacker wants to prove that two known users are communicating, they can achieve it. At the same time, it substantially complicates large-scale traffic correlation, making determining the real user identities much less effective.
+
+[0] Future versions of SMP may add support for revocation lists of certificates, presently this risk is mitigated by the SMP protocol itself.
+
+
+#### SimpleX Messaging Protocol
+
+SMP is initialized with an in-person or out-of-band introduction message, where Alice provides Bob with details of a server (including IP, port, and hash of the long-lived offline certificate), a queue ID, and Alice's public key for her receiving queue. These introductions are similar to the PANDA key-exchange, in that if observed, the adversary can race to establish the communication channel instead of the intended participant. [0]
+
+Because queues are uni-directional, Bob provides an identically-formatted introduction message to Alice over Alice's now-established receiving queue.
+
+When setting up a queue, the server will create separate sender and recipient queue IDs (provided to Alice during set-up and Bob during initial connection). Additionally, during set-up Alice will perform a DH exchange with the server to agree upon a shared secret. This secret will be used to re-encrypt Bob's incoming message before Alice receives it, creating the anti-correlation property earlier-described should the transport encryption be compromised.
+
+[0] Users can additionally create public 'contact queues' that are only used to receive connection requests.  
+
+#### SimpleX Agents
+
+SimpleX agents provide higher-level operations compared to SimpleX Clients, who are primarily concerned with creating queues and communicating with servers using SMP.  Agent operations include:
+
+- Managing sets of bi-directional, redundant queues for communication partners
+
+- Providing end-to-end encryption of messages
+
+- Rotating queues periodically with communication partners
+
+- Noise traffic
+
+#### Encryption Primitives Used
+
+- Ed448 to sign/verify commands to SMP servers (Ed25519 is also supported via client/server configuration).
+- Curve25519 for DH exchange to agree:
+  - the shared secret between server and recipient (to encrypt message bodies - it avoids shared cipher-text in sender and recipient traffic)
+  - the shared secret between sender and recipient (to encrypt messages end-to-end in each queue - it avoids shared cipher-text in redundant queues).
+- [NaCl crypto_box](https://nacl.cr.yp.to/box.html) encryption scheme (curve25519xsalsa20poly1305) for message body encryption between server and recipient and for E2E per-queue encryption.
+- SHA256 to validate server offline certificates.
+- [double ratchet](https://signal.org/docs/specifications/doubleratchet/) protocol for end-to-end message encryption between the agents:
+  - Curve448 keys to agree shared secrets required for double ratchet initialization (using [X3DH](https://signal.org/docs/specifications/x3dh/) key agreement with 2 ephemeral keys for each side),
+  - AES-GCM AEAD cipher,
+  - SHA512-based HKDF for key derivation.
+
+## Threat Model
+
+#### Global Assumptions
+
+ - A user protects their local database and key material
+ - The user's application is authentic, and no local malware is running
+ - The cryptographic primitives in use are not broken
+ - A user's choice of servers is not directly tied to their identity or otherwise represents distinguishing information about the user.
+
+#### A passive adversary able to monitor the traffic of one user
+
+*can:*
+
+ - identify that and when a user is using SimpleX
+
+ - block SimpleX traffic
+
+ - determine which servers the user communicates with
+
+ - observe how much traffic is being sent, and make guesses as to its purpose.
+
+*cannot:*
+
+ - see who sends messages to the user and who the user sends the messages to
+
+#### A passive adversary able to monitor a set of senders and recipients
+
+ *can:*
+
+ - identify who and when is using SimpleX
+
+ - learn which SimpleX Messaging Protocol servers are used as receive queues for which users
+
+ - learn when messages are sent and received
+
+ - perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers
+
+ - observe how much traffic is being sent, and make guesses as to its purpose
+
+*cannot, even in case of a compromised transport protocol:*
+
+ - perform traffic correlation attacks with any increase in efficiency over a non-compromised transport protocol
+
+#### SimpleX Messaging Protocol server
+
+*can:*
+
+- learn when a queue recipient or sender is online
+
+- know how many messages are sent via the queue (although some may be noise)
+
+- perform queue correlation (matching multiple queues to a single user) via either a re-used transport connection, user's IP Address, or connection timing regularities
+
+- learn a user's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used.
+
+- drop all future messages inserted into a queue, detectable only over other, redundant queues
+
+- lie about the state of a queue to the recipient and/or to the sender  (e.g. suspended or deleted when it is not).
+
+- spam a user with invalid messages
+
+*cannot:*
+
+- undetectably add, duplicate, or corrupt individual messages
+
+- undetectably drop individual messages, so long as a subsequent message is delivered
+
+- learn the contents of messages
+
+- distinguish noise messages from regular messages except via timing regularities
+
+- compromise the user's end-to-end encryption with an active attack
+
+#### An attacker who obtained Alice's (decrypted) chat database
+
+*can:*
+
+- see the history of all messages exchanged by Alice with her communication partners
+
+- see shared profiles of contacts and groups
+
+- surreptitiously receive new messages sent to Alice via existing queues; until communication queues are rotated or the Double-Ratchet advances forward
+
+- prevent Alice from receiving all new messages sent to her - either surreptitiously by emptying the queues regularly or overtly by deleting them
+
+- send messages from the user to their contacts; recipients will detect it as soon as the user sends the next message, because the previous message hash won’t match (and potentially won’t be able to decrypt them in case they don’t keep the previous ratchet keys).
+
+*cannot:*
+
+- impersonate a sender and send messages to the user whose database was stolen. Doing so requires also compromising the server (to place the message in the queue, that is possible until the Double-Ratchet advances forward) or the user's device at a subsequent time (to place the message in the database).
+
+- undetectably communicate at the same time as Alice with her contacts. Doing so would result in the contact getting different messages with repeated IDs.
+
+- undetectably monitor message queues in realtime without alerting the user they are doing so, as a second subscription request unsubscribes the first and notifies the second.
+
+#### A user’s contact
+
+*can:*
+
+- spam the user with messages
+
+- forever retain messages from the user
+
+*cannot:*
+
+- cryptographically prove to a third-party that a message came from a user (assuming the user’s device is not seized)
+
+- prove that two contacts they have is the same user
+
+- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user
+
+#### An attacker who observes Alice showing an introduction message to Bob
+
+*can:*
+
+ - Impersonate Bob to Alice
+
+*cannot:*
+
+ - Impersonate Alice to Bob
+
+#### An attacker with Internet access
+
+*can:*
+
+- Denial of Service SimpleX messaging servers
+
+- spam a user's public “contact queue” with connection requests
+
+*cannot:*
+
+- send messages to a user who they are not connected with
+
+- enumerate queues on a SimpleX server
+
+
+## Acknowledgements
+
+Efim Poberezkin contributed to the design and implementation of [SimpleX Messaging Protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) and [SimpleX Agent Protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) since 2019.
+
+Adam Langley's [Pond](https://github.com/agl/pond) inspired some of the recent improvements and the structure of this document.

protocol/simplex-messaging.md

@@ -7,11 +7,14 @@
 - [SMP Model](#smp-model)
 - [Out-of-band messages](#out-of-band-messages)
 - [Simplex queue](#simplex-queue)
+- [SMP queue URI](#smp-queue-uri)
 - [SMP procedure](#smp-procedure)
 - [SMP qualities and features](#smp-qualities-and-features)
 - [Cryptographic algorithms](#cryptographic-algorithms)
 - [Simplex queue IDs](#simplex-queue-ids)
-- [Server privacy requirements](#server-privacy-requirements)
+- [Server security requirements](#server-security-requirements)
+- [Message delivery notifications](#message-delivery-notifications)
+- [SMP Transmission structure](#smp-transmission-structure)
 - [SMP commands](#smp-commands)
   - [Correlating responses with commands](#correlating-responses-with-commands)
   - [Command authentication](#command-authentication)
@@ -20,14 +23,19 @@
     - [Create queue command](#create-queue-command)
     - [Subscribe to queue](#subscribe-to-queue)
     - [Secure queue command](#secure-queue-command)
+    - [Enable notifications command](#enable-notifications-command)
     - [Acknowledge message delivery](#acknowledge-message-delivery)
     - [Suspend queue](#suspend-queue)
     - [Delete queue](#delete-queue)
   - [Sender commands](#sender-commands)
     - [Send message](#send-message)
+  - [Notifier commands](#notifier-commands)
+    - [Subscribe to queue notifications](#subscribe-to-queue-notifications)
   - [Server messages](#server-messages)
     - [Queue IDs response](#queue-ids-response)
     - [Deliver queue message](#deliver-queue-message)
+    - [Notifier queue ID response](#notifier-queue-id-response)
+    - [Deliver message notification](#deliver-message-notification)
     - [Subscription END notification](#subscription-end-notification)
     - [Error responses](#error-responses)
     - [OK response](#ok-response)
@@ -66,37 +74,15 @@ The SMP model has three communication participants: the recipient, the message b
 
 SMP server manages multiple "simplex queues" - data records on the server that identify communication channels from the senders to the recipients. The same communicating party that is the sender in one queue, can be the recipient in another - without exposing this fact to the server.
 
-The queue record consists of 2 unique random IDs generated by the server, one for the recipient and another for the sender, and 2 keys to authenticate the recipient and the sender respectively, provided by the client. The users of SMP protocol must use a unique key for each queue, to avoid the possibility of aggregating and analysing their queues in case SMP server is compromised.
+The queue record consists of 2 unique random IDs generated by the server, one for the recipient and another for the sender, and 2 keys to authenticate the recipient and the sender respectively, provided by the client. The users of SMP protocol must use a unique key for each queue, to avoid the possibility of aggregating and analyzing their queues in case SMP server is compromised.
 
 Creating and using the queue requires sending commands to the SMP server from the recipient and the sender - they are described in detail in [SMP commands](#smp-commands) section.
 
 ## Out-of-band messages
 
-The out-of-band message with the queue information is sent via some trusted alternative channel from the recipient to the sender. This message is used to share the encryption (a.k.a. "public") key that the sender will use to encrypt the messages (to be decrypted by the recipient), sender queue ID, server hostname and any other information necessary to establish secure encrypted connection with SMP server (see [Appendix A](#appendix-a) for SMP transport protocol).
+The out-of-band message with the queue information is sent via some trusted alternative channel from the recipient to the sender. This message is used to share one or several [queue URIs](#smp-queue-uri) that parties can use to establish the initial connection, the encryption scheme and, it can include the public key(s) for end-to-end encryption.
 
-The [ABNF][8] syntax of the message is:
-
-```abnf
-queueInfo = %s"smp::" smpServer "::" queueId "::" encryptionKey
-smpServer = srvHost [":" port] ["#" serverKeyHash]
-srvHost = <hostname> ; RFC1123, RFC5891
-port = 1*DIGIT
-serverKeyHash = encoded
-queueId = encoded
-encryptionKey = %s"rsa:" x509encoded ; the recipient's RSA public key for sender to encrypt messages
-x509encoded = <base64 X509 key encoding>
-encoded = <base64 encoded>
-```
-
-`hostname` can be IP address or domain name, as defined in RFC 1123, section 2.1.
-
-`port` is optional, the default TCP port for SMP protocol is 5223.
-
-`serverKeyHash` is an optional hash of the server transport key used during transport handshake (see [Appendix A](#appendix-a)).
-
-Encryption keys are encoded using [X509][11] specification.
-
-Defining the approach to out-of-band message passing is out of scope of this protocol.
+The approach to out-of-band message passing and their syntax should be defined in application-level protocols.
 
 ## Simplex queue
 
@@ -104,7 +90,7 @@ The simplex queue is the main unit of SMP protocol. It is used by:
 
 - Sender of the queue (who received out-of-band message) to send messages to the server using sender's queue ID, signed by sender's key.
 
-- Recipient of the queue (who created the queue and sent out-of-band message) will use it to retrieve messages from the server, signing the commands by the recipient key.
+- Recipient of the queue (who created the queue and sent out-of-band message) will use it to retrieve messages from the server, signing the commands by the recipient key. Recipient decrypts the messages with the key negotiated during the creation of the queue.
 
 - Participant identities are not shared with the server - new unique keys and queue IDs are used for each queue.
 
@@ -114,7 +100,7 @@ This approach is based on the concept of [unidirectional networks][4] that are u
 
 Access to each queue is controlled with unique (not shared with other queues) asymmetric key pairs, separate for the sender and the recipient. The sender and the receiver have private keys, and the server has associated public keys to authenticate participants' commands by verifying cryptographic signatures.
 
-The messages sent over the queue are encrypted and decrypted using another key pair that was shared via out-of-band message - the recipient has the private key and the sender has the associated public key.
+The messages sent over the queue are end-to-end encrypted using the DH secret agreed via out-of-band message and SMP confirmation.
 
 **Simplex queue diagram:**
 
@@ -124,6 +110,34 @@ Queue is defined by recipient ID `RID` and sender ID `SID`, unique for the serve
 
 The protocol uses different IDs for sender and recipient in order to provide an additional privacy by preventing the correlation of senders and recipients commands sent over the network - in case the encrypted transport is compromised, it would still be difficult to correlate senders and recipients without access to the queue records on the server.
 
+## SMP queue URI
+
+The SMP queue URIs MUST include server identity, queue hostname, an optional port, sender queue ID and the public key that the clients must use to verify responses. Server identity is used to establish secure connection protected from MITM attack with SMP server (see [Appendix A](#appendix-a) for SMP transport protocol).
+
+The [ABNF][8] syntax of the queue URI is:
+
+```abnf
+queueURI = %s"smp://" smpServer "/" queueId "#" recipientDhPublicKey
+smpServer = serverIdentity "@" srvHost [":" port]
+srvHost = <hostname> ; RFC1123, RFC5891
+port = 1*DIGIT
+serverIdentity = base64url
+queueId = base64url
+base64url = <base64url encoded binary> ; RFC4648, section 5
+recipientDhPublicKey = x509UrlEncoded
+; the recipient's Curve25519 key for DH exchange to derive the secret
+; that the sender will use to encrypt delivered messages
+; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
+
+x509UrlEncoded = <base64url X509 key encoding>
+```
+
+`hostname` can be IP address or domain name, as defined in RFC 1123, section 2.1.
+
+`port` is optional, the default TCP port for SMP protocol is 5223.
+
+`serverIdentity` is a required hash of the server certificate SPKI block (without line breaks, header and footer) used by the client to validate server certificate during transport handshake (see [Appendix A](#appendix-a))
+
 ## SMP procedure
 
 The SMP procedure of creating a simplex queue on SMP server is explained using participants Alice (the recipient) who wants to receive messages from Bob (the sender).
@@ -138,17 +152,21 @@ To create and start using a simplex queue Alice and Bob follow these steps:
 
     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. 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" key `RK` that 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).
+    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. The server sends `"IDS"` response with queue IDs (`queueIds`):
+    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`):
 
         - 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.
 
+        - 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 to encrypt messages.
+    - 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)).
 
@@ -170,9 +188,11 @@ To create and start using a simplex queue Alice and Bob follow these steps:
 
 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 with "private" key `EK`.
+    1. She decrypts received message body using the secret `SS`.
 
-    2. 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.
+    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.
 
 5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
 
@@ -198,7 +218,7 @@ Bob now can securely send messages to Alice:
 
     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 provided to the server).
+    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):
 
@@ -266,7 +286,7 @@ Simplex Messaging Protocol:
 
   - One unique "public" key is used by the servers to authenticate requests to send the messages into the queue, and another unique "public" key - to retrieve the messages from the queue. "Unique" here means that each "public" key is used only for one queue and is not used for any other context - effectively, this key is not public and does not represent any participant identity.
 
-  - Both recipient and sender "public" keys are provided to the server by the queue recipient. "Public" key `RK` is provided when the queue is created, public key `SK` is proviced when the queue is secured.
+  - Both recipient and sender "public" keys are provided to the server by the queue recipient. "Public" key `RK` is provided when the queue is created, public key `SK` is provided when the queue is secured.
 
   - The "public" keys known to the server and used to authenticate commands from the participants are unrelated to the keys used to encrypt and decrypt the messages - the latter keys are also unique per each queue but they are only known to participants, not to the servers.
 
@@ -274,29 +294,36 @@ Simplex Messaging Protocol:
 
 ## Cryptographic algorithms
 
-Simplex messaging clients need to cryptographically sign commands for the following operations:
+Simplex messaging clients and servers must cryptographically sign commands, responses and messages for the following operations:
 
 - With the recipient's key `RK` (server to verify):
   - create the queue (`NEW`)
   - subscribe to queue (`SUB`)
   - secure the queue (`KEY`)
+  - enable queue notifications (`NKEY`)
   - acknowledge received messages (`ACK`)
   - suspend the queue (`OFF`)
   - delete the queue (`DEL`)
 - With the sender's key `SK` (server to verify):
   - send messages (`SEND`)
+- With the optional notifier's key:
+  - subscribe to message notifications (`NSUB`)
+- With the server's key (for recipient and sender to verify)
+  - queue IDs response (`IDS`)
+  - notifier queue ID response (`NID`)
+  - delivered messages (`MSG`)
+  - `OK` and `ERR` responses (excluding error responses not related to a queue)
 
-To sign and verify commands, clients and servers MUST use RSA-PSS algorithm defined in [RFC3447][2].
+To sign/verify transmissions clients and servers MUST use Ed25519 or Ed448 algorithm defined in [RFC8709][15].
 
-To optionally sign and verify messages, clients SHOULD use RSA-PSS algorithm.
+To encrypt/decrypt message bodies delivered to the recipients, servers/clients MUST use x25519 or x448 algorithm defined in [RFC8709][15] to derive the shared secret (TODO encryption scheme).
 
-To encrypt and decrypt messages, clients and servers SHOULD use RSA-OAEP algorithm defined in [RFC3447][2].
+Clients MUST encrypt message bodies sent via SMP servers - the protocol for this end-to-end encryption should be chosen by the clients using SMP protocol.
 
 The reasons to use these algorithms:
 
-- They are supported by WebCrypto API.
-- They are more widely supported than ECC algorithms.
-- They are newer versions than RSA-PKCS1-v1_5 encryption and signature schemes.
+- Faster operation than RSA algorithms.
+- DH key exchange provides forward secrecy.
 
 Future versions of the protocol may allow different cryptographic algorithms.
 
@@ -319,48 +346,89 @@ Simplex messaging server implementations MUST NOT create, store or send to any o
 
 - Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using simplex messaging servers.
 
-## SMP commands
+## Message delivery notifications
 
-Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
+Supporting message delivery while the client mobile app is not running requires sending push notifications with the device token. All alternative mechanisms for background message delivery are unreliable, particularly on iOS platform. Obviously, supporting push notification delivery by simply subscribing to messages would reduce meta-data privacy as it allows to see all queues that a given device uses.
 
-Each transmission between the client and the server must have this format/syntax (after the decryption):
+To protect the privacy of the recipients, there are several commands in SMP protocol that allow enabling and subscribing to message notifications from SMP queues, using separate set of "notifier keys" and via separate queue IDs - as long as SMP server is not compromised, these notifier queue IDs cannot be correlated with recipient or sender queue IDs.
 
-```abnf
-transmission = [signature] SP signed SP pad ; pad to the fixed block size
-signed = [corrId] SP [queueId] SP cmd
-cmd = ping / recipientCmd / send / serverMsg
-recipientCmd = create / subscribe / secure / acknowledge / suspend / delete
-serverMsg = pong / queueIds / message / unsubscribed / ok / error
-corrId = 1*(%x21-7F) ; any characters other than control/whitespace
-queueId = encoded ; empty queue ID is used with "create" command
+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).
+- `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
+- `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
+
+## SMP Transmission structure
+
+Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
+
+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:
+
+```
+paddedString = originalLength string pad
+originalLength = 2*2 OCTET
+pad = N*N"#" ; where N = paddedLength - originalLength - 2
+
+paddedNotation = <padded(string, paddedLength)>
+; string - un-padded string
+; paddedLength - required length after padding, including 2 bytes for originalLength
+```
+
+Each transmission between the client and the server must have this format/syntax:
+
+```
+paddedTransmission = <padded(transmission), 16384>
+transmission = [signature] SP signed
+signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
+; corrId is required in client commands and server responses,
+; it is empty in server notifications.
+corrId = 1*32(%x21-7F) ; any characters other than control/whitespace
+queueId = encoded ; max 32 bytes when decoded (24 bytes is used),
+; empty queue ID is used with "create" command and in some server responses
 signature = encoded
-; empty signature can be used with "create", "send" and "ping" commands and server messages
+; empty signature can be used with "send" before the queue is secured with secure command
+; signature is always empty with "ping" and "serverMsg"
 encoded = <base64 encoded binary>
 ```
 
 `base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
 
+## 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 /
+               acknowledge / suspend / delete
+serverMsg = queueIds / message / notifierId / messageNotification /
+            unsubscribed / ok / error
+```
+
 The syntax of specific commands and responses is defined below.
 
 ### Correlating responses with commands
 
-The server should send `queueIds`, `error` and `ok` responses in the same order within each queue ID as the commands received in the transport connection, so that they can be correlated by the clients. To simplify correlation of commands and responses, the server should use the same `corrId` in the response as in the command sent by the client.
+The server should send `queueIds`, `error` and `ok` responses in the same order within each queue ID as the commands received in the transport connection, so that they can be correlated by the clients. To simplify correlation of commands and responses, the server must use the same `corrId` in the response as in the command sent by the client.
 
 If the transport connection is closed before some responses are sent, these responses should be discarded.
 
 ### Command authentication
 
-SMP servers must authenticate all transmissions (excluding `ping` and `send` commands) by verifying the provided signatures. Command signature should be generated by applying RSA-PSS algorithm to the `signed` block of the transmission using the key associated with the queue ID (sender's or recipient's, depending on which queue ID is used).
+SMP servers must authenticate all transmissions (excluding `ping` and initial `send` commands) by verifying the client signatures. Command signature should be generated by applying the algorithm specified for the queue to the `signed` block of the transmission, using the key associated with the queue ID (recipient's, sender's or notifier's, depending on which queue ID is used).
 
 ### Keep-alive command
 
-To keep the transport connection alive and to generate noise traffic the clients should use `ping` command to which the server responds with `pong` response. This command should be sent unsigned and without queue ID.
+To keep the transport connection alive and to generate noise traffic the clients should use `ping` command to which the server responds with `ok` response. This command should be sent unsigned and without queue ID.
 
 ```abnf
 ping = %s"PING"
-pong = %s"PONG"
 ```
 
+This command is always send unsigned.
+
 ### Recipient commands
 
 Sending any of the commands in this section (other than `create`, that is sent without queue ID) is only allowed with recipient's ID (`RID`). If sender's ID is used the server must respond with `"ERR AUTH"` response (see [Error responses](#error-responses)).
@@ -370,24 +438,36 @@ Sending any of the commands in this section (other than `create`, that is sent w
 This command is sent by the recipient to the SMP server to create a new queue. The syntax is:
 
 ```abnf
-create = %s"NEW" SP recipientKey
-recipientKey = %s"rsa:" x509encoded ;  the recipient's RSA public key for this queue
-x509encoded = <base64 X509 key encoding>
+create = %s"NEW " recipientSignaturePublicKey recipientDhPublicKey
+recipientSignaturePublicKey = length x509encoded
+; the recipient's Ed25519 or Ed448 public key to verify commands for this queue
+
+recipientDhPublicKey = length x509encoded
+; the recipient's Curve25519 key for DH exchange to derive the secret
+; that the server will use to encrypt delivered message bodies
+; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
+
+x509encoded = <binary X509 key encoding>
+
+length = 1*1 OCTET
 ```
 
-If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs:
+If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs and public keys to sign all responses and messages and to encrypt delivered message bodies:
 
 ```abnf
-queueIds = %s"IDS" SP recipientId SP senderId
-recipientId = encoded
-senderId = encoded
+queueIds = %s"IDS " recipientId senderId srvDhPublicKey
+serverDhPublicKey = length x509encoded
+; the server's Curve25519 key for DH exchange to derive the secret
+; that the server will use to encrypt delivered message bodies to the recipient
+recipientId = length *OCTET ; 16-24 bytes
+senderId = length *OCTET ; 16-24 bytes
 ```
 
-This response should be sent with empty queue ID (the second part of the transmission).
-
 Once the queue is created, the recipient gets automatically subscribed to receive the messages from that queue, until the transport connection is closed. The `subscribe` command is needed only to start receiving the messages from the existing queue when the new transport connection is opened.
 
-NEW `transmission` must be signed using the `recipientKey` that was passed in the transmission.
+`NEW` transmission MUST be signed using the private part of the `recipientSignaturePublicKey` – this verifies that the client has the private key that will be used to sign subsequent commands for this queue.
+
+`IDS` response transmission MUST be sent with empty queue ID (the third part of the transmission).
 
 #### Subscribe to queue
 
@@ -401,19 +481,43 @@ If subscription is successful the server must respond with the first available m
 
 The first message will be delivered either immediately or as soon as it is available; to receive the following message the recipient must acknowledge the reception of the message (see [Acknowledge message delivery](#acknowledge-message-delivery)).
 
+This transmission and its response MUST be signed.
+
 #### Secure queue command
 
 This command is sent by the recipient to the server to add sender's key to the queue:
 
 ```abnf
-secure = %s"KEY" SP senderKey
-senderKey = %s"rsa:" x509encoded ; the sender's RSA public key for this queue
+secure = %s"KEY " senderSignaturePublicKey
+senderSignaturePublicKey = length x509encoded
+; the sender's Ed25519 or Ed448 key to verify SEND commands for this queue
 ```
 
 `senderKey` is received from the sender as part of the first message - see [Send Message](#send-message) command.
 
 Once the queue is secured only signed messages can be sent to it.
 
+#### Enable notifications command
+
+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
+notifierKey = length x509encoded
+; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue
+```
+
+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
+notifierId = length *OCTET ; 16-24 bytes
+```
+
+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.
+
 #### 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:
@@ -461,10 +565,17 @@ 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" SP size SP msgBody SP
-; the last SP is in addition to SP in the transmission
-size = 1*DIGIT ; size in bytes
-msgBody = *OCTET ; any binary content of specified size
+send = %s"SEND " smpEncMessage
+smpEncMessage = smpPubHeader sentMsgBody ; message up to 16088 bytes
+smpPubHeader = smpClientVersion ("1" senderPublicDhKey / "0")
+smpClientVersion = word16
+senderPublicDhKey = length x509encoded
+; sender's Curve25519 public key to agree DH secret for E2E encryption in this queue
+; it is only sent in confirmation message
+x509encoded = <binary X509 key encoding>
+sentMsgBody = 16032*16032 OCTET
+; E2E-encrypted smpClientMessage padded to 16032 bytes before encryption
+word16 = 2*2 OCTET
 ```
 
 The first message is sent to confirm the queue - it should contain sender's server key (see decrypted message syntax below) - this first message must be sent without signature.
@@ -482,15 +593,107 @@ Until the queue is secured, the server should accept any number of unsigned mess
 The body should be encrypted with the recipient's "public" key (`EK`); once decrypted it must have this format:
 
 ```abnf
-decryptedBody = [clientHeader] CRLF clientBody CRLF
-clientHeader = senderKeyMsg
-senderKeyMsg = %s"KEY" SP senderKey
-senderKey = %s"rsa:" x509encoded ; the sender's RSA public key for this queue
-clientBody = *OCTET
+sentMsgBody = <encrypted padded(smpClientMessage, 16032)>
+smpClientMessage = smpPrivHeader clientMsgBody
+smpPrivHeader = emptyHeader / smpConfirmationHeader
+emptyHeader = " "
+smpConfirmationHeader = %s"K" senderKey
+senderKey = length x509encoded
+; the sender's Ed25519 or Ed448 public key to sign SEND commands for this queue
+clientMsgBody = *OCTET ; up to 16016 in case of emptyHeader
 ```
 
 `clientHeader` in the initial unsigned message is used to transmit sender's server key and can be used in the future revisions of SMP protocol for other purposes.
 
+SMP transmission structure for sent messages:
+
+```
+------- transmission (= 16384 bytes)
+    2 | originalLength
+ 276- | signature sessionId corrId queueId %s"SEND" SP (1+114 + 1+32? + 1+32 + 1+24 + 4+1 = 210)
+      ....... smpEncMessage (= 16088 bytes = 16384 - 296 bytes)
+         8- | smpPubHeader (for messages it is only version and '0' to mean "no DH key" = 3 bytes)
+         24 | nonce for smpClientMessage
+         16 | auth tag for smpClientMessage
+            ------- smpClientMessage (E2E encrypted, = 16032 bytes = 16088 - 48)
+                2 | originalLength
+               12- | smpPrivHeader
+                  .......
+                        | clientMsgBody (<= 16016 bytes = 16032 - 14)
+                  .......
+               0+ | smpClientMessage pad
+            ------- smpClientMessage end
+            |
+      ....... smpEncMessage end
+  18+ | transmission pad
+------- transmission end
+```
+
+SMP transmission structure for received messages:
+
+```
+------- transmission (= 16384 bytes)
+    2 | originalLength
+ 276- | signature sessionId corrId queueId %s"MSG" SP msgId timestamp (1+114 + 1+32? + 1+32 + 1+24 + 3+1 + 24+1 + 8 = 243)
+   16 | auth tag (msgId is used as nonce)
+      ------- serverEncryptedMsg (= 16090 bytes = 16384 - 294 bytes)
+          2 | originalLength
+            ....... smpEncMessage (= 16088 bytes = 16090 - 2 bytes)
+               16- | smpPubHeader (empty header for the message)
+               24 | nonce for smpClientMessage
+               16 | auth tag for smpClientMessage
+                  ------- smpClientMessage (E2E encrypted, = 16032 bytes = 16088 - 56 bytes)
+                      2 | originalLength
+                     16- | smpPrivHeader (empty header for the message)
+                        ....... clientMsgBody (<= 16016 bytes = 16032 - 16)
+                              -- TODO move internal structure (below) to agent protocol
+                          20- | agentPublicHeader (the size is for user messages post handshake, without E2E X3DH keys - it is version and 'M' for the messages - 3 bytes in total)
+                              ....... E2E double-ratchet encrypted (<= 15996 bytes = 16016 - 20)
+                                  1 | encoded double ratchet header length (it is 123 now)
+                                123 | encoded double ratchet header, including:
+                                         2 | version
+                                        16 | double-ratchet header iv
+                                        16 | double-ratchet header auth tag
+                                      1+88 | double-ratchet header (actual size is 69 bytes, the rest is reserved)
+                                 16 | message auth tag (IV generated from chain ratchet)
+                                    ------- encrypted agent message (= 15856 bytes = 15996 - 140)
+                                        2 | originalLength
+                                      64- | agentHeader (the actual size is 41 = 8 + 1+32)
+                                        2 | %s"MM"
+                                          .......
+                                                | application message (<= 15788 bytes = 15856 - 68)
+                                          .......
+                                       0+ | encrypted agent message pad
+                                    ------- encrypted agent message end
+                                    |
+                              ....... E2E double-ratchet encrypted end
+                              |
+                              -- TODO move internal structure (above) to agent protocol
+                        ....... clientMsgBody end
+                     0+ | smpClientMessage pad
+                  ------- smpClientMessage end
+                  |
+            ....... smpEncMessage end
+         0+ | serverEncryptedMsg pad
+      ------- serverEncryptedMsg end
+   0+ | transmission pad
+------- transmission end
+```
+
+### Notifier commands
+
+#### Subscribe to queue notifications
+
+The push notifications server (notifier) must use this command to start receiving message notifications from the queue:
+
+```abnf
+subscribeNotifications = %s"NSUB"
+```
+
+If subscription is successful the server must respond with `ok` response if no messages are available. The notifier will be receiving the message notifications from this queue until the transport connection is closed or until another transport connection subscribes to notifications from the same simplex queue - in this case the first subscription should be cancelled and [subscription END notification](#subscription-end-notification) delivered.
+
+The first message notification will be delivered either immediately or as soon as the message is available.
+
 ### Server messages
 
 #### Queue IDs response
@@ -504,16 +707,38 @@ 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" SP msgId SP timestamp SP size SP msgBody SP
-msgId = encoded
-timestamp = <date-time defined in RFC3339>
+message = %s"MSG " msgId SP timestamp SP encryptedMsgBody
+encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
+paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 16088
+msgId = length 24*24OCTET
+timestamp = 8*8OCTET
 ```
 
-`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement).
+`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement). Message ID is used as a nonce for server/recipient encryption of message bodies.
 
-`timestamp` - the UTC time when the server received the message from the sender, must be in date-time format defined by [RFC 3339][10]
+`timestamp` - system time when the server received the message from the sender as **a number of seconds** since Unix epoch (1970-01-01) encoded as 64-bit integer in network byte order. If a client system/language does not support 64-bit integers, until 2106 it is safe to simply skip the first 4 zero bytes and decode 32-bit unsigned integer (or as signed integer until 2038).
 
-`binaryMsg` - see syntax in [Send message](#send-message)
+`paddedSentMsgBody` - see syntax in [Send message](#send-message)
+
+When server delivers the messages to the recipient, message body should be encrypted with the secret derived from DH exchange using the keys passed during the queue creation and returned with `queueIds` response.
+
+This is done to prevent the possibility of correlation of incoming and outgoing traffic of SMP server inside transport protocol.
+
+#### Notifier queue ID response
+
+Server must respond with this message when queue notifications are enabled.
+
+See its syntax in [Enable notifications command](#enable-notifications-command)
+
+#### Deliver message notification
+
+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"
+```
+
+Message notification does not contain any message data or meta-data, it only notifies that the message is available.
 
 #### Subscription END notification
 
@@ -528,24 +753,24 @@ No further messages should be delivered to unsubscribed transport connection.
 #### Error responses
 
 - incorrect block format, encoding or signature size (`BLOCK`).
+- missing or different session ID - tls-unique binding of TLS transport (`SESSION`)
 - command errors (`CMD`):
   - error parsing command (`SYNTAX`)
   - prohibited command (`PROHIBITED`) - any server response sent from client or `ACK` sent without active subscription or without message delivery.
-  - incorrect RSA key size in `NEW` or `KEY` commands - only 1024, 2048 and 4096-bit keys are allowed (`KEY_SIZE`).
   - transmission has no required signature or queue ID (`NO_AUTH`)
   - transmission has unexpected credentials (`HAS_AUTH`)
   - transmission has no required queue ID (`NO_QUEUE`)
 - authentication error (`AUTH`) - incorrect signature, unknown (or suspended) queue, sender's ID is used in place of recipient's and vice versa, and some other cases (see [Send message](#send-message) command).
 - message queue quota exceeded error (`QUOTA`) - too many messages were sent to the message queue. Further messages can only be sent after the recipient retrieves the messages.
-- incorrect message body size (`SIZE`).
+- sent message is too large (> 16088) to be delivered (`LARGE_MSG`).
 - internal server error (`INTERNAL`).
 
 The syntax for error responses:
 
 ```abnf
-error = %s"ERR" SP errorType
-errorType = %s"BLOCK" / %s"CMD" SP cmdError / %s"AUTH" / %s"SIZE" /%s"INTERNAL"
-cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"KEY_SIZE" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
+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"
 ```
 
 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).
@@ -566,52 +791,52 @@ 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.
 
-By default, the client and server should use the protocol presented below, that does not depend on a centralized certificate authority.
+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).
 
-Transport is encrypted with [AEAD-GCM][12] protocol with two random symmetric AES 256-bit keys and two random base IVs that will be agreed during the handshake. Both client and the server should maintain two 32-bit word counters, one for the sent and one for the received messages. The IV for each message should be computed by xor-ing the sequential message counter, starting from 0, with the first 32 bits of agreed base IV (the number is encoded in network byte order).
+In addition to that, the servers can be deployed as Tor onion services.
 
-To establish the session keys and base IVs, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) in advance in order to be able to validate the server public key during transport connection handshake.
+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.
 
-The handshake sequence is the following:
+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.
+- servers must send the chain of exactly 2 self-signed certificates in the handshake, with the first (offline) certificate one signing the second (online) certificate. Offline certificate fingerprint is used as a server identity - it is a part of SMP server address.
+- The clients must abort the connection in case a different number of certificates is sent.
+- server and client TLS configuration should not allow resuming the sessions.
 
-1. Once the connection is established, the server sends the `server_header` followed by its public RSA key encoded in X509 binary (not base-64 encoded) format to the client.
-2. The client compares the SHA256 hash of the received key with the hash it already has (e.g. received as part of connection invitation or as SMP server configuration). If the hash does not match, the client must terminate the connection.
-3. If the hash is the same, the client should generate two random symmetric 256-bit AES keys and two base IVs that will be used as session keys/IVs by the client and the server.
-4. The client then should create the `client_handshake` block and send it to the server, encrypted using [RSA-OAEP][2] scheme with the server public key: `rsa-encrypt(client_handshake)`. `snd_aes_key` and `snd_base_iv` will be used by the client to encrypt **sent** messages and by the server to decrypt them, `rcv_aes_key` and `rcv_base_iv` will be used by the client to decrypt **received** messages and by the server to encrypt them. `client_handshake` also contains `block_size` and reserved `protocol` blocks (see syntax).
-5. The server should decrypt the received AES keys and base IVs with its private RSA key.
-6. In case of successful decryption, the server should send encrypted welcome block (`encrypted_welcome_block`) that contains SMP protocol version supported by the server.
+During TLS handshake the client must validate that the fingerprint of the online server certificate is equal to the `serverIdentity` the client received as part of SMP server address; if the server identity does not match the client must abort the connection.
 
-All the subsequent data, both from the client and from the server, should be sent padded to the fixed agreed block size, encrypted with symmetric AES keys and base IVs (incremented by counters on both sides), that were sent by the client during the handshake. If the application needs to transmit a larger message, it should be broken down into fragments.
+Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes).
 
-Handshake blocks sent by the client and the server have this syntax:
+The first block sent by the server should be `serverHello` and the client should respond with `clientHello` - these blocks are used to agree SMP protocol version:
 
 ```abnf
-server_header = block_size protocol key_size
-block_size = 4*4(OCTET) ; 4-byte block size sent by the server
-protocol = 2*2(%x00) ; 0, reserved
-key_size = 2*2(OCTET) ; the size of the encoded key in bytes (binary encoded in X509 standard)
+serverHello = minSmpVersion maxSmpVersion sessionIdentifier pad
+minSmpVersion = smpVersion
+maxSmpVersion = smpVersion
+sessionIdentifier = length *OCTET
+; unique session identifier derived from transport connection handshake
+; it should be included in all SMP transmissions sent in this transport connection.
 
-client_handshake = client_block_size protocol snd_aes_key snd_base_iv rcv_aes_key rcv_base_iv
-client_block_size = 4*4(OCTET) ; 4-byte block size sent by the client,
-; to confirm or override the block size sent by the server
-client_protocol = 2*2(%x00) ; 0, reserved
-snd_aes_key = 32*32(OCTET)
-snd_base_iv = 16*16(OCTET)
-rcv_aes_key = 32*32(OCTET)
-rcv_base_iv = 16*16(OCTET)
+clientHello = smpVersion pad
+; chosen SMP protocol version - it must be the maximum supported version
+; within the range offered by the server
 
-transport_block = aes_body_auth_tag aes_encrypted_body
-; size is sent by server during handshake, usually 4096 bytes
-aes_body_auth_tag = 16*16(OCTET)
-aes_encrypted_body = 1*OCTET
+smpVersion = 2*2OCTET ; Word16 version number
 
-encrypted_welcome_block = transport_block
-welcome_block = smp_version SP pad ; decrypt(encrypted_welcome_block)
-smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format
-  ; for example: v123.456.789-alpha.7
-pad = 1*OCTET
+pad = *OCTET
 ```
 
+For TLS transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol (possibly, with another channel binding).
+
 [1]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack
 [2]: https://en.wikipedia.org/wiki/End-to-end_encryption
 [3]: https://en.wikipedia.org/wiki/QR_code
@@ -624,3 +849,7 @@ pad = 1*OCTET
 [10]: https://tools.ietf.org/html/rfc3339
 [11]: https://tools.ietf.org/html/rfc5280
 [12]: https://tools.ietf.org/html/rfc7714
+[13]: https://datatracker.ietf.org/doc/html/rfc8446
+[14]: https://datatracker.ietf.org/doc/html/rfc5929#section-3
+[15]: https://www.rfc-editor.org/rfc/rfc8709.html
+[16]: https://nacl.cr.yp.to/box.html

protocol/simplex-uri-request.txt

@@ -0,0 +1,18 @@
+Scheme name: simplex
+
+Status: Provisional
+
+Applications/protocols that use this scheme name:
+This scheme is used for connection requests in SimpleX Agent Protocol,
+a middle layer protocol for managing bi-directional communication via
+redundant unidirectional SimpleX Messaging Protocol queues.
+
+Contact: Evgeny Poberezkin <ep@simplex.chat>
+
+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
+SimpleX Messaging Protocol:
+https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md

protocol/smp-uri-request.txt

@@ -0,0 +1,16 @@
+Scheme name: smp
+
+Status: Provisional
+
+Applications/protocols that use this scheme name:
+This scheme is used for URIs of message queues in SimpleX Messaging Protocol,
+a client-server protocol for asynchronous distributed unidirectional
+message transmission via persistent message queues.
+
+Contact: Evgeny Poberezkin <ep@simplex.chat>
+
+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

rfcs/2021-02-28-streams.md

@@ -26,20 +26,20 @@ Such connections that can be unidirectional or duplex can be managed by agents v
 
 The protocol to create and manage such stream could be the following:
 
-1. The sender client notifies the agent about the stream it has to create for a specific duplex connection (the connection must be duplex for it to be possible): `<conn_alias> SNEW <size>` (where `conn_alias` is the existing duplex connection, `size` is the size for the data to be transferred; 0 for unbounded streams), the response is `<conn_alias> STREAM <stream_id> <size>`.
+1. The sender client notifies the agent about the stream it has to create for a specific duplex connection (the connection must be duplex for it to be possible): `<conn_id> SNEW <size>` (where `conn_id` is the existing duplex connection, `size` is the size for the data to be transferred; 0 for unbounded streams), the response is `<conn_id> STREAM <stream_id> <size>`.
 2. The sender agent sends to the recipient agent the "envelope" `STREAM <stream_id> <size>`
-3. The receiving agent would notify the client about availability of the stream by sending `<conn_alias> STREAM <stream_id> <size>` notification.
-4. Receiving client would send `<conn_alias> SJOIN <stream_id>` command to the receiving agent.
+3. The receiving agent would notify the client about availability of the stream by sending `<conn_id> STREAM <stream_id> <size>` notification.
+4. Receiving client would send `<conn_id> SJOIN <stream_id>` command to the receiving agent.
 5. Receiving agent provisions the SMP queue on the random SMP server (we planned to remove SMP server from NEW command anyway). Possibly, there will be a limited list of servers that support streams (that is un-throttled number of messages), and stream support can be communicated via welcome header and change with AUTH SMP command.
 6. Receiving agent sends the envelop to sending agent `SJOIN <stream_id> <invitation>` (where invitation has the same format as in out-of-band message, but it has symmetric AES key and IV instead of asymmetric RSA key - the encryption scheme should codified in the invitation to make it generic).
 7. Sending agent and receiving agent confirm and secure SMP queue as usual. This is still not solving the problem that the sending agent should sign each command. We might extend SMP protocol to create a new queue type that allows authenticating the sender only once per TCP session so that messages can be sent without signing - the server can see that these queues are special anyway, as there will be much faster traffic there.
-8. Sending agent, once the queue is confirmed notifies the sending client that the stream is ready to accept data by sending notification `<conn_alias> SREADY <stream_id> <max_chunk_size>`.
-9. Sending agent client can now send packets into the stream up to total `<size>` limit if it was specified by using command `<conn_alias> SPUT <stream_id> <chunk_no> <chunk_size> <binary> ` (the chunk size should not be bigger than `max_chunk_size`, the agent would pad it to this size before sending to the receiving agent)
+8. Sending agent, once the queue is confirmed notifies the sending client that the stream is ready to accept data by sending notification `<conn_id> SREADY <stream_id> <max_chunk_size>`.
+9. Sending agent client can now send packets into the stream up to total `<size>` limit if it was specified by using command `<conn_id> SPUT <stream_id> <chunk_no> <chunk_size> <binary> ` (the chunk size should not be bigger than `max_chunk_size`, the agent would pad it to this size before sending to the receiving agent)
 10. Sending agent would send the chunk to the receiving agent in `CHUNK <chunk_no> <ts> <chunk_size> <binary>` envelope, where the first 4 bytes in decrypted binary is chunk size.
-11. Receiving agent would send the chunk to the client as `<conn_alias> SDATA <stream_id> <chunk_no> <ts> <status> <chunk_size> <binary>` (possibly, with three IDs and timestamps as with messages).
-12. Both the receiving and sending clients can terminate the stream with `<conn_alias> SCLOSE <stream_id>` command. The agent would send `SCLOSED <stream_id>` envelope and the opposite client would receive `<conn_alias> SCLOSED <stream_id>` notification - no more data will be accepted into this stream.
+11. Receiving agent would send the chunk to the client as `<conn_id> SDATA <stream_id> <chunk_no> <ts> <status> <chunk_size> <binary>` (possibly, with three IDs and timestamps as with messages).
+12. Both the receiving and sending clients can terminate the stream with `<conn_id> SCLOSE <stream_id>` command. The agent would send `SCLOSED <stream_id>` envelope and the opposite client would receive `<conn_id> SCLOSED <stream_id>` notification - no more data will be accepted into this stream.
 13. If the stream was bounded with some `size` then both the sending and receiving client would receive `SCLOSED` notification after the last chunk of correct size was sent (and the incorrect chunk would be rejected).
-14. If the stream was interrupted then the recipient client can request resuming this stream using `<conn_alias> SRESUME <stream_id> <from_chunk_no>`, the recipient agent would send "envelope" `SRESUME <stream_id> <from_chunk_no> <invitation>`.
+14. If the stream was interrupted then the recipient client can request resuming this stream using `<conn_id> SRESUME <stream_id> <from_chunk_no>`, the recipient agent would send "envelope" `SRESUME <stream_id> <from_chunk_no> <invitation>`.
 
 To be clarified:
 1. Possibly the internal stream ID used by clients should be different from stream ID communicated between agents, and in any case it should be connection scoped (same as with messages).

rfcs/2021-05-17-open-connection.md

@@ -0,0 +1,52 @@
+# Open connections
+
+## Problem
+
+This proposal describes how to create invitations that can be used multiple times. 
+
+It can be used for:
+- an open invitation to join a group.
+- an open invitation to connect to a person - e.g. QR code/invitation link on a person's website, or passed from one person to another.
+- part of the solution for public DNS-based addresses (when a directory server would map address in some domain name#example.tld to an open invitation).
+
+## Solution
+
+No changes to SMP protocol - a dedicated unsecured SMP queue is used to receive invitations to connect that are sent in encrypted agent message. An unsecured SMP queue is used as an out-of-band channel for establishing another SMP queue.
+
+Additional parameters in commands in SMP agent protocol:
+
+- `NEW` command will have a parameter `INV` or `CON` to create an invitation or a permanent contact connection.
+
+`conn_id? OPEN` (or `PUB`, `NEWPUB`, tbc) - to create an "open"/"public" queue, the response is an invitation in a different format (TBC):
+  - should allow multiple servers (probably the original invitation should be extended to support it)
+  - should have a marker to indicate it's an open/public queue (probably the original invitation should be extended to include an invitation type).
+
+e.g. `smp:<queue_type>::<server1>/<queue_id1>,<server2>/<queue_id2>::<key1>`
+
+`queue_type`:
+  - `prv` - original invitation, should be accepted with KEY SMP message
+  - `pub` - open invitation, should be accepted with INV SMP message (to be added to SMP protocol)
+
+```mmd
+A ->> AA: oidA? OPEN
+AA ->> A: oidA INV pub_inv
+
+...
+
+B ->> BA: cidBA? JOIN pub_inv len CRLF meta_binary CRLF ; change command to require meta, len can be 0 for the current usage ; meta is used to send user profile
+BA ->> B: cidBA OK
+BA ->> SA ->> AA: INV prv_inv CRLF meta_binary
+AA ->> A: oidA CONF invID len meta_binary
+A ->> AA cidAB? LET invID
+
+establish connection as usual
+
+BA ->> B: cidBA CON
+AA ->> A: cidAB CON
+```
+
+That protocol requires addressing the current problem when an invitation cannot be accepted when the party that generated the invitation is not online.
+
+Questions.
+
+1. Do we need to differentiate the semantics of the invitation on the syntax level, or should we allow to just manage it outside of protocol when the receiving agent decides which SMP messages to accept and which to ignore (KEY / INV).

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

@@ -0,0 +1,91 @@
+# 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/2022-04-20-smp-conf-timeout-recovery.md

@@ -0,0 +1,21 @@
+# 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/done/2021-01-20-logging.md

@@ -31,7 +31,7 @@ Agent disconnected from host:port
 ### Received command from the client
 
 ```
-n --> A : corrId connAlias parsed_command // raw_command
+n --> A : corrId connId parsed_command // raw_command
 ```
 
 `raw_command` is added only in case of parsing failure.
@@ -53,13 +53,13 @@ In case the response is a message or notification, corrId should be replaced wit
 ### Interpreted ("unwrapped") SMP message as agent message
 
 ```
-Agent msg : connAlias parsed_message // raw_message 
+Agent msg : connId parsed_message // raw_message 
 ```
 
 ### Sent response / message to the client
 
 ```
-n <-- A : corrId connAlias parsed_command // raw_command
+n <-- A : corrId connId parsed_command // raw_command
 ```
 
 ### Database changes

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

@@ -0,0 +1,23 @@
+# SMP server image for DigitalOcean
+
+## How to build an image
+
+1. [Create an API token](https://cloud.digitalocean.com/account/api/tokens) in vendor account in DigitalOcean.
+2. Install [packer](https://www.packer.io/downloads) downloading binary or with brew (on Mac):
+
+```shell
+brew tap hashicorp/tap
+brew install hashicorp/tap/packer
+```
+
+3. Run `packer build` in the `smp-server-digitalocean-droplet` repository:
+
+```shell
+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-digitalocean-droplet/files/opt/simplex/initialize_server.sh

@@ -0,0 +1,51 @@
+#!/bin/bash
+
+# Download latest release
+bin_dir="/opt/simplex/bin"
+binary="$bin_dir/smp-server"
+mkdir -p $bin_dir
+curl -L -o $binary https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-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
+smp-server --version
+
+# Initialize server
+ip_address=$(curl ifconfig.me)
+smp-server init -l --ip $ip_address
+
+# Server fingerprint
+fingerprint=$(cat /etc/opt/simplex/fingerprint)
+
+# Set up welcome script
+echo "bash /opt/simplex/on_login.sh $fingerprint $ip_address" >> /root/.bashrc
+
+# / Create systemd service for SMP server
+cat > /etc/systemd/system/smp-server.service << EOF
+[Unit]
+Description=SMP server
+
+[Service]
+Type=simple
+ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
+
+[Install]
+WantedBy=multi-user.target
+
+EOF
+# Create systemd service for SMP server /
+
+# Start systemd service for SMP server
+chmod 644 /etc/systemd/system/smp-server.service
+sudo systemctl enable smp-server
+sudo systemctl start smp-server

scripts/smp-server-digitalocean-droplet/files/opt/simplex/on_login.sh

@@ -1,17 +1,16 @@
 #!/bin/bash
-# receives pubkey_hash file location as the first parameter
 
-ip_address=$(hostname -I | awk '{print$1}')
-hash=$(cat $1)
+fingerprint=$1
+server_address=$2
 
 cat <<EOF
 ********************************************************************************
 
-SMP server address: $ip_address#$hash
+SMP server address: smp://$fingerprint@$server_address
 Check SMP server status with: systemctl status smp-server
 
 To keep this server secure, the UFW firewall is enabled.
-All ports are BLOCKED except 22 (SSH), 80 (HTTP), 5223 (SMP server).
+All ports are BLOCKED except 22 (SSH), 443 (HTTPS), 5223 (SMP server).
 
 ********************************************************************************
 To stop seeing this message delete line - bash /opt/simplex/on_login.sh - from /root/.bashrc

scripts/smp-server-digitalocean-droplet/files/opt/simplex/server_bootstrap.sh

@@ -0,0 +1,12 @@
+#!/bin/bash
+
+set -eu
+
+if [[ ! -f /opt/simplex/do_initialize_server ]]; then
+  touch /opt/simplex/do_initialize_server
+elif [[ ! -f /etc/opt/simplex/smp-server.ini ]]; then
+  chmod +x /opt/simplex/initialize_server.sh
+  /opt/simplex/initialize_server.sh
+else
+  echo "SMP server already initialized"
+fi

scripts/smp-server-digitalocean-droplet/marketplace-image.json

@@ -2,8 +2,7 @@
   "variables": {
     "token": "{{env `DIGITALOCEAN_TOKEN`}}",
     "image_name": "smp-server-snapshot",
-    "application_name": "SMP server",
-    "release_tag": "v0.4.0"
+    "application_name": "SMP server"
   },
   "sensitive-variables": ["token"],
   "builders": [
@@ -34,7 +33,7 @@
       "type": "shell",
       "environment_vars": [
         "application_name={{user `application_name`}}",
-        "release_tag={{user `release_tag`}}"
+        "DEBIAN_FRONTEND=noninteractive"
       ],
       "scripts": [
         "scripts/01-packages.sh",

scripts/smp-server-digitalocean-droplet/scripts/01-packages.sh

@@ -1,8 +1,25 @@
 #!/bin/sh
 
-# update apt
-apt-get -y update
-apt-get -y upgrade
+# 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
 
-# packages needed for smp-server init-start.sh
-apt-get install -y jq
+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; jq is not needed on DigitalOcean
+# 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

scripts/smp-server-digitalocean-droplet/scripts/02-firewall.sh

@@ -1,9 +1,9 @@
 #!/bin/sh
 
-# add firewall
+# Add firewall
 echo "y" | ufw enable
 
-# open ports
+# Open ports
 ufw allow ssh
-ufw allow http
+ufw allow https
 ufw allow 5223

scripts/smp-server-digitalocean-droplet/scripts/03-init-start.sh

@@ -1,53 +1,23 @@
 #!/bin/bash
 
-bin_dir="/opt/simplex/bin"
-conf_dir="/etc/opt/simplex"
-var_dir="/var/opt/simplex"
-mkdir -p $bin_dir
-mkdir -p $conf_dir
-mkdir -p $var_dir
+chmod +x /opt/simplex/server_bootstrap.sh
 
-echo "downloading SMP server release $release_tag"
-curl -s https://api.github.com/repos/simplex-chat/simplexmq/releases/tags/{$release_tag} \
-| jq -r '.assets[].browser_download_url | select(test("smp-server-ubuntu-20_04-x86-64"))' \
-| tr -d \" \
-| wget -qi -
-
-echo "preparing for SMP server initiaization"
-mv smp-server-ubuntu-20_04-x86-64 $bin_dir/smp-server
-chmod +x $bin_dir/smp-server
-
-cat <<EOT >> /etc/profile.d/simplex.sh
-#!/bin/bash
-
-export PATH="$PATH:$bin_dir"
-
-EOT
-source /etc/profile.d/simplex.sh
-
-# prepare SMP server systemd service
-cat <<EOT >> /etc/systemd/system/smp-server.service
+# / Create systemd service for server bootstrap script
+cat > /etc/systemd/system/server-bootstrap.service << EOF
 [Unit]
-Description=SMP server systemd service
+Description=Server bootstrap script that downloads and initializes SMP server from the latest release
 
 [Service]
-Type=simple
-ExecStart=/bin/sh -c "$bin_dir/smp-server start"
+Type=oneshot
+ExecStart=/opt/simplex/server_bootstrap.sh
 
 [Install]
 WantedBy=multi-user.target
 
-EOT
-chmod 644 /etc/systemd/system/smp-server.service
+EOF
+# Create systemd service for server bootstrap script /
 
-echo "initializing SMP server"
-hash_file="$conf_dir/pubkey_hash"
-smp-server init -l | grep "transport key hash:" | cut -f2 -d":" | xargs > $hash_file
-# turn off websockets support
-sed -e '/websockets/s/^/# /g' -i $conf_dir/smp-server.ini
-# add welcome script to .bashrc
-echo "bash /opt/simplex/on_login.sh $hash_file" >> /root/.bashrc
-
-echo "starting SMP server"
-sudo systemctl enable smp-server
-sudo systemctl start smp-server
+# Start systemd service for server bootstrap script
+chmod 644 /etc/systemd/system/server-bootstrap.service
+sudo systemctl enable server-bootstrap
+sudo systemctl start server-bootstrap

scripts/smp-server-linode.sh

@@ -1,125 +1,178 @@
 #!/bin/bash
-# <UDF name="enable_store_log" label="Store log - persists SMP queues to append only log and restores them upon server restart." default="on" oneof="on, off" />
-# <UDF name="api_token" label="Linode API token - enables StackScript to create tags containing SMP server domain/ip address, transport key hash and server version. Use `domain#hash` or `ip#hash` as SMP server address in the client. Note: minimal permissions token should have are - read/write access to `linodes` (to update linode tags - you need them) and `domains` (to add A record for the chosen 3rd level domain)" default="" />
-# <UDF name="fqdn" label="FQDN (Fully qualified domain name) - provide third level domain name (ex: smp.example.com). If provided can be used instead of ip address." default="" />
 
-# log all stdout output to stackscript.log
+# <UDF name="enable_store_log" label="Store log - persist SMP queues 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. smp.example.com). If provided use `smp://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `smp://fingerprint@IP` instead." default="" />
+
+# Log all stdout output to stackscript.log
 exec &> >(tee -i /var/log/stackscript.log)
-# uncomment next line to enable debugging features
+
+# Uncomment next line to enable debugging features
 # set -xeo pipefail
 
 cd $HOME
 
-sudo apt-get -y update 
-sudo apt-get -y upgrade
-sudo apt-get install -y jq
+# 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
 
-# add firewall
+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
+
+# Open ports
 ufw allow ssh
-ufw allow http
+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"
-conf_dir="/etc/opt/simplex"
-var_dir="/var/opt/simplex"
+binary="$bin_dir/smp-server"
 mkdir -p $bin_dir
-mkdir -p $conf_dir
-mkdir -p $var_dir
+curl -L -o $binary https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64
+chmod +x $binary
 
-# retrieve latest release info and download smp-server executable
-curl -s https://api.github.com/repos/simplex-chat/simplexmq/releases/latest > release.json
-jq '.assets[].browser_download_url | select(test("smp-server-ubuntu-20_04-x86-64"))' release.json \
-| tr -d \" \
-| wget -qi -
-
-mv smp-server-ubuntu-20_04-x86-64 $bin_dir/smp-server
-chmod +x $bin_dir/smp-server
-
-cat <<EOT >> /etc/profile.d/simplex.sh
+# / Add to PATH
+cat > /etc/profile.d/simplex.sh << EOF
 #!/bin/bash
 
 export PATH="$PATH:$bin_dir"
 
-EOT
+EOF
+# Add to PATH /
+
+# Source and test PATH
 source /etc/profile.d/simplex.sh
+smp-server --version
 
-# initialize SMP server
+# Initialize server
 init_opts=()
+
 [[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
-hash_file="$conf_dir/pubkey_hash"
-smp-server init "${init_opts[@]}" | grep "transport key hash:" | cut -f2 -d":" | xargs > $hash_file
-# turn off websockets support
-sed -e '/websockets/s/^/# /g' -i $conf_dir/smp-server.ini
-# create script that will run on login
+
+ip_address=$(curl ifconfig.me)
+init_opts+=(--ip $ip_address)
+
+[[ -n "$FQDN" ]] && init_opts+=(-n $FQDN)
+
+smp-server init "${init_opts[@]}"
+
+# Server fingerprint
+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
+  server_address=$ip_address
+fi
+
+# Set up welcome script
 on_login_script="/opt/simplex/on_login.sh"
-cat <<EOT >> $on_login_script
+
+# / Welcome script
+cat > $on_login_script << EOF
 #!/bin/bash
-# receives pubkey_hash file location as the first parameter
 
-ip_address=\$(hostname -I | awk '{print\$1}')
-hash=\$(cat \$1)
+fingerprint=\$1
+server_address=\$2
 
-cat <<EOF
+cat << EOF2
 ********************************************************************************
 
-SMP server address: \$ip_address#\$hash
+SMP server address: smp://\$fingerprint@\$server_address
 Check SMP server status with: systemctl status smp-server
 
 To keep this server secure, the UFW firewall is enabled.
-All ports are BLOCKED except 22 (SSH), 80 (HTTP), 5223 (SMP server).
+All ports are BLOCKED except 22 (SSH), 443 (HTTPS), 5223 (SMP server).
 
 ********************************************************************************
 To stop seeing this message delete line - bash /opt/simplex/on_login.sh - from /root/.bashrc
+EOF2
+
 EOF
+# Welcome script /
 
-EOT
 chmod +x $on_login_script
-echo "bash $on_login_script $hash_file" >> /root/.bashrc
+echo "bash $on_login_script $fingerprint $server_address" >> /root/.bashrc
 
-# create A record and update linode's tags
-if [ ! -z "$API_TOKEN" ]; then
-     ip_address=$(curl ifconfig.me)
-     address=$ip_address
-     if [ ! -z "$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 [[ ! -z $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
-               address=$FQDN
-          fi
-     fi
+# 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
 
-     hash=$(cat $hash_file)
-     release_version=$(jq '.tag_name' release.json | tr -d \")
+  version=$(smp-server --version | cut -d ' ' -f 3-)
 
-     curl -s -H "Content-Type: application/json" \
-          -H "Authorization: Bearer $API_TOKEN" \
-          -X PUT -d "{\"tags\":[\"$address\",\"#$hash\",\"$release_version\"]}" \
-          https://api.linode.com/v4/linode/instances/$LINODE_ID
+  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, enable and start SMP server systemd service
-cat <<EOT >> /etc/systemd/system/smp-server.service
+# / Create systemd service
+cat > /etc/systemd/system/smp-server.service << EOF
 [Unit]
-Description=SMP server systemd service
+Description=SMP server
 
 [Service]
 Type=simple
-ExecStart=/bin/sh -c "$bin_dir/smp-server start"
+ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
+KillSignal=SIGINT
+Restart=always
+RestartSec=10
+LimitNOFILE=1000000
+LimitNOFILESoft=1000000
 
 [Install]
 WantedBy=multi-user.target
 
-EOT
+EOF
+# Create systemd service /
+
+# Start systemd service
 chmod 644 /etc/systemd/system/smp-server.service
 sudo systemctl enable smp-server
 sudo systemctl start smp-server
 
-# cleanup
-rm release.json
+# Reboot Linode to apply upgrades
+sudo reboot

scripts/update-smp-server.sh

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

@@ -3,11 +3,9 @@ cabal-version: 1.12
 -- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: e25d53dc1b12c8bcdf029091182613198be5271348ea19174b6532d820fe1fc9
 
 name:           simplexmq
-version:        0.4.0
+version:        2.3.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -21,7 +19,7 @@ category:       Chat, Network, Web, System, Cryptography
 homepage:       https://github.com/simplex-chat/simplexmq#readme
 author:         simplex.chat
 maintainer:     chat@simplex.chat
-copyright:      2020 simplex.chat
+copyright:      2020-2022 simplex.chat
 license:        AGPL-3
 license-file:   LICENSE
 build-type:     Simple
@@ -29,30 +27,62 @@ 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.SQLite
       Simplex.Messaging.Agent.Protocol
+      Simplex.Messaging.Agent.QueryString
       Simplex.Messaging.Agent.RetryInterval
+      Simplex.Messaging.Agent.Server
       Simplex.Messaging.Agent.Store
       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.M20220404_ntf_subscriptions_draft
       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.Push.APNS
+      Simplex.Messaging.Notifications.Server.Store
+      Simplex.Messaging.Notifications.Transport
       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.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
       Simplex.Messaging.Server.QueueStore.STM
       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
+      Simplex.Messaging.Version
   other-modules:
       Paths_simplexmq
   hs-source-dirs:
@@ -60,28 +90,36 @@ library
   ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
   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.13.*
+    , attoparsec ==0.14.*
     , 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-sqlite ==2.3.*
     , directory ==1.3.*
-    , file-embed ==0.0.14.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
+    , http-types ==0.12.*
+    , http2 ==3.0.*
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , sqlite-simple ==0.4.*
@@ -89,11 +127,79 @@ library
     , 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 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.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-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.*
+    , iso8601-time ==0.1.*
+    , memory ==0.15.*
+    , mtl ==2.2.*
+    , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
+    , simplexmq
+    , 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
+    , 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
@@ -105,28 +211,36 @@ executable smp-agent
   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.13.*
+    , attoparsec ==0.14.*
     , 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-sqlite ==2.3.*
     , directory ==1.3.*
-    , file-embed ==0.0.14.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
+    , http-types ==0.12.*
+    , http2 ==3.0.*
+    , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
@@ -135,11 +249,18 @@ executable smp-agent
     , 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-server
@@ -151,31 +272,36 @@ executable smp-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.13.*
+    , attoparsec ==0.14.*
     , 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-sqlite ==2.3.*
     , directory ==1.3.*
-    , file-embed ==0.0.14.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
+    , http-types ==0.12.*
+    , http2 ==3.0.*
     , ini ==0.4.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
     , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
@@ -184,11 +310,18 @@ executable smp-server
     , 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
 
 test-suite smp-server-test
@@ -196,9 +329,17 @@ test-suite smp-server-test
   main-is: Test.hs
   other-modules:
       AgentTests
+      AgentTests.ConnectionRequestTests
+      AgentTests.DoubleRatchetTests
       AgentTests.FunctionalAPITests
+      AgentTests.NotificationTests
+      AgentTests.SchemaDump
       AgentTests.SQLiteTests
-      ProtocolErrorTests
+      CoreTests.EncodingTests
+      CoreTests.ProtocolErrorTests
+      CoreTests.VersionRangeTests
+      NtfClient
+      NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
@@ -209,30 +350,38 @@ test-suite smp-server-test
   build-depends:
       HUnit ==1.6.*
     , 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.13.*
+    , attoparsec ==0.14.*
     , 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-sqlite ==2.3.*
     , directory ==1.3.*
-    , file-embed ==0.0.14.*
     , 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.*
     , iso8601-time ==0.1.*
     , memory ==0.15.*
     , mtl ==2.2.*
-    , network ==3.1.*
+    , network >=3.1.2.7 && <3.2
     , network-transport ==0.5.*
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
@@ -241,10 +390,17 @@ test-suite smp-server-test
     , 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
     , 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

src/Simplex/Messaging/Agent/Client.hs

@@ -1,11 +1,15 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
@@ -17,173 +21,319 @@ module Simplex.Messaging.Agent.Client
     subscribeQueue,
     addSubscription,
     sendConfirmation,
+    sendInvitation,
     RetryInterval (..),
-    sendHello,
     secureQueue,
     sendAgentMessage,
-    decryptAndVerify,
-    verifyMessage,
+    agentNtfRegisterToken,
+    agentNtfVerifyToken,
+    agentNtfCheckToken,
+    agentNtfDeleteToken,
+    agentNtfEnableCron,
+    agentCbEncrypt,
+    agentCbDecrypt,
+    cryptoError,
     sendAck,
     suspendQueue,
     deleteQueue,
     logServer,
     removeSubscription,
-    cryptoError,
-    addActivation,
-    getActivation,
-    removeActivation,
+    hasActiveSubscription,
+    agentDbPath,
   )
 where
 
-import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Control.Monad.Trans.Except
+import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isNothing)
-import Data.Set (Set)
-import qualified Data.Set as S
+import Data.Maybe (catMaybes)
 import Data.Text.Encoding
-import Data.Time.Clock
+import Data.Word (Word16)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..))
 import Simplex.Messaging.Client
+import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)
-import Simplex.Messaging.Util (bshow, liftEitherError, liftError)
-import UnliftIO.Exception (IOException)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Client
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, ProtocolServer (..), QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
+import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (bshow, catchAll_, ifM, liftEitherError, liftError, tryError, unlessM, whenM)
+import Simplex.Messaging.Version
+import System.Timeout (timeout)
+import UnliftIO (async, pooledForConcurrentlyN)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
+type ClientVar msg = TMVar (Either AgentErrorType (ProtocolClient msg))
+
+type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
+
+type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
+
 data AgentClient = AgentClient
-  { rcvQ :: TBQueue (ATransmission 'Client),
+  { active :: TVar Bool,
+    rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
-    msgQ :: TBQueue SMPServerTransmission,
-    smpClients :: TVar (Map SMPServer SMPClient),
-    subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
-    subscrConns :: TVar (Map ConnId SMPServer),
-    activations :: TVar (Map ConnId (Async ())), -- activations of send queues in progress
-    connMsgQueues :: TVar (Map ConnId (TQueue PendingMsg)),
-    connMsgDeliveries :: TVar (Map ConnId (Async ())),
-    srvMsgQueues :: TVar (Map SMPServer (TQueue PendingMsg)),
-    srvMsgDeliveries :: TVar (Map SMPServer (Async ())),
+    msgQ :: TBQueue (ServerTransmission BrokerMsg),
+    smpServers :: TVar (NonEmpty SMPServer),
+    ntfServers :: TVar [NtfServer],
+    smpClients :: TMap SMPServer SMPClientVar,
+    ntfClients :: TMap NtfServer NtfClientVar,
+    subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
+    pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
+    subscrConns :: TMap ConnId SMPServer,
+    connMsgsQueued :: TMap ConnId Bool,
+    smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
+    smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
     reconnections :: TVar [Async ()],
+    asyncClients :: TVar [Async ()],
     clientId :: Int,
     agentEnv :: Env,
     smpSubscriber :: Async (),
     lock :: TMVar ()
   }
 
-newAgentClient :: Env -> STM AgentClient
-newAgentClient agentEnv = do
+newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
+newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   let qSize = tbqSize $ config agentEnv
+  active <- newTVar True
   rcvQ <- newTBQueue qSize
   subQ <- newTBQueue qSize
   msgQ <- newTBQueue qSize
-  smpClients <- newTVar M.empty
-  subscrSrvrs <- newTVar M.empty
-  subscrConns <- newTVar M.empty
-  activations <- newTVar M.empty
-  connMsgQueues <- newTVar M.empty
-  connMsgDeliveries <- newTVar M.empty
-  srvMsgQueues <- newTVar M.empty
-  srvMsgDeliveries <- newTVar M.empty
+  smpServers <- newTVar smp
+  ntfServers <- newTVar ntf
+  smpClients <- TM.empty
+  ntfClients <- TM.empty
+  subscrSrvrs <- TM.empty
+  pendingSubscrSrvrs <- TM.empty
+  subscrConns <- TM.empty
+  connMsgsQueued <- TM.empty
+  smpQueueMsgQueues <- TM.empty
+  smpQueueMsgDeliveries <- TM.empty
   reconnections <- newTVar []
+  asyncClients <- newTVar []
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
   lock <- newTMVar ()
-  return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, activations, connMsgQueues, connMsgDeliveries, srvMsgQueues, srvMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, ntfServers, smpClients, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
+
+agentDbPath :: AgentClient -> FilePath
+agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
 
 -- | Agent monad with MonadReader Env and MonadError AgentErrorType
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
-getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
-getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
-  readTVarIO smpClients
-    >>= maybe newSMPClient return . M.lookup srv
-  where
-    newSMPClient :: m SMPClient
-    newSMPClient = do
-      smp <- connectClient
-      logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-      atomically . modifyTVar smpClients $ M.insert srv smp
-      return smp
+class ProtocolServerClient msg where
+  getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
+  protocolError :: ErrorType -> AgentErrorType
 
+instance ProtocolServerClient BrokerMsg where
+  getProtocolServerClient = getSMPServerClient
+  protocolError = SMP
+
+instance ProtocolServerClient NtfResponse where
+  getProtocolServerClient = getNtfServerClient
+  protocolError = NTF
+
+getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
+getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
+  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  atomically (getClientVar srv smpClients)
+    >>= either
+      (newProtocolClient c srv smpClients connectClient reconnectClient)
+      (waitForProtocolClient smpCfg)
+  where
     connectClient :: m SMPClient
     connectClient = do
       cfg <- asks $ smpCfg . config
       u <- askUnliftIO
-      liftEitherError smpClientError (getSMPClient srv cfg msgQ $ clientDisconnected u)
-        `E.catch` internalError
-      where
-        internalError :: IOException -> m SMPClient
-        internalError = throwError . INTERNAL . show
+      liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
 
     clientDisconnected :: UnliftIO m -> IO ()
     clientDisconnected u = do
-      removeClientSubs >>= (`forM_` serverDown u)
+      removeClientAndSubs >>= (`forM_` serverDown u)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    removeClientSubs :: IO (Maybe (Map ConnId RcvQueue))
-    removeClientSubs = atomically $ do
-      modifyTVar smpClients $ M.delete srv
-      cs <- M.lookup srv <$> readTVar (subscrSrvrs c)
-      modifyTVar (subscrSrvrs c) $ M.delete srv
-      modifyTVar (subscrConns c) $ maybe id (deleteKeys . M.keysSet) cs
-      return cs
+    removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
+    removeClientAndSubs = atomically $ do
+      TM.delete srv smpClients
+      TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
       where
-        deleteKeys :: Ord k => Set k -> Map k a -> Map k a
-        deleteKeys ks m = S.foldr' M.delete m ks
+        updateSubs cVar = do
+          cs <- readTVar cVar
+          modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
+          addPendingSubs cVar cs
+          pure cs
+
+        addPendingSubs cVar cs = do
+          let ps = pendingSubscrSrvrs c
+          TM.lookup srv ps >>= \case
+            Just v -> TM.union cs v
+            _ -> TM.insert srv cVar ps
 
     serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
-    serverDown u cs = unless (M.null cs) $ do
-      mapM_ (notifySub DOWN) $ M.keysSet cs
-      a <- async . unliftIO u $ tryReconnectClient cs
-      atomically $ modifyTVar (reconnections c) (a :)
+    serverDown u cs = unless (M.null cs) $
+      whenM (readTVarIO active) $ do
+        let conns = M.keys cs
+        unless (null conns) . notifySub "" $ DOWN srv conns
+        unliftIO u reconnectServer
 
-    tryReconnectClient :: Map ConnId RcvQueue -> m ()
-    tryReconnectClient cs = do
+    reconnectServer :: m ()
+    reconnectServer = do
+      a <- async tryReconnectClient
+      atomically $ modifyTVar' (reconnections c) (a :)
+
+    tryReconnectClient :: m ()
+    tryReconnectClient = do
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop ->
-        reconnectClient cs `catchError` const loop
+        reconnectClient `catchError` const loop
 
-    reconnectClient :: Map ConnId RcvQueue -> m ()
-    reconnectClient cs = do
-      withAgentLock c . withSMP c srv $ \smp -> do
-        subs <- readTVarIO $ subscrConns c
-        forM_ (M.toList cs) $ \(connId, rq@RcvQueue {rcvPrivateKey, rcvId}) ->
-          when (isNothing $ M.lookup connId subs) $ do
-            subscribeSMPQueue smp rcvPrivateKey rcvId
-              `catchError` \case
-                SMPServerError e -> liftIO $ notifySub (ERR $ SMP e) connId
-                e -> throwError e
-            addSubscription c rq connId
-            liftIO $ notifySub UP connId
+    reconnectClient :: m ()
+    reconnectClient = do
+      n <- asks $ resubscriptionConcurrency . config
+      withAgentLock c . withClient c srv $ \smp -> do
+        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSubscrSrvrs c)
+        conns <- pooledForConcurrentlyN n (maybe [] M.toList cs) $ \sub@(connId, _) ->
+          ifM
+            (atomically $ hasActiveSubscription c connId)
+            (pure $ Just connId)
+            (subscribe_ smp sub `catchError` handleError connId)
+        liftIO . unless (null conns) . notifySub "" . UP srv $ catMaybes conns
+      where
+        subscribe_ :: SMPClient -> (ConnId, RcvQueue) -> ExceptT ProtocolClientError IO (Maybe ConnId)
+        subscribe_ smp (connId, rq@RcvQueue {rcvPrivateKey, rcvId}) = do
+          subscribeSMPQueue smp rcvPrivateKey rcvId
+          addSubscription c rq connId
+          pure $ Just connId
 
-    notifySub :: ACommand 'Agent -> ConnId -> IO ()
-    notifySub cmd connId = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+        handleError :: ConnId -> ProtocolClientError -> ExceptT ProtocolClientError IO (Maybe ConnId)
+        handleError connId = \case
+          e@PCEResponseTimeout -> throwError e
+          e@PCENetworkError -> throwError e
+          e -> do
+            liftIO . notifySub connId . ERR $ protocolClientError SMP e
+            atomically $ removePendingSubscription c srv connId
+            pure Nothing
 
-closeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
+    notifySub :: ConnId -> ACommand 'Agent -> IO ()
+    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+
+getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient
+getNtfServerClient c@AgentClient {active, ntfClients} srv = do
+  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  atomically (getClientVar srv ntfClients)
+    >>= either
+      (newProtocolClient c srv ntfClients connectClient $ pure ())
+      (waitForProtocolClient ntfCfg)
+  where
+    connectClient :: m NtfClient
+    connectClient = do
+      cfg <- asks $ ntfCfg . config
+      liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
+
+    clientDisconnected :: IO ()
+    clientDisconnected = do
+      atomically $ TM.delete srv ntfClients
+      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+
+getClientVar :: forall a. ProtocolServer -> TMap ProtocolServer (TMVar a) -> STM (Either (TMVar a) (TMVar a))
+getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
+  where
+    newClientVar :: STM (TMVar a)
+    newClientVar = do
+      var <- newEmptyTMVar
+      TM.insert srv var clients
+      pure var
+
+waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
+waitForProtocolClient clientConfig clientVar = do
+  ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
+  client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
+  liftEither $ case client_ of
+    Just (Right smpClient) -> Right smpClient
+    Just (Left e) -> Left e
+    Nothing -> Left $ BROKER TIMEOUT
+
+newProtocolClient ::
+  forall msg m.
+  AgentMonad m =>
+  AgentClient ->
+  ProtocolServer ->
+  TMap ProtocolServer (ClientVar msg) ->
+  m (ProtocolClient msg) ->
+  m () ->
+  ClientVar msg ->
+  m (ProtocolClient msg)
+newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
+  where
+    tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
+    tryConnectClient successAction retryAction =
+      tryError connectClient >>= \r -> case r of
+        Right client -> do
+          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
+          atomically $ putTMVar clientVar r
+          successAction client
+        Left e -> do
+          if e == BROKER NETWORK || e == BROKER TIMEOUT
+            then retryAction
+            else atomically $ do
+              putTMVar clientVar (Left e)
+              TM.delete srv clients
+          throwError e
+    tryConnectAsync :: m ()
+    tryConnectAsync = do
+      a <- async connectAsync
+      atomically $ modifyTVar' (asyncClients c) (a :)
+    connectAsync :: m ()
+    connectAsync = do
+      ri <- asks $ reconnectInterval . config
+      withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
+
+closeAgentClient :: MonadIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
-  closeSMPServerClients c
-  cancelActions $ activations c
+  atomically $ writeTVar (active c) False
+  closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
+  closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
   cancelActions $ reconnections c
-  cancelActions $ connMsgDeliveries c
-  cancelActions $ srvMsgDeliveries c
+  cancelActions $ asyncClients c
+  cancelActions $ smpQueueMsgDeliveries c
+  clear subscrSrvrs
+  clear pendingSubscrSrvrs
+  clear subscrConns
+  clear connMsgsQueued
+  clear smpQueueMsgQueues
+  where
+    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
+    clear sel = atomically $ writeTVar (sel c) M.empty
 
-closeSMPServerClients :: AgentClient -> IO ()
-closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ closeSMPClient
+closeProtocolServerClients :: Int -> TMap ProtocolServer (ClientVar msg) -> IO ()
+closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+  where
+    closeClient cVar =
+      tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
+        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
+        _ -> pure ()
 
-cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
+cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
+cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel >> atomically (writeTVar as mempty)
 
 withAgentLock :: MonadUnliftIO m => AgentClient -> m a -> m a
 withAgentLock AgentClient {lock} =
@@ -191,190 +341,228 @@ withAgentLock AgentClient {lock} =
     (void . atomically $ takeTMVar lock)
     (atomically $ putTMVar lock ())
 
-withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
-withSMP_ c srv action =
-  (getSMPServerClient c srv >>= action) `catchError` logServerError
+withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> m a) -> m a
+withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
   where
     logServerError :: AgentErrorType -> m a
     logServerError e = do
       logServer "<--" c srv "" $ bshow e
       throwError e
 
-withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
-withLogSMP_ c srv qId cmdStr action = do
+withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withLogClient_ c srv qId cmdStr action = do
   logServer "-->" c srv qId cmdStr
-  res <- withSMP_ c srv action
+  res <- withClient_ c srv action
   logServer "<--" c srv qId "OK"
   return res
 
-withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
-withSMP c srv action = withSMP_ c srv $ liftSMP . action
+withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withClient c srv action = withClient_ c srv $ liftClient (protocolError @msg) . action
 
-withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
-withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action
+withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (protocolError @msg) . action
 
-liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
-liftSMP = liftError smpClientError
+liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
+liftClient = liftError . protocolClientError
 
-smpClientError :: SMPClientError -> AgentErrorType
-smpClientError = \case
-  SMPServerError e -> SMP e
-  SMPResponseError e -> BROKER $ RESPONSE e
-  SMPUnexpectedResponse -> BROKER UNEXPECTED
-  SMPResponseTimeout -> BROKER TIMEOUT
-  SMPNetworkError -> BROKER NETWORK
-  SMPTransportError e -> BROKER $ TRANSPORT e
-  e -> INTERNAL $ show e
+protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
+protocolClientError protocolError_ = \case
+  PCEProtocolError e -> protocolError_ e
+  PCEResponseError e -> BROKER $ RESPONSE e
+  PCEUnexpectedResponse -> BROKER UNEXPECTED
+  PCEResponseTimeout -> BROKER TIMEOUT
+  PCENetworkError -> BROKER NETWORK
+  PCETransportError e -> BROKER $ TRANSPORT e
+  e@PCESignatureError {} -> INTERNAL $ show e
+  e@PCEIOError {} -> INTERNAL $ show e
 
-newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo)
-newRcvQueue c srv = do
-  size <- asks $ rsaKeySize . config
-  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size
+newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
+newRcvQueue c srv =
+  asks (cmdSignAlg . config) >>= \case
+    C.SignAlg a -> newRcvQueue_ a c srv
+
+newRcvQueue_ ::
+  (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
+  C.SAlgorithm a ->
+  AgentClient ->
+  SMPServer ->
+  m (RcvQueue, SMPQueueUri)
+newRcvQueue_ a c srv = do
+  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
+  (dhKey, privDhKey) <- liftIO C.generateKeyPair'
+  (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
-  (rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey
-  logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId]
-  (encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size
+  QIK {rcvId, sndId, rcvPublicDhKey} <-
+    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+  logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
           { server = srv,
             rcvId,
             rcvPrivateKey,
-            sndId = Just sId,
-            decryptKey,
-            verifyKey = Nothing,
+            rcvDhSecret = C.dh' rcvPublicDhKey privDhKey,
+            e2ePrivKey,
+            e2eDhSecret = Nothing,
+            sndId = Just sndId,
             status = New
           }
-  return (rq, SMPQueueInfo srv sId encryptKey)
+  pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
 
 subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
 subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
-  withLogSMP c server rcvId "SUB" $ \smp ->
-    subscribeSMPQueue smp rcvPrivateKey rcvId
-  addSubscription c rq connId
+  atomically $ addPendingSubscription c rq connId
+  withLogClient c server rcvId "SUB" $ \smp -> do
+    liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
+      Left e -> do
+        atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
+          removePendingSubscription c server connId
+        throwError e
+      Right _ -> addSubscription c rq connId
 
-addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
+addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
 addSubscription c rq@RcvQueue {server} connId = atomically $ do
-  modifyTVar (subscrConns c) $ M.insert connId server
-  modifyTVar (subscrSrvrs c) $ M.alter (Just . addSub) server
-  where
-    addSub :: Maybe (Map ConnId RcvQueue) -> Map ConnId RcvQueue
-    addSub (Just cs) = M.insert connId rq cs
-    addSub _ = M.singleton connId rq
+  TM.insert connId server $ subscrConns c
+  addSubs_ (subscrSrvrs c) rq connId
+  removePendingSubscription c server connId
 
-removeSubscription :: AgentMonad m => AgentClient -> ConnId -> m ()
-removeSubscription AgentClient {subscrConns, subscrSrvrs} connId = atomically $ do
-  cs <- readTVar subscrConns
-  writeTVar subscrConns $ M.delete connId cs
-  mapM_
-    (modifyTVar subscrSrvrs . M.alter (>>= delSub))
-    (M.lookup connId cs)
-  where
-    delSub :: Map ConnId RcvQueue -> Maybe (Map ConnId RcvQueue)
-    delSub cs =
-      let cs' = M.delete connId cs
-       in if M.null cs' then Nothing else Just cs'
+hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
+hasActiveSubscription c connId = TM.member connId (subscrConns c)
 
-addActivation :: MonadUnliftIO m => AgentClient -> ConnId -> Async () -> m ()
-addActivation c connId a = atomically . modifyTVar (activations c) $ M.insert connId a
+addPendingSubscription :: AgentClient -> RcvQueue -> ConnId -> STM ()
+addPendingSubscription = addSubs_ . pendingSubscrSrvrs
 
-getActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m (Maybe (Async ()))
-getActivation c connId = M.lookup connId <$> readTVarIO (activations c)
+addSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> RcvQueue -> ConnId -> STM ()
+addSubs_ ss rq@RcvQueue {server} connId =
+  TM.lookup server ss >>= \case
+    Just m -> TM.insert connId rq m
+    _ -> TM.singleton connId rq >>= \m -> TM.insert server m ss
 
-removeActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m ()
-removeActivation c connId = atomically . modifyTVar (activations c) $ M.delete connId
+removeSubscription :: AgentClient -> ConnId -> STM ()
+removeSubscription c@AgentClient {subscrConns} connId = do
+  server_ <- TM.lookupDelete connId subscrConns
+  mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
 
-logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
+removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
+removePendingSubscription = removeSubs_ . pendingSubscrSrvrs
+
+removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> STM ()
+removeSubs_ ss server connId =
+  TM.lookup server ss >>= mapM_ (TM.delete connId)
+
+logServer :: MonadIO m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
   logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 
 showServer :: SMPServer -> ByteString
-showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv)
+showServer ProtocolServer {host, port} =
+  B.pack $ host <> if null port then "" else ':' : port
 
 logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
 
-sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m ()
-sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo =
-  withLogSMP_ c server sndId "SEND <KEY>" $ \smp -> do
-    msg <- mkConfirmation smp
-    liftSMP $ sendSMPMessage smp Nothing sndId msg
-  where
-    mkConfirmation :: SMPClient -> m MsgBody
-    mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo
+sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
+sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
+  withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
+    let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
+    msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
+    liftClient SMP $ sendSMPMessage smp Nothing sndId msg
+sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
-sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> RetryInterval -> m ()
-sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri =
-  withLogSMP_ c server sndId "SEND <HELLO> (retrying)" $ \smp -> do
-    msg <- mkHello smp $ AckMode On
-    liftSMP . withRetryInterval ri $ \loop ->
-      sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case
-        SMPServerError AUTH -> loop
-        e -> throwE e
+sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
+  withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
+    msg <- mkInvitation
+    liftClient SMP $ sendSMPMessage smp Nothing senderId msg
   where
-    mkHello :: SMPClient -> AckMode -> m ByteString
-    mkHello smp ackMode = do
-      senderTimestamp <- liftIO getCurrentTime
-      encryptAndSign smp sq . serializeSMPMessage $
-        SMPMessage
-          { senderMsgId = 0,
-            senderTimestamp,
-            previousMsgHash = "",
-            agentMessage = HELLO verifyKey ackMode
-          }
+    mkInvitation :: m ByteString
+    -- this is only encrypted with per-queue E2E, not with double ratchet
+    mkInvitation = do
+      let agentEnvelope = AgentInvitation {agentVersion = smpAgentVersion, connReq, connInfo}
+      agentCbEncryptOnce dhPublicKey . smpEncode $
+        SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
 
-secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
+secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
 secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
-  withLogSMP c server rcvId "KEY <key>" $ \smp ->
+  withLogClient c server rcvId "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogSMP c server rcvId "ACK" $ \smp ->
+  withLogClient c server rcvId "ACK" $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId
 
 suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogSMP c server rcvId "OFF" $ \smp ->
+  withLogClient c server rcvId "OFF" $ \smp ->
     suspendSMPQueue smp rcvPrivateKey rcvId
 
 deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
 deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogSMP c server rcvId "DEL" $ \smp ->
+  withLogClient c server rcvId "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
-sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
-sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msg =
-  withLogSMP_ c server sndId "SEND <message>" $ \smp -> do
-    msg' <- encryptAndSign smp sq msg
-    liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg'
+sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
+sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
+  withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
+    let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
+    msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
+    liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
 
-encryptAndSign :: AgentMonad m => SMPClient -> SndQueue -> ByteString -> m ByteString
-encryptAndSign smp SndQueue {encryptKey, signKey} msg = do
-  paddedSize <- asks $ (blockSize smp -) . reservedMsgSize
-  liftError cryptoError $ do
-    enc <- C.encrypt encryptKey paddedSize msg
-    C.Signature sig <- C.sign signKey enc
-    pure $ sig <> enc
+agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
+agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
+  withClient c ntfServer $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
 
-decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString
-decryptAndVerify RcvQueue {decryptKey, verifyKey} msg =
-  verifyMessage verifyKey msg
-    >>= liftError cryptoError . C.decrypt decryptKey
+agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
+agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
+  withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
 
-verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString
-verifyMessage verifyKey msg = do
-  size <- asks $ rsaKeySize . config
-  let (sig, enc) = B.splitAt size msg
-  case verifyKey of
-    Nothing -> pure enc
-    Just k
-      | C.verify k (C.Signature sig) enc -> pure enc
-      | otherwise -> throwError $ AGENT A_SIGNATURE
+agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus
+agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
+  withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
+
+agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
+agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
+  withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
+
+agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m ()
+agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
+  withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
+
+agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
+agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
+  cmNonce <- liftIO C.randomCbNonce
+  let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
+  cmEncBody <-
+    liftEither . first cryptoError $
+      C.cbEncrypt e2eDhSecret cmNonce msg paddedLen
+  -- TODO per-queue client version
+  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) e2ePubKey
+  pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
+
+-- add encoding as AgentInvitation'?
+agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString
+agentCbEncryptOnce dhRcvPubKey msg = do
+  (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
+  let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
+  cmNonce <- liftIO C.randomCbNonce
+  cmEncBody <-
+    liftEither . first cryptoError $
+      C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
+  -- TODO per-queue client version
+  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) (Just dhSndPubKey)
+  pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
+
+-- | NaCl crypto-box decrypt - both for messages received from the server
+-- and per-queue E2E encrypted messages from the sender that were inside.
+agentCbDecrypt :: AgentMonad m => C.DhSecretX25519 -> C.CbNonce -> ByteString -> m ByteString
+agentCbDecrypt dhSecret nonce msg =
+  liftEither . first cryptoError $
+    C.cbDecrypt dhSecret nonce msg
 
 cryptoError :: C.CryptoError -> AgentErrorType
 cryptoError = \case
   C.CryptoLargeMsgError -> CMD LARGE
-  C.RSADecryptError _ -> AGENT A_ENCRYPTION
   C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
   C.AESDecryptError -> AGENT A_ENCRYPTION
+  C.CBDecryptError -> AGENT A_ENCRYPTION
   e -> INTERNAL $ show e

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

@@ -2,13 +2,23 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-module Simplex.Messaging.Agent.Env.SQLite where
+module Simplex.Messaging.Agent.Env.SQLite
+  ( AgentConfig (..),
+    InitialAgentServers (..),
+    defaultAgentConfig,
+    defaultReconnectInterval,
+    Env (..),
+    newSMPAgentEnv,
+  )
+where
 
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
+import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol (SMPServer)
@@ -16,48 +26,65 @@ 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 qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Client (NtfServer)
+import Simplex.Messaging.Transport (TLS, Transport (..))
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
 
+data InitialAgentServers = InitialAgentServers
+  { smp :: NonEmpty SMPServer,
+    ntf :: [NtfServer]
+  }
+
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
-    smpServers :: NonEmpty SMPServer,
-    rsaKeySize :: Int,
+    cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
     dbFile :: FilePath,
     dbPoolSize :: Int,
-    smpCfg :: SMPClientConfig,
-    retryInterval :: RetryInterval,
-    reconnectInterval :: RetryInterval
+    yesToMigrations :: Bool,
+    smpCfg :: ProtocolClientConfig,
+    ntfCfg :: ProtocolClientConfig,
+    reconnectInterval :: RetryInterval,
+    helloTimeout :: NominalDiffTime,
+    resubscriptionConcurrency :: Int,
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: FilePath
   }
 
-minute :: Int
-minute = 60_000_000
+defaultReconnectInterval :: RetryInterval
+defaultReconnectInterval =
+  RetryInterval
+    { initialInterval = second,
+      increaseAfter = 10 * second,
+      maxInterval = 10 * second
+    }
+  where
+    second = 1_000_000
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
   AgentConfig
     { tcpPort = "5224",
-      smpServers = undefined,
-      rsaKeySize = 2048 `div` 8,
+      cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
-      tbqSize = 16,
+      tbqSize = 64,
       dbFile = "smp-agent.db",
       dbPoolSize = 4,
-      smpCfg = smpDefaultConfig,
-      retryInterval =
-        RetryInterval
-          { initialInterval = 1_000_000,
-            increaseAfter = minute,
-            maxInterval = 10 * minute
-          },
-      reconnectInterval =
-        RetryInterval
-          { initialInterval = 1_000_000,
-            increaseAfter = 10_000_000,
-            maxInterval = 10_000_000
-          }
+      yesToMigrations = False,
+      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+      ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
+      reconnectInterval = defaultReconnectInterval,
+      helloTimeout = 2 * nominalDay,
+      resubscriptionConcurrency = 16,
+      -- 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"
     }
 
 data Env = Env
@@ -65,20 +92,13 @@ data Env = Env
     store :: SQLiteStore,
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
-    reservedMsgSize :: Int,
     randomServer :: TVar StdGen
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv cfg = do
+newSMPAgentEnv config@AgentConfig {dbFile, dbPoolSize, yesToMigrations} = do
   idsDrg <- newTVarIO =<< drgNew
-  store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
+  store <- liftIO $ createSQLiteStore dbFile dbPoolSize Migrations.app yesToMigrations
   clientCounter <- newTVarIO 0
   randomServer <- newTVarIO =<< liftIO newStdGen
-  return Env {config = cfg, store, idsDrg, clientCounter, reservedMsgSize, randomServer}
-  where
-    -- 1st rsaKeySize is used by the RSA signature in each command,
-    -- 2nd - by encrypted message body header
-    -- 3rd - by message signature
-    -- smpCommandSize - is the estimated max size for SMP command, queueId, corrId
-    reservedMsgSize = 3 * rsaKeySize cfg + smpCommandSize (smpCfg cfg)
+  return Env {config, store, idsDrg, clientCounter, randomServer}

src/Simplex/Messaging/Agent/QueryString.hs

@@ -0,0 +1,30 @@
+module Simplex.Messaging.Agent.QueryString where
+
+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.List (find)
+import qualified Network.HTTP.Types as Q
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (parseAll)
+
+data QueryStringParams = QSP QSPEscaping Q.SimpleQuery
+  deriving (Show)
+
+data QSPEscaping = QEscape | QNoEscaping
+  deriving (Show)
+
+instance StrEncoding QueryStringParams where
+  strEncode (QSP esc q) = case esc of
+    QEscape -> Q.renderSimpleQuery False q
+    QNoEscaping ->
+      Q.renderQueryPartialEscape False $
+        map (\(n, v) -> (n, [Q.QN v])) q
+  strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
+
+queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a
+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

src/Simplex/Messaging/Agent/Server.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Agent.Server
+  ( -- * SMP agent over TCP
+    runSMPAgent,
+    runSMPAgentBlocking,
+  )
+where
+
+import Control.Logger.Simple (logInfo)
+import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Reader
+import Crypto.Random (MonadRandom)
+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.Protocol
+import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
+import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer)
+import Simplex.Messaging.Util (bshow)
+import UnliftIO.Async (race_)
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+-- | Runs an SMP agent as a TCP service using passed configuration.
+--
+-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
+runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
+runSMPAgent t cfg initServers = do
+  started <- newEmptyTMVarIO
+  runSMPAgentBlocking t started cfg initServers
+
+-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
+--
+-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
+-- and when it is disconnected from the TCP socket once the server thread is killed (False).
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
+runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
+  runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
+  where
+    smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
+    smpAgent _ = do
+      -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
+      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
+        logConnection c True
+        race_ (connectClient h c) (runAgentClient c)
+          `E.finally` disconnectAgentClient c
+
+connectClient :: Transport c => MonadUnliftIO m => c -> AgentClient -> m ()
+connectClient h c = race_ (send h c) (receive h c)
+
+receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
+receive h c@AgentClient {rcvQ, subQ} = forever $ do
+  (corrId, connId, cmdOrErr) <- tGet SClient h
+  case cmdOrErr of
+    Right cmd -> write rcvQ (corrId, connId, cmd)
+    Left e -> write subQ (corrId, connId, ERR e)
+  where
+    write :: TBQueue (ATransmission p) -> ATransmission p -> m ()
+    write q t = do
+      logClient c "-->" t
+      atomically $ writeTBQueue q t
+
+send :: (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
+send h c@AgentClient {subQ} = forever $ do
+  t <- atomically $ readTBQueue subQ
+  tPut h t
+  logClient c "<--" t
+
+logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
+logClient AgentClient {clientId} dir (corrId, connId, cmd) = do
+  logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]

src/Simplex/Messaging/Agent/Store.hs

@@ -18,12 +18,16 @@ import Data.Kind (Type)
 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, SkippedMsgDiff, SkippedMsgKeys)
+import Simplex.Messaging.Notifications.Client
+import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfTknStatus, NtfTokenId)
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgId,
-    RecipientPrivateKey,
-    SenderPrivateKey,
-    SenderPublicKey,
+    RcvDhSecret,
+    RcvPrivateSignKey,
+    SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 
@@ -32,18 +36,16 @@ import qualified Simplex.Messaging.Protocol as SMP
 -- | 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 -> m ConnId
+  createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
   createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
   getConn :: s -> ConnId -> m SomeConn
-  getAllConnIds :: s -> m [ConnId] -- TODO remove - hack for subscribing to all
   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 ()
-  setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m ()
+  setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
   setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
-  updateSignKey :: s -> SndQueue -> SignatureKey -> m ()
 
   -- Confirmations
   createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
@@ -51,28 +53,56 @@ class Monad m => MonadAgentStore s m where
   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 ()
-  updateSndMsgStatus :: s -> ConnId -> InternalId -> SndMsgStatus -> m ()
-  getPendingMsgData :: s -> ConnId -> InternalId -> m (SndQueue, MsgBody)
-  getPendingMsgs :: s -> ConnId -> m [PendingMsg]
-  getMsg :: s -> ConnId -> InternalId -> m Msg
+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
+  getPendingMsgs :: s -> ConnId -> m [InternalId]
   checkRcvMsg :: s -> ConnId -> InternalId -> m ()
-  updateRcvMsgAck :: 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 ()
+
+  -- Notification device token persistence
+  createNtfToken :: s -> NtfToken -> m ()
+
+  getDeviceNtfToken :: s -> DeviceToken -> m (Maybe NtfToken, [NtfToken])
+  updateNtfTokenRegistration :: s -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> m ()
+  updateNtfToken :: s -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> m ()
+  removeNtfToken :: s -> NtfToken -> m ()
 
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
 data RcvQueue = RcvQueue
   { server :: SMPServer,
+    -- | recipient queue ID
     rcvId :: SMP.RecipientId,
-    rcvPrivateKey :: RecipientPrivateKey,
+    -- | key used by the recipient to sign transmissions
+    rcvPrivateKey :: RcvPrivateSignKey,
+    -- | shared DH secret used to encrypt/decrypt message bodies from server to recipient
+    rcvDhSecret :: RcvDhSecret,
+    -- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e)
+    e2ePrivKey :: C.PrivateKeyX25519,
+    -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
+    e2eDhSecret :: Maybe C.DhSecretX25519,
+    -- | sender queue ID
     sndId :: Maybe SMP.SenderId,
-    decryptKey :: DecryptionKey,
-    verifyKey :: Maybe VerificationKey,
+    -- | queue status
     status :: QueueStatus
   }
   deriving (Eq, Show)
@@ -80,10 +110,16 @@ data RcvQueue = RcvQueue
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
   { server :: SMPServer,
+    -- | sender queue ID
     sndId :: SMP.SenderId,
-    sndPrivateKey :: SenderPrivateKey,
-    encryptKey :: EncryptionKey,
-    signKey :: SignatureKey,
+    -- | key pair used by the sender to sign transmissions
+    sndPublicKey :: Maybe C.APublicVerifyKey,
+    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
   }
   deriving (Eq, Show)
@@ -91,7 +127,7 @@ data SndQueue = SndQueue
 -- * Connection types
 
 -- | Type of a connection.
-data ConnType = CRcv | CSnd | CDuplex deriving (Eq, Show)
+data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 
 -- | Connection of a specific type.
 --
@@ -107,6 +143,7 @@ data Connection (d :: ConnType) where
   RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
   SndConnection :: ConnData -> SndQueue -> Connection CSnd
   DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
+  ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
 deriving instance Eq (Connection d)
 
@@ -116,11 +153,13 @@ data SConnType :: ConnType -> Type where
   SCRcv :: SConnType CRcv
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
+  SCContact :: SConnType CContact
 
 connType :: SConnType c -> ConnType
 connType SCRcv = CRcv
 connType SCSnd = CSnd
 connType SCDuplex = CDuplex
+connType SCContact = CContact
 
 deriving instance Eq (SConnType d)
 
@@ -130,6 +169,7 @@ instance TestEquality SConnType where
   testEquality SCRcv SCRcv = Just Refl
   testEquality SCSnd SCSnd = Just Refl
   testEquality SCDuplex SCDuplex = Just Refl
+  testEquality SCContact SCContact = Just Refl
   testEquality _ _ = Nothing
 
 -- | Connection of an unknown type.
@@ -150,18 +190,35 @@ newtype ConnData = ConnData {connId :: ConnId}
 
 data NewConfirmation = NewConfirmation
   { connId :: ConnId,
-    senderKey :: SenderPublicKey,
-    senderConnInfo :: ConnInfo
+    senderConf :: SMPConfirmation,
+    ratchetState :: RatchetX448
   }
 
 data AcceptedConfirmation = AcceptedConfirmation
   { confirmationId :: ConfirmationId,
     connId :: ConnId,
-    senderKey :: SenderPublicKey,
-    senderConnInfo :: ConnInfo,
+    senderConf :: SMPConfirmation,
+    ratchetState :: RatchetX448,
     ownConnInfo :: ConnInfo
   }
 
+-- * Invitations
+
+data NewInvitation = NewInvitation
+  { contactConnId :: ConnId,
+    connReq :: ConnectionRequestUri 'CMInvitation,
+    recipientConnInfo :: ConnInfo
+  }
+
+data Invitation = Invitation
+  { invitationId :: InvitationId,
+    contactConnId :: ConnId,
+    connReq :: ConnectionRequestUri 'CMInvitation,
+    recipientConnInfo :: ConnInfo,
+    ownConnInfo :: Maybe ConnInfo,
+    accepted :: Bool
+  }
+
 -- * Message integrity validation types
 
 -- | Corresponds to `last_external_snd_msg_id` in `connections` table
@@ -173,12 +230,11 @@ type PrevRcvMsgHash = MsgHash
 -- | Corresponds to `last_snd_msg_hash` in `connections` table
 type PrevSndMsgHash = MsgHash
 
--- ? merge/replace these with RcvMsg and SndMsg
-
 -- * Message data containers - used on Msg creation to reduce number of parameters
 
 data RcvMsgData = RcvMsgData
   { msgMeta :: MsgMeta,
+    msgType :: AgentMessageType,
     msgBody :: MsgBody,
     internalRcvId :: InternalRcvId,
     internalHash :: MsgHash,
@@ -189,9 +245,10 @@ data SndMsgData = SndMsgData
   { internalId :: InternalId,
     internalSndId :: InternalSndId,
     internalTs :: InternalTs,
+    msgType :: AgentMessageType,
     msgBody :: MsgBody,
     internalHash :: MsgHash,
-    previousMsgHash :: MsgHash
+    prevMsgHash :: MsgHash
   }
 
 data PendingMsg = PendingMsg
@@ -200,43 +257,6 @@ data PendingMsg = PendingMsg
   }
   deriving (Show)
 
--- * Broadcast types
-
-type BroadcastId = ByteString
-
--- * Message types
-
--- | A message in either direction that is stored by the agent.
-data Msg = MRcv RcvMsg | MSnd SndMsg
-  deriving (Eq, Show)
-
--- | A message received by the agent from a sender.
-data RcvMsg = RcvMsg
-  { msgBase :: MsgBase,
-    internalRcvId :: InternalRcvId,
-    -- | Id of the message at sender, corresponds to `internalSndId` from the sender's side.
-    -- Sender Id is made sequential for detection of missing messages. For redundant / parallel queues,
-    -- it also allows to keep track of duplicates and restore the original order before delivery to the client.
-    externalSndId :: ExternalSndId,
-    externalSndTs :: ExternalSndTs,
-    -- | Id of the message at broker, although it is not sequential (to avoid metadata leakage for potential observer),
-    -- it is needed to track repeated deliveries in case of connection loss - this logic is not implemented yet.
-    brokerId :: BrokerId,
-    brokerTs :: BrokerTs,
-    rcvMsgStatus :: RcvMsgStatus,
-    -- | Timestamp of acknowledgement to broker, corresponds to `AcknowledgedToBroker` status.
-    -- Do not mix up with `brokerTs` - timestamp created at broker after it receives the message from sender.
-    ackBrokerTs :: AckBrokerTs,
-    -- | Timestamp of acknowledgement to sender, corresponds to `AcknowledgedToSender` status.
-    -- Do not mix up with `externalSndTs` - timestamp created at sender before sending,
-    -- which in its turn corresponds to `internalTs` in sending agent.
-    ackSenderTs :: AckSenderTs,
-    -- | Hash of previous message as received from sender - stored for integrity forensics.
-    externalPrevSndHash :: MsgHash,
-    msgIntegrity :: MsgIntegrity
-  }
-  deriving (Eq, Show)
-
 -- internal Ids are newtypes to prevent mixing them up
 newtype InternalRcvId = InternalRcvId {unRcvId :: Int64} deriving (Eq, Show)
 
@@ -248,44 +268,11 @@ type BrokerId = MsgId
 
 type BrokerTs = UTCTime
 
-data RcvMsgStatus
-  = Received
-  | AcknowledgedToBroker
-  | AcknowledgedToSender
-  deriving (Eq, Show)
-
-type AckBrokerTs = UTCTime
-
-type AckSenderTs = UTCTime
-
--- | A message sent by the agent to a recipient.
-data SndMsg = SndMsg
-  { msgBase :: MsgBase,
-    -- | Id of the message sent / to be sent, as in its number in order of sending.
-    internalSndId :: InternalSndId,
-    sndMsgStatus :: SndMsgStatus,
-    -- | Timestamp of the message received by broker, corresponds to `Sent` status.
-    sentTs :: SentTs,
-    -- | Timestamp of the message received by recipient, corresponds to `Delivered` status.
-    deliveredTs :: DeliveredTs
-  }
-  deriving (Eq, Show)
-
 newtype InternalSndId = InternalSndId {unSndId :: Int64} deriving (Eq, Show)
 
-data SndMsgStatus
-  = SndMsgCreated
-  | SndMsgSent
-  | SndMsgDelivered
-  deriving (Eq, Show)
-
-type SentTs = UTCTime
-
-type DeliveredTs = UTCTime
-
 -- | Base message data independent of direction.
 data MsgBase = MsgBase
-  { connAlias :: ConnId,
+  { connId :: ConnId,
     -- | Monotonically increasing id of a message per connection, internal to the agent.
     -- Internal Id preserves ordering between both received and sent messages, and is needed
     -- to track the order of the conversation (which can be different for the sender / receiver)
@@ -309,23 +296,29 @@ type InternalTs = UTCTime
 data StoreError
   = -- | IO exceptions in store actions.
     SEInternal ByteString
-  | -- | failed to generate unique random ID
+  | -- | Failed to generate unique random ID
     SEUniqueID
-  | -- | Connection alias not found (or both queues absent).
+  | -- | Connection not found (or both queues absent).
     SEConnNotFound
-  | -- | Connection alias already used.
+  | -- | Connection already used.
     SEConnDuplicate
   | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.
     -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.
     SEBadConnType ConnType
   | -- | Confirmation not found.
     SEConfirmationNotFound
+  | -- | Invitation not found
+    SEInvitationNotFound
   | -- | Message not found
     SEMsgNotFound
   | -- | 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.
     SEBadQueueStatus
+  | -- | connection does not have associated double-ratchet state
+    SERatchetNotFound
+  | -- | connection does not have associated x3dh keys
+    SEX3dhKeysNotFound
   | -- | Used in `getMsg` that is not implemented/used. TODO remove.
     SENotImplemented
   deriving (Eq, Show, Exception)

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

@@ -16,29 +16,33 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
 where
 
 import Control.Monad (forM_)
-import Data.FileEmbed (embedDir, makeRelativeToProject)
 import Data.Function (on)
 import Data.List (intercalate, sortBy)
 import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (Connection, Only (..))
+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 System.FilePath (takeBaseName, takeExtension)
+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
 
 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)
+  ]
+
 -- | The list of migrations in ascending order by date
 app :: [Migration]
-app =
-  sortBy (compare `on` name) . map migration . filter sqlFile $
-    $(makeRelativeToProject "migrations" >>= embedDir)
+app = sortBy (compare `on` name) $ map migration schemaMigrations
   where
-    sqlFile (file, _) = takeExtension file == ".sql"
-    migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
+    migration (name, query) = Migration {name = name, up = fromQuery query}
 
 get :: Connection -> [Migration] -> IO (Either String [Migration])
 get conn migrations =

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

@@ -0,0 +1,148 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220101_initial :: Query
+m20220101_initial =
+  [sql|
+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
+) 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,
+  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,
+  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'',
+  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,
+  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'))
+) 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
+);
+|]

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

@@ -0,0 +1,13 @@
+{-# 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

@@ -0,0 +1,39 @@
+{-# 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, -- apn
+  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/M20220404_ntf_subscriptions_draft.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220404_ntf_subscriptions_draft :: Query
+m20220404_ntf_subscriptions_draft =
+  [sql|
+ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
+
+ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
+
+ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
+
+CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
+
+CREATE TABLE ntf_subscriptions (
+  ntf_host TEXT NOT NULL,
+  ntf_port TEXT NOT NULL,
+  ntf_sub_id BLOB NOT NULL,
+  ntf_sub_status TEXT NOT NULL, -- new, created, active, pending, error_auth
+  ntf_sub_action TEXT, -- if there is an action required on this subscription: create / check / token / delete
+  ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
+  ntf_token TEXT NOT NULL, -- or BLOB?
+  smp_host TEXT NOT NULL,
+  smp_port TEXT NOT NULL,
+  smp_ntf_id BLOB NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL, -- this is to check subscription status periodically to know when it was last checked
+  PRIMARY KEY (ntf_host, ntf_port, ntf_sub_id),
+  FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
+    ON DELETE RESTRICT ON UPDATE CASCADE,
+  FOREIGN KEY (smp_host, smp_port, smp_ntf_id) REFERENCES rcv_queues (host, port, ntf_id)
+    ON DELETE RESTRICT ON UPDATE CASCADE
+) WITHOUT ROWID;
+|]

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

@@ -0,0 +1,161 @@
+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
+) 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,
+  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,
+  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'',
+  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,
+  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'))
+) 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, -- apn
+  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/Client.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -23,25 +24,28 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    SMPClient (blockSize),
-    getSMPClient,
-    closeSMPClient,
+    ProtocolClient (sessionId),
+    SMPClient,
+    getProtocolClient,
+    closeProtocolClient,
 
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
+    subscribeSMPQueueNotifications,
     secureSMPQueue,
+    enableSMPQueueNotifications,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
     deleteSMPQueue,
-    sendSMPCommand,
+    sendProtocolCommand,
 
     -- * Supporting types and client configuration
-    SMPClientError (..),
-    SMPClientConfig (..),
-    smpDefaultConfig,
-    SMPServerTransmission,
+    ProtocolClientError (..),
+    ProtocolClientConfig (..),
+    defaultClientConfig,
+    ServerTransmission,
   )
 where
 
@@ -54,100 +58,96 @@ import Control.Monad.Trans.Class
 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.Maybe (fromMaybe)
 import Network.Socket (ServiceName)
 import Numeric.Natural
-import Simplex.Messaging.Agent.Protocol (SMPServer (..))
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol
-import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
+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 (runTransportClient)
+import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
 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 SMPClient = SMPClient
+data ProtocolClient msg = ProtocolClient
   { action :: Async (),
     connected :: TVar Bool,
-    smpServer :: SMPServer,
+    sessionId :: SessionId,
+    protocolServer :: ProtocolServer,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
-    sentCommands :: TVar (Map CorrId Request),
-    sndQ :: TBQueue SignedRawTransmission,
-    rcvQ :: TBQueue SignedTransmissionOrError,
-    msgQ :: TBQueue SMPServerTransmission,
-    blockSize :: Int
+    sentCommands :: TMap CorrId (Request msg),
+    sndQ :: TBQueue SentRawTransmission,
+    rcvQ :: TBQueue (SignedTransmission msg),
+    msgQ :: Maybe (TBQueue (ServerTransmission msg))
   }
 
--- | Type synonym for transmission from some SPM server queue.
-type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker)
+type SMPClient = ProtocolClient SMP.BrokerMsg
 
--- | SMP client configuration.
-data SMPClientConfig = SMPClientConfig
+-- | Type synonym for transmission from some SPM server queue.
+type ServerTransmission msg = (ProtocolServer, SessionId, QueueId, msg)
+
+-- | protocol client configuration.
+data ProtocolClientConfig = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
-    -- | default SMP server port if port is not specified in SMPServer
+    -- | default server port if port is not specified in ProtocolServer
     defaultTransport :: (ServiceName, ATransport),
     -- | timeout of TCP commands (microseconds)
     tcpTimeout :: Int,
+    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
+    tcpKeepAlive :: Maybe KeepAliveOpts,
     -- | period for SMP ping commands (microseconds)
-    smpPing :: Int,
-    -- | SMP transport block size, Nothing - the block size will be set by the server.
-    -- Allowed sizes are 4, 8, 16, 32, 64 KiB (* 1024 bytes).
-    smpBlockSize :: Maybe Int,
-    -- | estimated maximum size of SMP command excluding message body,
-    -- determines the maximum allowed message size
-    smpCommandSize :: Int
+    smpPing :: Int
   }
 
--- | Default SMP client configuration.
-smpDefaultConfig :: SMPClientConfig
-smpDefaultConfig =
-  SMPClientConfig
-    { qSize = 16,
-      defaultTransport = ("5223", transport @TCP),
-      tcpTimeout = 4_000_000,
-      smpPing = 30_000_000,
-      smpBlockSize = Just 8192,
-      smpCommandSize = 256
+-- | Default protocol client configuration.
+defaultClientConfig :: ProtocolClientConfig
+defaultClientConfig =
+  ProtocolClientConfig
+    { qSize = 64,
+      defaultTransport = ("443", transport @TLS),
+      tcpTimeout = 5_000_000,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      smpPing = 600_000_000 -- 10min
     }
 
-data Request = Request
+data Request msg = Request
   { queueId :: QueueId,
-    responseVar :: TMVar Response
+    responseVar :: TMVar (Response msg)
   }
 
-type Response = Either SMPClientError Cmd
+type Response msg = Either ProtocolClientError msg
 
--- | Connects to 'SMPServer' using passed client configuration
+-- | Connects to 'ProtocolServer' 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.
-getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
-getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlockSize} msgQ disconnected =
-  atomically mkSMPClient >>= runClient useTransport
+getProtocolClient :: forall msg. Protocol msg => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
+  (atomically mkProtocolClient >>= runClient useTransport)
+    `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
   where
-    mkSMPClient :: STM SMPClient
-    mkSMPClient = do
+    mkProtocolClient :: STM (ProtocolClient msg)
+    mkProtocolClient = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
-      sentCommands <- newTVar M.empty
+      sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        SMPClient
+        ProtocolClient
           { action = undefined,
-            blockSize = undefined,
+            sessionId = undefined,
             connected,
-            smpServer,
+            protocolServer,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -156,100 +156,104 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
+    runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
     runClient (port', ATransport t) c = do
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host smpServer) port' (client t c thVar)
-            `finally` atomically (putTMVar thVar $ Left SMPNetworkError)
-      bSize <- tcpTimeout `timeout` atomically (takeTMVar thVar)
-      pure $ case bSize of
-        Just (Right blockSize) -> Right c {action, blockSize}
+          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
+            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
+      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
+      pure $ case th_ of
+        Just (Right THandle {sessionId}) -> Right c {action, sessionId}
         Just (Left e) -> Left e
-        Nothing -> Left SMPNetworkError
+        Nothing -> Left PCENetworkError
 
     useTransport :: (ServiceName, ATransport)
-    useTransport = case port smpServer of
-      Nothing -> defaultTransport cfg
-      Just "80" -> ("80", transport @WS)
-      Just p -> (p, transport @TCP)
+    useTransport = case port protocolServer of
+      "" -> defaultTransport cfg
+      "80" -> ("80", transport @WS)
+      p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
+    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
     client _ c thVar h =
-      runExceptT (clientHandshake h smpBlockSize $ keyHash smpServer) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
-        Right th -> do
+      runExceptT (protocolClientHandshake @msg h $ keyHash protocolServer) >>= \case
+        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
+        Right th@THandle {sessionId} -> do
           atomically $ do
             writeTVar (connected c) True
-            putTMVar thVar . Right $ blockSize (th :: THandle c)
-          raceAny_ [send c th, process c, receive c th, ping c]
+            putTMVar thVar $ Right th
+          let c' = c {sessionId} :: ProtocolClient msg
+          -- TODO remove ping if 0 is passed (or Nothing?)
+          raceAny_ [send c' th, process c', receive c' th, ping c']
             `finally` disconnected
 
-    send :: Transport c => SMPClient -> THandle c -> IO ()
-    send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
+    send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-    receive :: Transport c => SMPClient -> THandle c -> IO ()
-    receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ
+    receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
+    receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
-    ping :: SMPClient -> IO ()
+    ping :: ProtocolClient msg -> IO ()
     ping c = forever $ do
       threadDelay smpPing
-      runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING)
+      runExceptT $ sendProtocolCommand c Nothing "" protocolPing
 
-    process :: SMPClient -> IO ()
-    process SMPClient {rcvQ, sentCommands} = forever $ do
-      (_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
+    process :: ProtocolClient msg -> IO ()
+    process ProtocolClient {sessionId, rcvQ, sentCommands} = forever $ do
+      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
       if B.null $ bs corrId
         then sendMsg qId respOrErr
         else do
-          cs <- readTVarIO sentCommands
-          case M.lookup corrId cs of
+          atomically (TM.lookup corrId sentCommands) >>= \case
             Nothing -> sendMsg qId respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
-              modifyTVar sentCommands $ M.delete corrId
+              TM.delete corrId sentCommands
               putTMVar responseVar $
                 if queueId == qId
                   then case respOrErr of
-                    Left e -> Left $ SMPResponseError e
-                    Right (Cmd _ (ERR e)) -> Left $ SMPServerError e
-                    Right r -> Right r
-                  else Left SMPUnexpectedResponse
+                    Left e -> Left $ PCEResponseError e
+                    Right r -> case protocolError r of
+                      Just e -> Left $ PCEProtocolError e
+                      _ -> Right r
+                  else Left PCEUnexpectedResponse
+      where
+        sendMsg :: QueueId -> Either ErrorType msg -> IO ()
+        sendMsg qId = \case
+          Right cmd -> atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, qId, cmd)) msgQ
+          -- TODO send everything else to errQ and log in agent
+          _ -> return ()
 
-    sendMsg :: QueueId -> Either ErrorType Cmd -> IO ()
-    sendMsg qId = \case
-      Right (Cmd SBroker 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
+-- | Disconnects client from the server and terminates client threads.
+closeProtocolClient :: ProtocolClient msg -> IO ()
+closeProtocolClient = uninterruptibleCancel . action
 
 -- | SMP client error type.
-data SMPClientError
+data ProtocolClientError
   = -- | Correctly parsed SMP server ERR response.
     -- This error is forwarded to the agent client as `ERR SMP err`.
-    SMPServerError ErrorType
+    PCEProtocolError ErrorType
   | -- | Invalid server response that failed to parse.
     -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
-    SMPResponseError ErrorType
+    PCEResponseError 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`.
-    SMPUnexpectedResponse
+    PCEUnexpectedResponse
   | -- | Used for TCP connection and command response timeouts.
     -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
-    SMPResponseTimeout
+    PCEResponseTimeout
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
-    SMPNetworkError
+    PCENetworkError
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
-    SMPTransportError TransportError
+    PCETransportError TransportError
   | -- | Error when cryptographically "signing" the command.
-    SMPSignatureError C.CryptoError
+    PCESignatureError C.CryptoError
+  | -- | IO Error
+    PCEIOError IOException
   deriving (Eq, Show, Exception)
 
 -- | Create a new SMP queue.
@@ -257,79 +261,98 @@ data SMPClientError
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
 createSMPQueue ::
   SMPClient ->
-  RecipientPrivateKey ->
-  RecipientPublicKey ->
-  ExceptT SMPClientError IO (RecipientId, SenderId)
-createSMPQueue c rpKey rKey =
-  -- TODO add signing this request too - requires changes in the server
-  sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey) >>= \case
-    Cmd _ (IDS rId sId) -> return (rId, sId)
-    _ -> throwE SMPUnexpectedResponse
+  RcvPrivateSignKey ->
+  RcvPublicVerifyKey ->
+  RcvPublicDhKey ->
+  ExceptT ProtocolClientError IO QueueIdsKeys
+createSMPQueue c rpKey rKey dhKey =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
+    IDS qik -> pure qik
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-subscribeSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> ExceptT SMPClientError IO ()
-subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
-  sendSMPCommand c (Just rpKey) rId (Cmd SRecipient SUB) >>= \case
-    Cmd _ OK -> return ()
-    Cmd _ cmd@MSG {} ->
-      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
-    _ -> throwE SMPUnexpectedResponse
+subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
+subscribeSMPQueue c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+  sendSMPCommand c (Just rpKey) rId SUB >>= \case
+    OK -> return ()
+    cmd@MSG {} ->
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+    _ -> throwE PCEUnexpectedResponse
+
+-- | 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 = 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 -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO ()
-secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId
+secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError 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 -> ExceptT ProtocolClientError IO NotifierId
+enableSMPQueueNotifications c rpKey rId notifierKey =
+  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
+    NID nId -> pure nId
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT ProtocolClientError IO ()
 sendSMPMessage c spKey sId msg =
-  sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case
-    Cmd _ OK -> return ()
-    _ -> throwE SMPUnexpectedResponse
+  sendSMPCommand c spKey sId (SEND msg) >>= \case
+    OK -> pure ()
+    _ -> throwE PCEUnexpectedResponse
 
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-ackSMPMessage :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
-ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
-  sendSMPCommand c (Just rpKey) rId (Cmd SRecipient ACK) >>= \case
-    Cmd _ OK -> return ()
-    Cmd _ cmd@MSG {} ->
-      lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
-    _ -> throwE SMPUnexpectedResponse
+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+ackSMPMessage c@ProtocolClient {protocolServer, sessionId, msgQ} rpKey rId =
+  sendSMPCommand c (Just rpKey) rId ACK >>= \case
+    OK -> return ()
+    cmd@MSG {} ->
+      lift . atomically $ mapM_ (`writeTBQueue` (protocolServer, sessionId, rId, cmd)) msgQ
+    _ -> throwE PCEUnexpectedResponse
 
 -- | 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 -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
-suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF
+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError 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 -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
-deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue = okSMPCommand DEL
 
-okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
-    Cmd _ OK -> return ()
-    _ -> throwE SMPUnexpectedResponse
+    OK -> return ()
+    _ -> throwE PCEUnexpectedResponse
 
--- | Send any SMP command ('Cmd' type).
-sendSMPCommand :: SMPClient -> Maybe C.SafePrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
-sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do
+-- | 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 Protocol command
+sendProtocolCommand :: forall msg. ProtocolEncoding (ProtocolCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtocolCommand msg -> ExceptT ProtocolClientError IO msg
+sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
   corrId <- lift_ getNextCorrId
-  t <- signTransmission $ serializeTransmission (corrId, qId, cmd)
+  t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
   ExceptT $ sendRecv corrId t
   where
-    lift_ :: STM a -> ExceptT SMPClientError IO a
+    lift_ :: STM a -> ExceptT ProtocolClientError IO a
     lift_ action = ExceptT $ Right <$> atomically action
 
     getNextCorrId :: STM CorrId
@@ -337,22 +360,22 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
 
-    signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
+    signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
     signTransmission t = case pKey of
-      Nothing -> return ("", t)
+      Nothing -> return (Nothing, t)
       Just pk -> do
-        sig <- liftError SMPSignatureError $ C.sign pk t
-        return (sig, t)
+        sig <- liftError PCESignatureError $ C.sign pk t
+        return (Just sig, t)
 
     -- two separate "atomically" needed to avoid blocking
-    sendRecv :: CorrId -> SignedRawTransmission -> IO Response
+    sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
     sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
       where
-        withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
+        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
 
-    send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
+    send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
     send corrId t = do
       r <- newEmptyTMVar
-      modifyTVar sentCommands . M.insert corrId $ Request qId r
+      TM.insert corrId (Request qId r) sentCommands
       writeTBQueue sndQ t
       return r

src/Simplex/Messaging/Client/Agent.hs

@@ -0,0 +1,301 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# 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.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (catchAll_, tryE, whenM, ($>>=))
+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)
+
+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,
+      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 {tcpTimeout} = smpCfg agentCfg
+      smpClient_ <- liftIO $ tcpTimeout `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 :: 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, _) ->
+          whenM (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} =
+  B.pack $ host <> 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/Ratchet.hs

@@ -0,0 +1,488 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Simplex.Messaging.Crypto.Ratchet where
+
+import Control.Monad.Except
+import Control.Monad.Trans.Except
+import Crypto.Cipher.AES (AES256)
+import Crypto.Hash (SHA512)
+import qualified Crypto.KDF.HKDF as H
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.List.NonEmpty as L
+import Data.Map.Strict (Map)
+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 GHC.Generics
+import Simplex.Messaging.Agent.QueryString
+import Simplex.Messaging.Crypto
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')
+import Simplex.Messaging.Util (tryE)
+import Simplex.Messaging.Version
+
+e2eEncryptVersion :: Version
+e2eEncryptVersion = 1
+
+e2eEncryptVRange :: VersionRange
+e2eEncryptVRange = mkVersionRange 1 e2eEncryptVersion
+
+data E2ERatchetParams (a :: Algorithm)
+  = E2ERatchetParams Version (PublicKey a) (PublicKey a)
+  deriving (Eq, Show)
+
+instance AlgorithmI a => Encoding (E2ERatchetParams a) where
+  smpEncode (E2ERatchetParams v k1 k2) = smpEncode (v, k1, k2)
+  smpP = E2ERatchetParams <$> smpP <*> smpP <*> smpP
+
+instance VersionI (E2ERatchetParams a) where
+  type VersionRangeT (E2ERatchetParams a) = E2ERatchetParamsUri a
+  version (E2ERatchetParams v _ _) = v
+  toVersionRangeT (E2ERatchetParams _ k1 k2) vr = E2ERatchetParamsUri vr k1 k2
+
+instance VersionRangeI (E2ERatchetParamsUri a) where
+  type VersionT (E2ERatchetParamsUri a) = (E2ERatchetParams a)
+  versionRange (E2ERatchetParamsUri vr _ _) = vr
+  toVersionT (E2ERatchetParamsUri _ k1 k2) v = E2ERatchetParams v k1 k2
+
+data E2ERatchetParamsUri (a :: Algorithm)
+  = E2ERatchetParamsUri VersionRange (PublicKey a) (PublicKey a)
+  deriving (Eq, Show)
+
+instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where
+  strEncode (E2ERatchetParamsUri vs key1 key2) =
+    strEncode $
+      QSP QNoEscaping [("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])]
+  strP = do
+    query <- strP
+    vs <- queryParam "v" query
+    keys <- L.toList <$> queryParam "x3dh" query
+    case keys of
+      [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2
+      _ -> fail "bad e2e params"
+
+generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => Version -> IO (PrivateKey a, PrivateKey a, E2ERatchetParams a)
+generateE2EParams v = do
+  (k1, pk1) <- generateKeyPair'
+  (k2, pk2) <- generateKeyPair'
+  pure (pk1, pk2, E2ERatchetParams v k1 k2)
+
+data RatchetInitParams = RatchetInitParams
+  { assocData :: Str,
+    ratchetKey :: RatchetKey,
+    sndHK :: HeaderKey,
+    rcvNextHK :: HeaderKey
+  }
+  deriving (Eq, Show)
+
+x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
+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 _ sk1 sk2) =
+  x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
+
+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
+    (hk, rest) = B.splitAt 32 $ dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
+    (nhk, sk) = B.splitAt 32 rest
+
+type RatchetX448 = Ratchet 'X448
+
+data Ratchet a = Ratchet
+  { -- ratchet version range sent in messages (current .. max supported ratchet version)
+    rcVersion :: VersionRange,
+    -- associated data - must be the same in both parties ratchets
+    rcAD :: Str,
+    rcDHRs :: PrivateKey a,
+    rcRK :: RatchetKey,
+    rcSnd :: Maybe (SndRatchet a),
+    rcRcv :: Maybe RcvRatchet,
+    rcNs :: Word32,
+    rcNr :: Word32,
+    rcPN :: Word32,
+    rcNHKs :: HeaderKey,
+    rcNHKr :: HeaderKey
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance AlgorithmI a => ToJSON (Ratchet a) where
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+data SndRatchet a = SndRatchet
+  { rcDHRr :: PublicKey a,
+    rcCKs :: RatchetKey,
+    rcHKs :: HeaderKey
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance AlgorithmI a => ToJSON (SndRatchet a) where
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+data RcvRatchet = RcvRatchet
+  { rcCKr :: RatchetKey,
+    rcHKr :: HeaderKey
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON RcvRatchet where
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+type SkippedMsgKeys = Map HeaderKey SkippedHdrMsgKeys
+
+type SkippedHdrMsgKeys = Map Word32 MessageKey
+
+data SkippedMsgDiff
+  = SMDNoChange
+  | SMDRemove HeaderKey Word32
+  | SMDAdd SkippedMsgKeys
+
+-- | this function is only used in tests to apply changes in skipped messages,
+-- in the agent the diff is persisted, and the whole state is loaded for the next message.
+applySMDiff :: SkippedMsgKeys -> SkippedMsgDiff -> SkippedMsgKeys
+applySMDiff smks = \case
+  SMDNoChange -> smks
+  SMDRemove hk msgN -> fromMaybe smks $ do
+    mks <- M.lookup hk smks
+    _ <- M.lookup msgN mks
+    let mks' = M.delete msgN mks
+    pure $
+      if M.null mks'
+        then M.delete hk smks
+        else M.insert hk mks' smks
+  SMDAdd smks' ->
+    let merge hk mks = M.alter (Just . maybe mks (M.union mks)) hk
+     in M.foldrWithKey merge smks smks'
+
+type HeaderKey = Key
+
+data MessageKey = MessageKey Key IV
+
+instance Encoding MessageKey where
+  smpEncode (MessageKey (Key key) (IV iv)) = smpEncode (key, iv)
+  smpP = MessageKey <$> (Key <$> smpP) <*> (IV <$> smpP)
+
+-- | Input key material for double ratchet HKDF functions
+newtype RatchetKey = RatchetKey ByteString
+  deriving (Eq, Show)
+
+instance ToJSON RatchetKey where
+  toJSON (RatchetKey k) = strToJSON k
+  toEncoding (RatchetKey k) = strToJEncoding k
+
+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, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'
+
+instance ToField MessageKey where toField = toField . smpEncode
+
+instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
+
+-- | 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) => 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 = e2eEncryptVRange,
+          rcAD = assocData,
+          rcDHRs,
+          rcRK,
+          rcSnd = Just SndRatchet {rcDHRr, rcCKs, rcHKs = sndHK},
+          rcRcv = Nothing,
+          rcPN = 0,
+          rcNs = 0,
+          rcNr = 0,
+          rcNHKs,
+          rcNHKr = rcvNextHK
+        }
+
+-- | Receiving ratchet initialization, equivalent to RatchetInitBobHE in double ratchet spec
+--
+-- 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) => PrivateKey a -> RatchetInitParams -> Ratchet a
+initRcvRatchet rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
+  Ratchet
+    { rcVersion = e2eEncryptVRange,
+      rcAD = assocData,
+      rcDHRs,
+      rcRK = ratchetKey,
+      rcSnd = Nothing,
+      rcRcv = Nothing,
+      rcPN = 0,
+      rcNs = 0,
+      rcNr = 0,
+      rcNHKs = rcvNextHK,
+      rcNHKr = sndHK
+    }
+
+data MsgHeader a = MsgHeader
+  { -- | max supported ratchet version
+    msgMaxVersion :: Version,
+    msgDHRs :: PublicKey a,
+    msgPN :: Word32,
+    msgNs :: Word32
+  }
+  deriving (Eq, Show)
+
+data AMsgHeader
+  = forall a.
+    (AlgorithmI a, DhAlgorithm a) =>
+    AMsgHeader (SAlgorithm a) (MsgHeader a)
+
+-- to allow extension without increasing the size, the actual header length is:
+-- 69 = 2 (original size) + 2 + 1+56 (Curve448) + 4 + 4
+paddedHeaderLen :: Int
+paddedHeaderLen = 88
+
+-- only used in tests to validate correct padding
+-- (2 bytes - version size, 1 byte - header size, not to have it fixed or version-dependent)
+fullHeaderLen :: Int
+fullHeaderLen = 2 + 1 + paddedHeaderLen + authTagSize + ivSize @AES256
+
+instance AlgorithmI a => Encoding (MsgHeader a) where
+  smpEncode MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs} =
+    smpEncode (msgMaxVersion, msgDHRs, msgPN, msgNs)
+  smpP = do
+    msgMaxVersion <- smpP
+    msgDHRs <- smpP
+    msgPN <- smpP
+    msgNs <- smpP
+    pure MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs}
+
+data EncMessageHeader = EncMessageHeader
+  { ehVersion :: Version,
+    ehIV :: IV,
+    ehAuthTag :: AuthTag,
+    ehBody :: ByteString
+  }
+
+instance Encoding EncMessageHeader where
+  smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} =
+    smpEncode (ehVersion, ehIV, ehAuthTag, ehBody)
+  smpP = do
+    (ehVersion, ehIV, ehAuthTag, ehBody) <- smpP
+    pure EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody}
+
+data EncRatchetMessage = EncRatchetMessage
+  { emHeader :: ByteString,
+    emAuthTag :: AuthTag,
+    emBody :: ByteString
+  }
+
+instance Encoding EncRatchetMessage where
+  smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag} =
+    smpEncode (emHeader, emAuthTag, Tail emBody)
+  smpP = do
+    (emHeader, emAuthTag, Tail emBody) <- smpP
+    pure EncRatchetMessage {emHeader, emBody, emAuthTag}
+
+rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> ExceptT CryptoError IO (ByteString, Ratchet a)
+rcEncrypt Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState
+rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcNs, rcPN, rcAD = Str rcAD, rcVersion} paddedMsgLen msg = do
+  -- state.CKs, mk = KDF_CK(state.CKs)
+  let (ck', mk, iv, ehIV) = chainKdf rcCKs
+  -- enc_header = HENCRYPT(state.HKs, header)
+  (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV paddedHeaderLen rcAD msgHeader
+  -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
+  let emHeader = smpEncode EncMessageHeader {ehVersion = minVersion rcVersion, ehBody, ehAuthTag, ehIV}
+  (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg
+  let msg' = smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag}
+      -- state.Ns += 1
+      rc' = rc {rcSnd = Just sr {rcCKs = ck'}, rcNs = rcNs + 1}
+  pure (msg', rc')
+  where
+    -- header = HEADER(state.DHRs, state.PN, state.Ns)
+    msgHeader =
+      smpEncode
+        MsgHeader
+          { msgMaxVersion = maxVersion rcVersion,
+            msgDHRs = publicKey rcDHRs,
+            msgPN = rcPN,
+            msgNs = rcNs
+          }
+
+data SkippedMessage a
+  = SMMessage (DecryptResult a)
+  | SMHeader (Maybe RatchetStep) (MsgHeader a)
+  | SMNone
+
+data RatchetStep = AdvanceRatchet | SameRatchet
+  deriving (Eq)
+
+type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)
+
+maxSkip :: Word32
+maxSkip = 512
+
+rcDecrypt ::
+  forall a.
+  (AlgorithmI a, DhAlgorithm a) =>
+  Ratchet a ->
+  SkippedMsgKeys ->
+  ByteString ->
+  ExceptT CryptoError IO (DecryptResult a)
+rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
+  encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg'
+  encHdr <- parseE CryptoHeaderError smpP emHeader
+  -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)
+  decryptSkipped encHdr encMsg >>= \case
+    SMNone -> do
+      (rcStep, hdr) <- decryptRcHeader rcRcv encHdr
+      decryptRcMessage rcStep hdr encMsg
+    SMHeader rcStep_ hdr ->
+      case rcStep_ of
+        Just rcStep -> decryptRcMessage rcStep hdr encMsg
+        Nothing -> throwE CERatchetHeader
+    SMMessage r -> pure r
+  where
+    decryptRcMessage :: RatchetStep -> MsgHeader a -> EncRatchetMessage -> ExceptT CryptoError IO (DecryptResult a)
+    decryptRcMessage rcStep MsgHeader {msgDHRs, msgPN, msgNs} encMsg = do
+      -- if dh_ratchet:
+      (rc', smks1) <- ratchetStep rcStep
+      case skipMessageKeys msgNs rc' of
+        Left e -> pure (Left e, rc', smkDiff smks1)
+        Right (rc''@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr}, rcNr}, smks2) -> do
+          -- state.CKr, mk = KDF_CK(state.CKr)
+          let (rcCKr', mk, iv, _) = chainKdf rcCKr
+          -- return DECRYPT (mk, cipher-text, CONCAT (AD, enc_header))
+          msg <- decryptMessage (MessageKey mk iv) encMsg
+          -- state . Nr += 1
+          pure (msg, rc'' {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr + 1}, smkDiff $ smks1 <> smks2)
+        Right (rc'', smks2) -> do
+          pure (Left CERatchetState, rc'', smkDiff $ smks1 <> smks2)
+      where
+        smkDiff :: SkippedMsgKeys -> SkippedMsgDiff
+        smkDiff smks = if M.null smks then SMDNoChange else SMDAdd smks
+        ratchetStep :: RatchetStep -> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)
+        ratchetStep SameRatchet = pure (rc, M.empty)
+        ratchetStep AdvanceRatchet =
+          -- SkipMessageKeysHE(state, header.pn)
+          case skipMessageKeys msgPN rc of
+            Left e -> throwE e
+            Right (rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr}, hmks) -> do
+              -- DHRatchetHE(state, header)
+              (_, rcDHRs') <- liftIO $ generateKeyPair' @a
+              -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
+              let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs
+                  -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
+                  (rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs'
+                  rc'' =
+                    rc'
+                      { rcDHRs = rcDHRs',
+                        rcRK = rcRK'',
+                        rcSnd = Just SndRatchet {rcDHRr = msgDHRs, rcCKs = rcCKs', rcHKs = rcNHKs},
+                        rcRcv = Just RcvRatchet {rcCKr = rcCKr', rcHKr = rcNHKr},
+                        rcPN = rcNs rc,
+                        rcNs = 0,
+                        rcNr = 0,
+                        rcNHKs = rcNHKs',
+                        rcNHKr = rcNHKr'
+                      }
+              pure (rc'', hmks)
+    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 = Left CERatchetDuplicateMessage
+      | rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
+      | rcNr == untilN = Right (r, M.empty)
+      | otherwise =
+        let (rcCKr', rcNr', mks) = advanceRcvRatchet (untilN - rcNr) rcCKr rcNr M.empty
+            r' = r {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr'}
+         in Right (r', M.singleton rcHKr mks)
+    advanceRcvRatchet :: Word32 -> RatchetKey -> Word32 -> SkippedHdrMsgKeys -> (RatchetKey, Word32, SkippedHdrMsgKeys)
+    advanceRcvRatchet 0 ck msgNs mks = (ck, msgNs, mks)
+    advanceRcvRatchet n ck msgNs mks =
+      let (ck', mk, iv, _) = chainKdf ck
+          mks' = M.insert msgNs (MessageKey mk iv) mks
+       in advanceRcvRatchet (n - 1) ck' (msgNs + 1) mks'
+    decryptSkipped :: EncMessageHeader -> EncRatchetMessage -> ExceptT CryptoError IO (SkippedMessage a)
+    decryptSkipped encHdr encMsg = tryDecryptSkipped SMNone $ M.assocs rcMKSkipped
+      where
+        tryDecryptSkipped :: SkippedMessage a -> [(HeaderKey, SkippedHdrMsgKeys)] -> ExceptT CryptoError IO (SkippedMessage a)
+        tryDecryptSkipped SMNone ((hk, mks) : hks) = do
+          tryE (decryptHeader hk encHdr) >>= \case
+            Left CERatchetHeader -> tryDecryptSkipped SMNone hks
+            Left e -> throwE e
+            Right hdr@MsgHeader {msgNs} ->
+              case M.lookup msgNs mks of
+                Nothing ->
+                  let nextRc
+                        | maybe False ((== hk) . rcHKr) rcRcv = Just SameRatchet
+                        | hk == rcNHKr rc = Just AdvanceRatchet
+                        | otherwise = Nothing
+                   in pure $ SMHeader nextRc hdr
+                Just mk -> do
+                  msg <- decryptMessage mk encMsg
+                  pure $ SMMessage (msg, rc, SMDRemove hk msgNs)
+        tryDecryptSkipped r _ = pure r
+    decryptRcHeader :: Maybe RcvRatchet -> EncMessageHeader -> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
+    decryptRcHeader Nothing hdr = decryptNextHeader hdr
+    decryptRcHeader (Just RcvRatchet {rcHKr}) hdr =
+      -- header = HDECRYPT(state.HKr, enc_header)
+      ((SameRatchet,) <$> decryptHeader rcHKr hdr) `catchE` \case
+        CERatchetHeader -> decryptNextHeader hdr
+        e -> throwE e
+    -- header = HDECRYPT(state.NHKr, enc_header)
+    decryptNextHeader hdr = (AdvanceRatchet,) <$> decryptHeader (rcNHKr rc) hdr
+    decryptHeader k EncMessageHeader {ehBody, ehAuthTag, ehIV} = do
+      header <- decryptAEAD k ehIV rcAD ehBody ehAuthTag `catchE` \_ -> throwE CERatchetHeader
+      parseE' CryptoHeaderError smpP header
+    decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
+    decryptMessage (MessageKey mk iv) EncRatchetMessage {emHeader, emBody, emAuthTag} =
+      -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
+      -- TODO add associated data
+      tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
+
+rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> (RatchetKey, RatchetKey, Key)
+rootKdf (RatchetKey rk) k pk =
+  let dhOut = dhBytes' $ dh' k pk
+      (rk', ck, nhk) = hkdf3 rk dhOut "SimpleXRootRatchet"
+   in (RatchetKey rk', RatchetKey ck, Key nhk)
+
+chainKdf :: RatchetKey -> (RatchetKey, Key, IV, IV)
+chainKdf (RatchetKey ck) =
+  let (ck', mk, ivs) = hkdf3 "" ck "SimpleXChainRatchet"
+      (iv1, iv2) = B.splitAt 16 ivs
+   in (RatchetKey ck', Key mk, IV iv1, IV iv2)
+
+hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
+hkdf3 salt ikm info = (s1, s2, s3)
+  where
+    prk = H.extract salt ikm :: H.PRK SHA512
+    out = H.expand prk info 96
+    (s1, rest) = B.splitAt 32 out
+    (s2, s3) = B.splitAt 32 rest

src/Simplex/Messaging/Encoding.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Simplex.Messaging.Encoding
+  ( Encoding (..),
+    Tail (..),
+    Large (..),
+    smpEncodeList,
+    smpListP,
+  )
+where
+
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bits (shiftL, shiftR, (.|.))
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Internal (c2w, w2c)
+import Data.Int (Int64)
+import qualified Data.List.NonEmpty as L
+import Data.Time.Clock.System (SystemTime (..))
+import Data.Word (Word16, Word32)
+import Network.Transport.Internal (decodeWord16, decodeWord32, encodeWord16, encodeWord32)
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Util ((<$?>))
+
+-- | SMP protocol encoding
+class Encoding a where
+  {-# MINIMAL smpEncode, (smpDecode | smpP) #-}
+
+  -- | protocol encoding of type (default implementation uses protocol ByteString encoding)
+  smpEncode :: a -> ByteString
+
+  -- | decoding of type (default implementation uses parser)
+  smpDecode :: ByteString -> Either String a
+  smpDecode = parseAll smpP
+
+  -- | protocol parser of type (default implementation parses protocol ByteString encoding)
+  smpP :: Parser a
+  smpP = smpDecode <$?> smpP
+
+instance Encoding Char where
+  smpEncode = B.singleton
+  smpP = A.anyChar
+
+instance Encoding Word16 where
+  smpEncode = encodeWord16
+  smpP = decodeWord16 <$> A.take 2
+
+instance Encoding Word32 where
+  smpEncode = encodeWord32
+  smpP = decodeWord32 <$> A.take 4
+
+instance Encoding Int64 where
+  smpEncode i = w32 (i `shiftR` 32) <> w32 i
+  smpP = do
+    l <- w32P
+    r <- w32P
+    pure $ (l `shiftL` 32) .|. r
+
+w32 :: Int64 -> ByteString
+w32 = smpEncode @Word32 . fromIntegral
+
+w32P :: Parser Int64
+w32P = fromIntegral <$> smpP @Word32
+
+-- ByteStrings are assumed no longer than 255 bytes
+instance Encoding ByteString where
+  smpEncode s = B.cons (lenEncode $ B.length s) s
+  smpP = A.take =<< lenP
+
+lenEncode :: Int -> Char
+lenEncode = w2c . fromIntegral
+
+lenP :: Parser Int
+lenP = fromIntegral . c2w <$> A.anyChar
+
+instance Encoding a => Encoding (Maybe a) where
+  smpEncode s = maybe "0" (("1" <>) . smpEncode) s
+  smpP =
+    smpP >>= \case
+      '0' -> pure Nothing
+      '1' -> Just <$> smpP
+      _ -> fail "invalid Maybe tag"
+
+newtype Tail = Tail {unTail :: ByteString}
+
+instance Encoding Tail where
+  smpEncode = unTail
+  smpP = Tail <$> A.takeByteString
+
+-- 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
+  smpP = do
+    len <- fromIntegral <$> smpP @Word16
+    Large <$> A.take len
+
+instance Encoding SystemTime where
+  smpEncode = smpEncode . systemSeconds
+  smpP = MkSystemTime <$> smpP <*> pure 0
+
+-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
+smpEncodeList :: Encoding a => [a] -> ByteString
+smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs
+
+smpListP :: Encoding a => Parser [a]
+smpListP = (`A.count` smpP) =<< lenP
+
+instance Encoding String where
+  smpEncode = smpEncode . B.pack
+  smpP = B.unpack <$> smpP
+
+instance Encoding a => Encoding (L.NonEmpty a) where
+  smpEncode = smpEncodeList . L.toList
+  smpP =
+    lenP >>= \case
+      0 -> fail "empty list"
+      n -> L.fromList <$> A.count n smpP
+
+instance (Encoding a, Encoding b) => Encoding (a, b) where
+  smpEncode (a, b) = smpEncode a <> smpEncode b
+  smpP = (,) <$> smpP <*> smpP
+
+instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
+  smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
+  smpP = (,,) <$> smpP <*> smpP <*> 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
+  smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> 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
+  smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> 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
+  smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP

src/Simplex/Messaging/Encoding/String.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Encoding.String
+  ( TextEncoding (..),
+    StrEncoding (..),
+    Str (..),
+    strP_,
+    strToJSON,
+    strToJEncoding,
+    strParseJSON,
+    base64urlP,
+    strEncodeList,
+    strListP,
+  )
+where
+
+import Control.Applicative (optional)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.Types as JT
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+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.Text (Text)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Time.Clock.System (SystemTime (..))
+import Data.Word (Word16)
+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) #-}
+  strEncode :: a -> ByteString
+
+  -- Please note - if you only specify strDecode, it will use base64urlP as default parser before decoding the string
+  strDecode :: ByteString -> Either String a
+  strDecode = parseAll strP
+  strP :: Parser a
+  strP = strDecode <$?> base64urlP
+
+-- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings
+instance StrEncoding ByteString where
+  strEncode = U.encode
+  strDecode = U.decode
+  strP = base64urlP
+
+base64urlP :: Parser ByteString
+base64urlP = do
+  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
+  pad <- A.takeWhile (== '=')
+  either fail pure $ U.decode (str <> pad)
+
+newtype Str = Str {unStr :: ByteString}
+  deriving (Eq, Show)
+
+instance StrEncoding Str where
+  strEncode = unStr
+  strP = Str <$> A.takeTill (== ' ') <* optional A.space
+
+instance ToJSON Str where
+  toJSON (Str s) = strToJSON s
+  toEncoding (Str s) = strToJEncoding s
+
+instance FromJSON Str where
+  parseJSON = fmap Str . strParseJSON "Str"
+
+instance StrEncoding a => StrEncoding (Maybe a) where
+  strEncode = maybe "" strEncode
+  strP = optional strP
+
+instance StrEncoding Word16 where
+  strEncode = B.pack . show
+  strP = A.decimal
+
+instance StrEncoding Int64 where
+  strEncode = B.pack . show
+  strP = A.decimal
+
+instance StrEncoding SystemTime where
+  strEncode = strEncode . systemSeconds
+  strP = MkSystemTime <$> strP <*> pure 0
+
+-- lists encode/parse as comma-separated strings
+strEncodeList :: StrEncoding a => [a] -> ByteString
+strEncodeList = B.intercalate "," . map strEncode
+
+strListP :: StrEncoding a => Parser [a]
+strListP = listItem `A.sepBy'` A.char ','
+
+-- relies on sepBy1 never returning an empty list
+instance StrEncoding a => StrEncoding (L.NonEmpty a) where
+  strEncode = strEncodeList . L.toList
+  strP = L.fromList <$> listItem `A.sepBy1'` A.char ','
+
+listItem :: StrEncoding a => Parser a
+listItem = parseAll strP <$?> A.takeTill (== ',')
+
+instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
+  strEncode (a, b) = B.unwords [strEncode a, strEncode b]
+  strP = (,) <$> strP_ <*> 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]
+  strP = (,,) <$> strP_ <*> strP_ <*> 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]
+  strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> 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]
+  strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
+
+strP_ :: StrEncoding a => Parser a
+strP_ = strP <* A.space
+
+strToJSON :: StrEncoding a => a -> J.Value
+strToJSON = J.String . decodeLatin1 . strEncode
+
+strToJEncoding :: StrEncoding a => a -> J.Encoding
+strToJEncoding = JE.text . decodeLatin1 . strEncode
+
+strParseJSON :: StrEncoding a => String -> J.Value -> JT.Parser a
+strParseJSON name = J.withText name $ either fail pure . parseAll strP . encodeUtf8

src/Simplex/Messaging/Notifications/Client.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Notifications.Client where
+
+import Control.Monad.Except
+import Control.Monad.Trans.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Word (Word16)
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.Messaging.Client
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Parsers (blobFieldDecoder)
+import Simplex.Messaging.Protocol (ProtocolServer)
+
+type NtfServer = ProtocolServer
+
+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
+    NRId tknId dhKey -> pure (tknId, dhKey)
+    _ -> throwE PCEUnexpectedResponse
+
+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
+    _ -> throwE PCEUnexpectedResponse
+
+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
+
+ntfCreateSubsciption :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO (NtfSubscriptionId, C.PublicKeyX25519)
+ntfCreateSubsciption c pKey newSub =
+  sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
+    NRId subId dhKey -> pure (subId, dhKey)
+    _ -> throwE PCEUnexpectedResponse
+
+ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
+ntfCheckSubscription c pKey subId =
+  sendNtfCommand c (Just pKey) subId SCHK >>= \case
+    NRSub stat -> pure stat
+    _ -> throwE PCEUnexpectedResponse
+
+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 ()
+    _ -> throwE PCEUnexpectedResponse
+
+data NtfTknAction
+  = NTARegister
+  | NTAVerify NtfRegCode -- code to verify token
+  | NTACheck
+  | NTACron Word16
+  | NTADelete
+  deriving (Show)
+
+instance Encoding NtfTknAction where
+  smpEncode = \case
+    NTARegister -> "R"
+    NTAVerify code -> smpEncode ('V', code)
+    NTACheck -> "C"
+    NTACron interval -> smpEncode ('I', interval)
+    NTADelete -> "D"
+  smpP =
+    A.anyChar >>= \case
+      'R' -> pure NTARegister
+      'V' -> NTAVerify <$> smpP
+      'C' -> pure NTACheck
+      'I' -> NTACron <$> smpP
+      '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
+  }
+  deriving (Show)
+
+newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NtfToken
+newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys =
+  NtfToken
+    { deviceToken,
+      ntfServer,
+      ntfTokenId = Nothing,
+      ntfPubKey,
+      ntfPrivKey,
+      ntfDhKeys,
+      ntfDhSecret = Nothing,
+      ntfTknStatus = NTNew,
+      ntfTknAction = Just NTARegister
+    }

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -0,0 +1,434 @@
+{-# 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 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 ((<$?>))
+
+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
+  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"
+    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_
+    "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 -> NewNtfEntity 'Subscription -- NtfTokenId -> C.APublicVerifyKey -> SMPQueueNtf
+
+deriving instance Show (NewNtfEntity e)
+
+data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
+
+instance NtfEntityI e => Encoding (NewNtfEntity e) where
+  smpEncode = \case
+    NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
+    NewNtfSub tknId smpQueue -> smpEncode ('S', tknId, smpQueue)
+  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)
+      _ -> fail "bad ANewNtfEntity"
+
+instance Protocol NtfResponse where
+  type ProtocolCommand NtfResponse = NtfCmd
+  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
+  -- | 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 STAT)
+  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 = \case
+    TNEW newTkn -> e (TNEW_, ' ', newTkn)
+    TVFY code -> e (TVFY_, ' ', code)
+    TCHK -> e TCHK_
+    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 tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP (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 (NtfCmd _ c) = encodeProtocol c
+
+  protocolP = \case
+    NCT SToken tag ->
+      NtfCmd SToken <$> case tag of
+        TNEW_ -> TNEW <$> _smpP
+        TVFY_ -> TVFY <$> _smpP
+        TCHK_ -> pure TCHK
+        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
+  = NRId_
+  | NROk_
+  | NRErr_
+  | NRTkn_
+  | NRSub_
+  | NRPong_
+  deriving (Show)
+
+instance Encoding NtfResponseTag where
+  smpEncode = \case
+    NRId_ -> "ID"
+    NROk_ -> "OK"
+    NRErr_ -> "ERR"
+    NRTkn_ -> "TKN"
+    NRSub_ -> "SUB"
+    NRPong_ -> "PONG"
+  smpP = messageTagP
+
+instance ProtocolMsgTag NtfResponseTag where
+  decodeTag = \case
+    "ID" -> Just NRId_
+    "OK" -> Just NROk_
+    "ERR" -> Just NRErr_
+    "TKN" -> Just NRTkn_
+    "SUB" -> Just NRSub_
+    "PONG" -> Just NRPong_
+    _ -> Nothing
+
+data NtfResponse
+  = NRId NtfEntityId C.PublicKeyX25519
+  | NROk
+  | NRErr ErrorType
+  | NRTkn NtfTknStatus
+  | NRSub NtfSubStatus
+  | NRPong
+  deriving (Show)
+
+instance ProtocolEncoding NtfResponse where
+  type Tag NtfResponse = NtfResponseTag
+  encodeProtocol = \case
+    NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
+    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 = \case
+    NRId_ -> NRId <$> _smpP <*> smpP
+    NROk_ -> pure NROk
+    NRErr_ -> NRErr <$> _smpP
+    NRTkn_ -> NRTkn <$> _smpP
+    NRSub_ -> NRSub <$> _smpP
+    NRPong_ -> pure NRPong
+
+  checkCredentials (_, _, entId, _) cmd = case cmd of
+    -- ID response must not have queue ID
+    NRId {} -> 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 :: ProtocolServer,
+    notifierId :: NotifierId,
+    notifierKey :: NtfPrivateSignKey
+  }
+  deriving (Show)
+
+instance Encoding SMPQueueNtf where
+  smpEncode SMPQueueNtf {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
+  smpP = do
+    (smpServer, notifierId, notifierKey) <- smpP
+    pure $ SMPQueueNtf smpServer notifierId notifierKey
+
+data PushProvider = PPApns
+  deriving (Eq, Ord, Show)
+
+instance Encoding PushProvider where
+  smpEncode = \case
+    PPApns -> "A"
+  smpP =
+    A.anyChar >>= \case
+      'A' -> pure PPApns
+      _ -> fail "bad PushProvider"
+
+instance TextEncoding PushProvider where
+  textEncode = \case
+    PPApns -> "apple"
+  textDecode = \case
+    "apple" -> Just PPApns
+    _ -> Nothing
+
+instance FromField PushProvider where fromField = fromTextField_ textDecode
+
+instance ToField PushProvider where toField = toField . textEncode
+
+data DeviceToken = DeviceToken PushProvider ByteString
+  deriving (Eq, Ord, Show)
+
+instance Encoding DeviceToken where
+  smpEncode (DeviceToken p t) = smpEncode (p, t)
+  smpP = DeviceToken <$> smpP <*> smpP
+
+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
+  | -- | NEND received (we currently do not support it)
+    NSEnd
+  | -- | SMP AUTH error
+    NSSMPAuth
+  deriving (Eq, Show)
+
+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"
+    NSEnd -> "END"
+    NSSMPAuth -> "SMP_AUTH"
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "NEW" -> pure NSNew
+      "PENDING" -> pure NSPending
+      "ACTIVE" -> pure NSActive
+      "END" -> pure NSEnd
+      "SMP_AUTH" -> pure NSSMPAuth
+      _ -> fail "bad NtfSubStatus"
+
+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 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

@@ -0,0 +1,330 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Notifications.Server where
+
+import Control.Logger.Simple
+import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Reader
+import Crypto.Random (MonadRandom)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.Text as T
+import Data.Time.Clock.System (getSystemTime)
+import Network.Socket (ServiceName)
+import Simplex.Messaging.Client.Agent
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Env
+import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Server.Store
+import Simplex.Messaging.Notifications.Transport
+import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Server
+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 UnliftIO (async, uninterruptibleCancel)
+import UnliftIO.Concurrent (threadDelay)
+import UnliftIO.Exception
+import UnliftIO.STM
+
+runNtfServer :: (MonadRandom m, MonadUnliftIO m) => NtfServerConfig -> m ()
+runNtfServer cfg = do
+  started <- newEmptyTMVarIO
+  runNtfServerBlocking started cfg
+
+runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfServerConfig -> m ()
+runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
+
+ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
+ntfServer NtfServerConfig {transports} started = do
+  s <- asks subscriber
+  ps <- asks pushServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
+  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) >>= \case
+        Right th -> runNtfClientTransport th
+        Left _ -> pure ()
+
+ntfSubscriber :: forall m. MonadUnliftIO m => NtfSubscriber -> m ()
+ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
+  raceAny_ [subscribe, receiveSMP, receiveAgent]
+  where
+    subscribe :: m ()
+    subscribe = forever $ do
+      atomically (readTBQueue subQ) >>= \case
+        NtfSub NtfSubData {smpQueue} -> do
+          let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue
+          liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
+            Right _ -> pure () -- update subscription status
+            Left _e -> pure ()
+
+    receiveSMP :: m ()
+    receiveSMP = forever $ do
+      (_srv, _sessId, _ntfId, msg) <- atomically $ readTBQueue msgQ
+      case msg of
+        SMP.NMSG -> do
+          -- check when the last NMSG was received from this queue
+          -- update timestamp
+          -- check what was the last hidden notification was sent (and whether to this queue)
+          -- decide whether it should be sent as hidden or visible
+          -- construct and possibly encrypt notification
+          -- send it
+          pure ()
+        _ -> pure ()
+      pure ()
+
+    receiveAgent =
+      forever $
+        atomically (readTBQueue agentQ) >>= \case
+          CAConnected _ -> pure ()
+          CADisconnected _srv _subs -> do
+            -- update subscription statuses
+            pure ()
+          CAReconnected _ -> pure ()
+          CAResubscribed _srv _sub -> do
+            -- update subscription status
+            pure ()
+          CASubError _srv _sub _err -> do
+            -- update subscription status
+            pure ()
+
+ntfPush :: MonadUnliftIO m => NtfPushServer -> m ()
+ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
+  (tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+  logDebug $ "sending push notification to " <> T.pack (show pp)
+  status <- readTVarIO tknStatus
+  case (status, ntf) of
+    (_, PNVerification _) -> do
+      -- TODO check token status
+      deliverNotification pp tkn ntf
+      atomically $ modifyTVar tknStatus $ \status' -> if status' == NTActive then NTActive else NTConfirmed
+    (NTActive, PNCheckMessages) -> do
+      deliverNotification pp tkn ntf
+    _ -> do
+      logError "bad notification token status"
+  where
+    deliverNotification :: PushProvider -> PushProviderClient
+    deliverNotification pp tkn ntf = do
+      deliver <- liftIO $ getPushClient s pp
+      -- TODO retry later based on the error
+      deliver tkn ntf `catchError` \e -> logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e
+
+runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => 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_ ([send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
+    `finally` clientDisconnected c
+  where
+    disconnectThread_ c expCfg = maybe [] ((: []) . disconnectTransport th c activeAt) expCfg
+
+clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
+clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
+
+receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
+receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
+  t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
+  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, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
+send h NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
+  t <- atomically $ readTBQueue sndQ
+  void . liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
+  atomically . writeTVar activeAt =<< liftIO getSystemTime
+
+data VerificationResult = VRVerified NtfRequest | VRFailed
+
+verifyNtfTransmission ::
+  forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => 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
+      pure $ case t_ of
+        Just t@NtfTknData {tknVerifyKey}
+          | verifyCmdSignature sig_ signed tknVerifyKey -> verifiedTknCmd t c
+          | otherwise -> VRFailed
+        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    _ -> pure VRFailed
+  where
+    verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
+
+client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
+client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} 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
+        atomically $ do
+          tkn <- mkNtfTknData tknId newTkn ks dhSecret regCode
+          addNtfToken st tknId tkn
+          writeTBQueue pushQ (tkn, PNVerification regCode)
+        pure (corrId, "", NRId tknId srvDhPubKey)
+      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (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 $ NRId 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
+              pure NROk
+            | otherwise -> do
+              logDebug "TVFY - incorrect code or token status"
+              pure $ NRErr AUTH
+          TCHK -> pure $ NRTkn status
+          TDEL -> do
+            logDebug "TDEL"
+            st <- asks store
+            atomically $ deleteNtfToken st tknId
+            cancelInvervalNotifications tknId
+            pure NROk
+          TCRN 0 -> do
+            logDebug "TCRN 0"
+            cancelInvervalNotifications tknId
+            pure NROk
+          TCRN int
+            | int < 20 -> pure $ NRErr QUOTA
+            | otherwise -> do
+              logDebug "TCRN"
+              atomically (TM.lookup tknId intervalNotifiers) >>= \case
+                Nothing -> runIntervalNotifier int
+                Just IntervalNotifier {interval, action} ->
+                  unless (interval == int) $ do
+                    uninterruptibleCancel action
+                    runIntervalNotifier 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) -> pure (corrId, "", NROk)
+      NtfReqCmd SSubscription _sub (corrId, subId, cmd) ->
+        (corrId,subId,) <$> case cmd of
+          SNEW _newSub -> pure NROk
+          SCHK -> pure NROk
+          SDEL -> 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)
+
+-- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk)
+-- do
+-- st <- asks store
+-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
+-- let dhSecret = C.dh' dhPubKey privDhKey
+-- sub <- atomically $ mkNtfSubsciption smpQueue token verifyKey dhSecret
+-- addSubRetry 3 st sub >>= \case
+--   Nothing -> pure (corrId, "", NRErr INTERNAL)
+--   Just sId -> do
+--     atomically $ writeTBQueue subQ sub
+--     pure (corrId, sId, NRSubId pubDhKey)
+-- where
+--   addSubRetry :: Int -> NtfSubscriptionsStore -> NtfSubsciption -> m (Maybe NtfSubsciptionId)
+--   addSubRetry 0 _ _ = pure Nothing
+--   addSubRetry n st sub = do
+--     sId <- getId
+--     -- create QueueRec record with these ids and keys
+--     atomically (addNtfSub st sId sub) >>= \case
+--       Nothing -> addSubRetry (n - 1) st sub
+--       _ -> pure $ Just sId
+--   getId :: m NtfSubsciptionId
+--   getId = do
+--     n <- asks $ subIdBytes . config
+--     gVar <- asks idsDrg
+--     atomically (randomBytes n gVar)
+-- NReqCommand sub@NtfSubsciption {tokenId, subStatus} (corrId, subId, cmd) ->
+--   (corrId,subId,) <$> case cmd of
+--     NCSubCreate tokenId smpQueue -> pure NROk
+-- do
+--   st <- asks store
+--   (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
+--   let dhSecret = C.dh' (dhPubKey newSub) privDhKey
+--   atomically (updateNtfSub st sub newSub dhSecret) >>= \case
+--     Nothing -> pure $ NRErr INTERNAL
+--     _ -> atomically $ do
+--       whenM ((== NSEnd) <$> readTVar status) $ writeTBQueue subQ sub
+--       pure $ NRSubId pubDhKey
+-- NCSubCheck -> NRStat <$> readTVarIO subStatus
+-- NCSubDelete -> do
+--   st <- asks store
+--   atomically (deleteNtfSub st subId) $> NROk

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

@@ -0,0 +1,140 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Notifications.Server.Env where
+
+import Control.Concurrent.Async (Async)
+import Control.Monad (void)
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.ByteString.Char8 (ByteString)
+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.Store
+import Simplex.Messaging.Protocol (CorrId, 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 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,
+    -- CA certificate private key is not needed for initialization
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: 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,
+    idsDrg :: TVar ChaChaDRG,
+    serverIdentity :: C.KeyHash,
+    tlsServerParams :: T.ServerParams,
+    serverIdentity :: C.KeyHash
+  }
+
+newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
+newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, caCertificateFile, certificateFile, privateKeyFile} = do
+  idsDrg <- newTVarIO =<< drgNew
+  store <- atomically newNtfStore
+  subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
+  pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
+  -- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server
+  void . liftIO $ newPushClient pushServer PPApns
+  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
+  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
+  pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
+
+data NtfSubscriber = NtfSubscriber
+  { subQ :: TBQueue (NtfEntityRec 'Subscription),
+    smpAgent :: SMPClientAgent
+  }
+
+newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
+newNtfSubscriber qSize smpAgentCfg = do
+  smpAgent <- newSMPClientAgent smpAgentCfg
+  subQ <- newTBQueue qSize
+  pure NtfSubscriber {smpAgent, subQ}
+
+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} = \case
+  PPApns -> do
+    c <- apnsPushProviderClient <$> createAPNSPushClient apnsConfig
+    atomically $ TM.insert PPApns 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/Push/.gitignore

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

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

@@ -0,0 +1,349 @@
+{-# 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.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.Text.Encoding (decodeUtf8With)
+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 (NotifierId, SMPServer)
+import Simplex.Messaging.Transport.HTTP2.Client
+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 SMPServer NotifierId
+  | PNAlert Text
+  | PNCheckMessages
+
+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
+  = APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
+  | APNSBackground {contentAvailable :: Int}
+  | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, 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,
+    apnsHost :: HostName,
+    apnsPort :: ServiceName,
+    http2cfg :: HTTP2ClientConfig
+  }
+  deriving (Show)
+
+defaultAPNSPushClientConfig :: APNSPushClientConfig
+defaultAPNSPushClientConfig =
+  APNSPushClientConfig
+    { tokenTTL = 1200, -- 20 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 = 256,
+      appName = "chat.simplex.app",
+      appTeamId = "5NN7GUYB6T",
+      apnsHost = "api.sandbox.push.apple.com",
+      apnsPort = "443",
+      http2cfg = defaultHTTP2ClientConfig
+    }
+
+data APNSPushClient = APNSPushClient
+  { https2Client :: TVar (Maybe HTTP2Client),
+    privateKey :: EC.PrivateKey,
+    jwtHeader :: JWTHeader,
+    jwtToken :: TVar (JWTToken, SignedJWTToken),
+    nonceDrg :: TVar ChaChaDRG,
+    apnsCfg :: APNSPushClientConfig
+  }
+
+createAPNSPushClient :: APNSPushClientConfig -> IO APNSPushClient
+createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
+  https2Client <- newTVarIO Nothing
+  void $ connectHTTPS2 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, 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 :: APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
+connectHTTPS2 APNSPushClientConfig {apnsHost, 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, apnsCfg} =
+  readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right)
+
+disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
+disconnectApnsHTTP2Client APNSPushClient {https2Client} =
+  readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
+
+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 ["verification" .= code', "nonce" .= nonce]
+  PNMessage srv nId ->
+    encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue ->
+      apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue, "nonce" .= nonce]
+  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 some other app event", category = Nothing}
+    apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
+    safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?'
+
+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)
+
+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 PPApns 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

@@ -0,0 +1,26 @@
+#!/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/Store.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Notifications.Server.Store where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.Map.Strict as M
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (whenM, ($>>=))
+
+data NtfStore = NtfStore
+  { tokens :: TMap NtfTokenId NtfTknData,
+    tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId)
+  }
+
+newNtfStore :: STM NtfStore
+newNtfStore = do
+  tokens <- TM.empty
+  tokenRegistrations <- TM.empty
+  pure NtfStore {tokens, tokenRegistrations}
+
+data NtfTknData = NtfTknData
+  { ntfTknId :: NtfTokenId,
+    token :: DeviceToken,
+    tknStatus :: TVar NtfTknStatus,
+    tknVerifyKey :: C.APublicVerifyKey,
+    tknDhKeys :: C.KeyPair 'C.X25519,
+    tknDhSecret :: C.DhSecretX25519,
+    tknRegCode :: NtfRegCode
+  }
+
+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
+  pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode}
+
+-- data NtfSubscriptionsStore = NtfSubscriptionsStore
+
+-- { subscriptions :: TMap NtfSubsciptionId NtfSubsciption,
+--   activeSubscriptions :: TMap (SMPServer, NotifierId) NtfSubsciptionId
+-- }
+-- do
+-- subscriptions <- newTVar M.empty
+-- activeSubscriptions <- newTVar M.empty
+-- pure NtfSubscriptionsStore {subscriptions, activeSubscriptions}
+
+data NtfSubData = NtfSubData
+  { smpQueue :: SMPQueueNtf,
+    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
+      pure $ map snd tIds
+
+deleteNtfToken :: NtfStore -> NtfTokenId -> STM ()
+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
+              )
+      )
+  where
+    regs = tokenRegistrations st
+    regKey = C.toPubKey C.pubKeyBytes
+
+-- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
+-- getNtfRec st ent entId = case ent of
+--   SToken -> NtfTkn <$$> TM.lookup entId (tokens st)
+--   SSubscription -> pure Nothing
+
+-- getNtfVerifyKey :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e, C.APublicVerifyKey))
+-- getNtfVerifyKey st ent entId =
+--   getNtfRec st ent entId >>= \case
+--     Just r@(NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
+--     Just r@(NtfSub NtfSubData {tokenId}) ->
+--       getNtfRec st SToken tokenId >>= \case
+--         Just (NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
+--         _ -> pure Nothing
+--     _ -> pure Nothing
+
+-- mkNtfSubsciption :: SMPQueueNtf -> NtfTokenId -> STM NtfSubsciption
+-- mkNtfSubsciption smpQueue tokenId = do
+--   subStatus <- newTVar NSNew
+--   pure NtfSubsciption {smpQueue, tokenId, subStatus}
+
+-- getNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM (Maybe NtfSubsciption)
+-- getNtfSub st subId = pure Nothing -- maybe (pure $ Left AUTH) (fmap Right . readTVar) . M.lookup subId . subscriptions =<< readTVar st
+
+-- getNtfSubViaSMPQueue :: NtfSubscriptionsStore -> SMPQueueNtf -> STM (Maybe NtfSubsciption)
+-- getNtfSubViaSMPQueue st smpQueue = pure Nothing
+
+-- -- replace keeping status
+-- updateNtfSub :: NtfSubscriptionsStore -> NtfSubsciption -> SMPQueueNtf -> NtfTokenId -> C.DhSecretX25519 -> STM (Maybe ())
+-- updateNtfSub st sub smpQueue tokenId dhSecret = pure Nothing
+
+-- addNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> NtfSubsciption -> STM (Maybe ())
+-- addNtfSub st subId sub = pure Nothing
+
+-- deleteNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM ()
+-- deleteNtfSub st subId = pure ()

src/Simplex/Messaging/Notifications/Transport.hs

@@ -0,0 +1,19 @@
+module Simplex.Messaging.Notifications.Transport where
+
+import Control.Monad.Except
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Transport
+
+ntfBlockSize :: Int
+ntfBlockSize = 512
+
+-- | Notifcations server transport handshake.
+ntfServerHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+ntfServerHandshake c _ = pure $ ntfTHandle c
+
+-- | Notifcations server client transport handshake.
+ntfClientHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+ntfClientHandshake c _ = pure $ ntfTHandle c
+
+ntfTHandle :: Transport c => c -> THandle c
+ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}

src/Simplex/Messaging/Parsers.hs

@@ -1,15 +1,20 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Parsers where
 
+import Control.Monad.Trans.Except
+import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isAlphaNum)
+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)
@@ -21,13 +26,18 @@ import Simplex.Messaging.Util ((<$?>))
 import Text.Read (readMaybe)
 
 base64P :: Parser ByteString
-base64P = decode <$?> base64StringP
+base64P = decode <$?> paddedBase64 rawBase64P
 
-base64StringP :: Parser ByteString
-base64StringP = do
-  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
-  pad <- A.takeWhile (== '=')
-  pure $ str <> pad
+paddedBase64 :: Parser ByteString -> Parser ByteString
+paddedBase64 raw = (<>) <$> raw <*> pad
+  where
+    pad = A.takeWhile (== '=')
+
+rawBase64P :: Parser ByteString
+rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
+
+-- rawBase64UriP :: Parser ByteString
+-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
 
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd
@@ -38,6 +48,12 @@ parse parser err = first (const err) . parseAll parser
 parseAll :: Parser a -> (ByteString -> Either String a)
 parseAll parser = A.parseOnly (parser <* A.endOfInput)
 
+parseE :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)
+parseE err parser = except . first err . parseAll parser
+
+parseE' :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)
+parseE' err parser = except . first err . A.parseOnly parser
+
 parseRead :: Read a => Parser ByteString -> Parser a
 parseRead = (>>= maybe (fail "cannot read") pure . readMaybe . B.unpack)
 
@@ -57,9 +73,63 @@ parseString :: (ByteString -> Either String a) -> (String -> a)
 parseString p = either error id . p . B.pack
 
 blobFieldParser :: Typeable k => Parser k -> FieldParser k
-blobFieldParser p = \case
+blobFieldParser = blobFieldDecoder . parseAll
+
+blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
+blobFieldDecoder dec = \case
   f@(Field (SQLBlob b) _) ->
-    case parseAll p b of
+    case dec b of
       Right k -> Ok k
       Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
   f -> returnError ConversionFailed f "expecting SQLBlob column type"
+
+fromTextField_ :: (Typeable a) => (Text -> Maybe a) -> Field -> Ok a
+fromTextField_ fromText = \case
+  f@(Field (SQLText t) _) ->
+    case fromText t of
+      Just x -> Ok x
+      _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)
+  f -> returnError ConversionFailed f "expecting SQLText column type"
+
+fstToLower :: String -> String
+fstToLower "" = ""
+fstToLower (h : t) = toLower h : t
+
+dropPrefix :: String -> String -> String
+dropPrefix pfx s =
+  let (p, rest) = splitAt (length pfx) s
+   in fstToLower $ if p == pfx then rest else s
+
+enumJSON :: (String -> String) -> J.Options
+enumJSON tagModifier =
+  J.defaultOptions
+    { J.constructorTagModifier = tagModifier,
+      J.allNullaryToStringTag = True
+    }
+
+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.constructorTagModifier = tagModifier,
+      J.allNullaryToStringTag = False,
+      J.nullaryToObject = True,
+      J.omitNothingFields = True
+    }
+
+singleFieldJSON :: (String -> String) -> J.Options
+singleFieldJSON tagModifier =
+  J.defaultOptions
+    { J.sumEncoding = J.ObjectWithSingleField,
+      J.constructorTagModifier = tagModifier,
+      J.allNullaryToStringTag = False,
+      J.nullaryToObject = True,
+      J.omitNothingFields = True
+    }

src/Simplex/Messaging/Protocol.hs

@@ -1,17 +1,26 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 -- |
--- Module      : Simplex.Messaging.Protocol
+-- Module      : Simplex.Messaging.ProtocolEncoding
 -- Copyright   : (c) simplex.chat
 -- License     : AGPL-3
 --
@@ -23,100 +32,166 @@
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Protocol
-  ( -- * SMP protocol types
+  ( -- * SMP protocol parameters
+    smpClientVersion,
+    smpClientVRange,
+    maxMessageLength,
+    e2eEncConfirmationLength,
+    e2eEncMessageLength,
+
+    -- * SMP protocol types
+    ProtocolEncoding (..),
     Command (..),
     Party (..),
     Cmd (..),
+    BrokerMsg (..),
     SParty (..),
+    PartyI (..),
+    QueueIdsKeys (..),
     ErrorType (..),
     CommandError (..),
     Transmission,
     SignedTransmission,
-    SignedTransmissionOrError,
-    RawTransmission,
+    SentRawTransmission,
     SignedRawTransmission,
+    ClientMsgEnvelope (..),
+    PubHeader (..),
+    ClientMessage (..),
+    PrivHeader (..),
+    Protocol (..),
+    ProtocolServer (..),
+    SMPServer,
+    pattern SMPServer,
+    SrvLoc (..),
     CorrId (..),
     QueueId,
     RecipientId,
     SenderId,
-    RecipientPrivateKey,
-    RecipientPublicKey,
-    SenderPrivateKey,
-    SenderPublicKey,
-    Encoded,
+    NotifierId,
+    RcvPrivateSignKey,
+    RcvPublicVerifyKey,
+    RcvPublicDhKey,
+    RcvDhSecret,
+    SndPrivateSignKey,
+    SndPublicVerifyKey,
+    NtfPrivateSignKey,
+    NtfPublicVerifyKey,
     MsgId,
     MsgBody,
 
     -- * Parse and serialize
-    serializeTransmission,
-    serializeCommand,
-    serializeErrorType,
+    ProtocolMsgTag (..),
+    messageTagP,
+    encodeTransmission,
     transmissionP,
-    commandP,
-    errorTypeP,
+    _smpP,
 
     -- * TCP transport functions
     tPut,
     tGet,
-    fromClient,
-    fromServer,
+
+    -- * exports for tests
+    CommandTag (..),
+    BrokerMsgTag (..),
   )
 where
 
-import Control.Applicative ((<|>))
-import Control.Monad
+import Control.Applicative (optional, (<|>))
 import Control.Monad.Except
+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.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
 import Data.Kind
+import Data.Maybe (isNothing)
 import Data.String
-import Data.Time.Clock
-import Data.Time.ISO8601
+import Data.Time.Clock.System (SystemTime)
+import Data.Type.Equality
 import GHC.Generics (Generic)
 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 (THandle, Transport, TransportError (..), tGetEncrypted, tPutEncrypted)
-import Simplex.Messaging.Util
+import Simplex.Messaging.Transport
+import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
--- | SMP protocol participants.
-data Party = Broker | Recipient | Sender
+smpClientVersion :: Version
+smpClientVersion = 1
+
+smpClientVRange :: VersionRange
+smpClientVRange = mkVersionRange 1 smpClientVersion
+
+maxMessageLength :: Int
+maxMessageLength = 16088
+
+-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
+e2eEncConfirmationLength :: Int
+e2eEncConfirmationLength = 15936
+
+e2eEncMessageLength :: Int
+e2eEncMessageLength = 16032
+
+-- | SMP protocol clients
+data Party = Recipient | Sender | Notifier
   deriving (Show)
 
--- | Singleton types for SMP protocol participants.
+-- | Singleton types for SMP protocol clients
 data SParty :: Party -> Type where
-  SBroker :: SParty Broker
   SRecipient :: SParty Recipient
   SSender :: SParty Sender
+  SNotifier :: SParty Notifier
 
-deriving instance Show (SParty a)
+instance TestEquality SParty where
+  testEquality SRecipient SRecipient = Just Refl
+  testEquality SSender SSender = Just Refl
+  testEquality SNotifier SNotifier = Just Refl
+  testEquality _ _ = Nothing
 
--- | Type for command or response of any participant.
-data Cmd = forall a. Cmd (SParty a) (Command a)
+deriving instance Show (SParty p)
+
+class PartyI (p :: Party) where sParty :: SParty p
+
+instance PartyI Recipient where sParty = SRecipient
+
+instance PartyI Sender where sParty = SSender
+
+instance PartyI Notifier where sParty = SNotifier
+
+-- | Type for client command of any participant.
+data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
 
 deriving instance Show Cmd
 
--- | SMP transmission without signature.
-type Transmission = (CorrId, QueueId, Cmd)
+-- | Parsed SMP transmission without signature, size and session ID.
+type Transmission c = (CorrId, EntityId, c)
 
--- | SMP transmission with signature.
-type SignedTransmission = (C.Signature, Transmission)
+-- | signed parsed transmission, with original raw bytes and parsing error.
+type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
 
-type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd)
-
--- | signed parsed transmission, with parsing error.
-type SignedTransmissionOrError = (C.Signature, TransmissionOrError)
+type Signed = ByteString
 
 -- | unparsed SMP transmission with signature.
-type RawTransmission = (ByteString, ByteString, ByteString, ByteString)
+data RawTransmission = RawTransmission
+  { signature :: ByteString,
+    signed :: ByteString,
+    sessId :: SessionId,
+    corrId :: ByteString,
+    entityId :: ByteString,
+    command :: ByteString
+  }
+  deriving (Show)
 
--- | unparsed SMP transmission with signature.
-type SignedRawTransmission = (C.Signature, ByteString)
+-- | unparsed sent SMP transmission with signature, without session ID.
+type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
+
+-- | unparsed sent SMP transmission with signature.
+type SentRawTransmission = (Maybe C.ASignature, ByteString)
 
 -- | SMP queue ID for the recipient.
 type RecipientId = QueueId
@@ -124,62 +199,291 @@ type RecipientId = QueueId
 -- | SMP queue ID for the sender.
 type SenderId = QueueId
 
--- | SMP queue ID on the server.
-type QueueId = Encoded
+-- | SMP queue ID for notifications.
+type NotifierId = QueueId
 
--- | Parameterized type for SMP protocol commands from all participants.
-data Command (a :: Party) where
+-- | SMP queue ID on the server.
+type QueueId = EntityId
+
+type EntityId = ByteString
+
+-- | Parameterized type for SMP protocol commands from all clients.
+data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RecipientPublicKey -> Command Recipient
+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
   SUB :: Command Recipient
-  KEY :: SenderPublicKey -> Command Recipient
+  KEY :: SndPublicVerifyKey -> Command Recipient
+  NKEY :: NtfPublicVerifyKey -> Command Recipient
   ACK :: Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
   -- SMP sender commands
   SEND :: MsgBody -> Command Sender
   PING :: Command Sender
-  -- SMP broker commands (responses, messages, notifications)
-  IDS :: RecipientId -> SenderId -> Command Broker
-  MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker
-  END :: Command Broker
-  OK :: Command Broker
-  ERR :: ErrorType -> Command Broker
-  PONG :: Command Broker
+  -- SMP notification subscriber commands
+  NSUB :: Command Notifier
 
-deriving instance Show (Command a)
+deriving instance Show (Command p)
 
-deriving instance Eq (Command a)
+deriving instance Eq (Command p)
 
--- | Base-64 encoded string.
-type Encoded = ByteString
+data BrokerMsg where
+  -- SMP broker messages (responses, client messages, notifications)
+  IDS :: QueueIdsKeys -> BrokerMsg
+  MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
+  NID :: NotifierId -> BrokerMsg
+  NMSG :: BrokerMsg
+  END :: BrokerMsg
+  OK :: BrokerMsg
+  ERR :: ErrorType -> BrokerMsg
+  PONG :: BrokerMsg
+  deriving (Eq, Show)
+
+-- * SMP command tags
+
+data CommandTag (p :: Party) where
+  NEW_ :: CommandTag Recipient
+  SUB_ :: CommandTag Recipient
+  KEY_ :: CommandTag Recipient
+  NKEY_ :: CommandTag Recipient
+  ACK_ :: CommandTag Recipient
+  OFF_ :: CommandTag Recipient
+  DEL_ :: CommandTag Recipient
+  SEND_ :: CommandTag Sender
+  PING_ :: CommandTag Sender
+  NSUB_ :: CommandTag Notifier
+
+data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p)
+
+deriving instance Show (CommandTag p)
+
+deriving instance Show CmdTag
+
+data BrokerMsgTag
+  = IDS_
+  | MSG_
+  | NID_
+  | NMSG_
+  | END_
+  | OK_
+  | ERR_
+  | PONG_
+  deriving (Show)
+
+class ProtocolMsgTag t where
+  decodeTag :: ByteString -> Maybe t
+
+messageTagP :: ProtocolMsgTag t => Parser t
+messageTagP =
+  maybe (fail "bad message") pure . decodeTag
+    =<< (A.takeTill (== ' ') <* optional A.space)
+
+instance PartyI p => Encoding (CommandTag p) where
+  smpEncode = \case
+    NEW_ -> "NEW"
+    SUB_ -> "SUB"
+    KEY_ -> "KEY"
+    NKEY_ -> "NKEY"
+    ACK_ -> "ACK"
+    OFF_ -> "OFF"
+    DEL_ -> "DEL"
+    SEND_ -> "SEND"
+    PING_ -> "PING"
+    NSUB_ -> "NSUB"
+  smpP = messageTagP
+
+instance ProtocolMsgTag CmdTag where
+  decodeTag = \case
+    "NEW" -> Just $ CT SRecipient NEW_
+    "SUB" -> Just $ CT SRecipient SUB_
+    "KEY" -> Just $ CT SRecipient KEY_
+    "NKEY" -> Just $ CT SRecipient NKEY_
+    "ACK" -> Just $ CT SRecipient ACK_
+    "OFF" -> Just $ CT SRecipient OFF_
+    "DEL" -> Just $ CT SRecipient DEL_
+    "SEND" -> Just $ CT SSender SEND_
+    "PING" -> Just $ CT SSender PING_
+    "NSUB" -> Just $ CT SNotifier NSUB_
+    _ -> Nothing
+
+instance Encoding CmdTag where
+  smpEncode (CT _ t) = smpEncode t
+  smpP = messageTagP
+
+instance PartyI p => ProtocolMsgTag (CommandTag p) where
+  decodeTag s = decodeTag s >>= (\(CT _ t) -> checkParty' t)
+
+instance Encoding BrokerMsgTag where
+  smpEncode = \case
+    IDS_ -> "IDS"
+    MSG_ -> "MSG"
+    NID_ -> "NID"
+    NMSG_ -> "NMSG"
+    END_ -> "END"
+    OK_ -> "OK"
+    ERR_ -> "ERR"
+    PONG_ -> "PONG"
+  smpP = messageTagP
+
+instance ProtocolMsgTag BrokerMsgTag where
+  decodeTag = \case
+    "IDS" -> Just IDS_
+    "MSG" -> Just MSG_
+    "NID" -> Just NID_
+    "NMSG" -> Just NMSG_
+    "END" -> Just END_
+    "OK" -> Just OK_
+    "ERR" -> Just ERR_
+    "PONG" -> Just PONG_
+    _ -> Nothing
+
+-- | SMP message body format
+data ClientMsgEnvelope = ClientMsgEnvelope
+  { cmHeader :: PubHeader,
+    cmNonce :: C.CbNonce,
+    cmEncBody :: ByteString
+  }
+  deriving (Show)
+
+data PubHeader = PubHeader
+  { phVersion :: Version,
+    phE2ePubDhKey :: Maybe C.PublicKeyX25519
+  }
+  deriving (Show)
+
+instance Encoding PubHeader where
+  smpEncode (PubHeader v k) = smpEncode (v, k)
+  smpP = PubHeader <$> smpP <*> smpP
+
+instance Encoding ClientMsgEnvelope where
+  smpEncode ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody} =
+    smpEncode (cmHeader, cmNonce, Tail cmEncBody)
+  smpP = do
+    (cmHeader, cmNonce, Tail cmEncBody) <- smpP
+    pure ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
+
+data ClientMessage = ClientMessage PrivHeader ByteString
+
+data PrivHeader
+  = PHConfirmation C.APublicVerifyKey
+  | PHEmpty
+  deriving (Show)
+
+instance Encoding PrivHeader where
+  smpEncode = \case
+    PHConfirmation k -> "K" <> smpEncode k
+    PHEmpty -> "_"
+  smpP =
+    A.anyChar >>= \case
+      'K' -> PHConfirmation <$> smpP
+      '_' -> pure PHEmpty
+      _ -> fail "invalid PrivHeader"
+
+instance Encoding ClientMessage where
+  smpEncode (ClientMessage h msg) = smpEncode h <> msg
+  smpP = ClientMessage <$> smpP <*> A.takeByteString
+
+type SMPServer = ProtocolServer
+
+pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer
+pattern SMPServer host port keyHash = ProtocolServer host port keyHash
+
+{-# COMPLETE SMPServer #-}
+
+-- | SMP server location and transport key digest (hash).
+data ProtocolServer = ProtocolServer
+  { host :: HostName,
+    port :: ServiceName,
+    keyHash :: C.KeyHash
+  }
+  deriving (Eq, Ord, Show)
+
+instance IsString ProtocolServer where
+  fromString = parseString strDecode
+
+instance Encoding ProtocolServer where
+  smpEncode ProtocolServer {host, port, keyHash} =
+    smpEncode (host, port, keyHash)
+  smpP = do
+    (host, port, keyHash) <- smpP
+    pure ProtocolServer {host, port, keyHash}
+
+instance StrEncoding ProtocolServer where
+  strEncode ProtocolServer {host, port, keyHash} =
+    "smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
+  strP = do
+    _ <- "smp://"
+    keyHash <- strP <* A.char '@'
+    SrvLoc host port <- strP
+    pure ProtocolServer {host, port, keyHash}
+
+instance ToJSON ProtocolServer where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+data SrvLoc = SrvLoc HostName ServiceName
+  deriving (Eq, Ord, Show)
+
+instance StrEncoding SrvLoc where
+  strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port
+  strP = SrvLoc <$> host <*> (port <|> pure "")
+    where
+      host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
+      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
 
 -- | Transmission correlation ID.
---
--- A newtype to avoid accidentally changing order of transmission parts.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
 
 instance IsString CorrId where
   fromString = CorrId . fromString
 
+instance StrEncoding CorrId where
+  strEncode (CorrId cId) = strEncode cId
+  strDecode s = CorrId <$> strDecode s
+  strP = CorrId <$> strP
+
+instance ToJSON CorrId where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+-- | Queue IDs and keys
+data QueueIdsKeys = QIK
+  { rcvId :: RecipientId,
+    sndId :: SenderId,
+    rcvPublicDhKey :: RcvPublicDhKey
+  }
+  deriving (Eq, Show)
+
 -- | Recipient's private key used by the recipient to authorize (sign) SMP commands.
 --
 -- Only used by SMP agent, kept here so its definition is close to respective public key.
-type RecipientPrivateKey = C.SafePrivateKey
+type RcvPrivateSignKey = C.APrivateSignKey
 
 -- | Recipient's public key used by SMP server to verify authorization of SMP commands.
-type RecipientPublicKey = C.PublicKey
+type RcvPublicVerifyKey = C.APublicVerifyKey
+
+-- | Public key used for DH exchange to encrypt message bodies from server to recipient
+type RcvPublicDhKey = C.PublicKeyX25519
+
+-- | DH Secret used to encrypt message bodies from server to recipient
+type RcvDhSecret = C.DhSecretX25519
 
 -- | Sender's private key used by the recipient to authorize (sign) SMP commands.
 --
 -- Only used by SMP agent, kept here so its definition is close to respective public key.
-type SenderPrivateKey = C.SafePrivateKey
+type SndPrivateSignKey = C.APrivateSignKey
 
 -- | Sender's public key used by SMP server to verify authorization of SMP commands.
-type SenderPublicKey = C.PublicKey
+type SndPublicVerifyKey = C.APublicVerifyKey
+
+-- | 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 LSTN command sent by push notifications server.
+type NtfPublicVerifyKey = C.APublicVerifyKey
 
 -- | SMP message server ID.
-type MsgId = Encoded
+type MsgId = ByteString
 
 -- | SMP message body.
 type MsgBody = ByteString
@@ -188,36 +492,52 @@ type MsgBody = ByteString
 data ErrorType
   = -- | incorrect block format, encoding or signature size
     BLOCK
+  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
+    SESSION
   | -- | SMP command is unknown or has invalid syntax
-    CMD CommandError
+    CMD {cmdErr :: CommandError}
   | -- | command authorization error - bad signature or non-existing SMP queue
     AUTH
   | -- | SMP queue capacity is exceeded on the server
     QUOTA
   | -- | ACK command is sent without message to be acknowledged
     NO_MSG
+  | -- | sent message is too large (> maxMessageLength = 16078 bytes)
+    LARGE_MSG
   | -- | internal server error
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
     DUPLICATE_ -- TODO remove, not part of SMP protocol
   deriving (Eq, Generic, Read, Show)
 
+instance ToJSON ErrorType where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
+instance StrEncoding ErrorType where
+  strEncode = \case
+    CMD e -> "CMD " <> bshow e
+    e -> bshow e
+  strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
+
 -- | SMP command error type.
 data CommandError
-  = -- | server response sent from client or vice versa
-    PROHIBITED
-  | -- | bad RSA key size in NEW or KEY commands (only 1024, 2048 and 4096 bits keys are allowed)
-    KEY_SIZE
+  = -- | unknown command
+    UNKNOWN
   | -- | error parsing command
     SYNTAX
   | -- | 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 queue ID
-    NO_QUEUE
+  | -- | transmission has no required entity ID (e.g. SMP queue)
+    NO_ENTITY
   deriving (Eq, Generic, Read, Show)
 
+instance ToJSON CommandError where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
 instance Arbitrary ErrorType where arbitrary = genericArbitraryU
 
 instance Arbitrary CommandError where arbitrary = genericArbitraryU
@@ -225,156 +545,228 @@ instance Arbitrary CommandError where arbitrary = genericArbitraryU
 -- | SMP transmission parser.
 transmissionP :: Parser RawTransmission
 transmissionP = do
-  signature <- segment
-  corrId <- segment
-  queueId <- segment
-  command <- A.takeByteString
-  return (signature, corrId, queueId, command)
+  signature <- smpP
+  signed <- A.takeByteString
+  either fail pure $ parseAll (trn signature signed) signed
   where
-    segment = A.takeTill (== ' ') <* " "
+    trn signature signed = do
+      sessId <- smpP
+      corrId <- smpP
+      entityId <- smpP
+      command <- A.takeByteString
+      pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
 
--- | SMP command parser.
-commandP :: Parser Cmd
-commandP =
-  "NEW " *> newCmd
-    <|> "IDS " *> idsResp
-    <|> "SUB" $> Cmd SRecipient SUB
-    <|> "KEY " *> keyCmd
-    <|> "ACK" $> Cmd SRecipient ACK
-    <|> "OFF" $> Cmd SRecipient OFF
-    <|> "DEL" $> Cmd SRecipient DEL
-    <|> "SEND " *> sendCmd
-    <|> "PING" $> Cmd SSender PING
-    <|> "MSG " *> message
-    <|> "END" $> Cmd SBroker END
-    <|> "OK" $> Cmd SBroker OK
-    <|> "ERR " *> serverError
-    <|> "PONG" $> Cmd SBroker PONG
-  where
-    newCmd = Cmd SRecipient . NEW <$> C.pubKeyP
-    idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P)
-    keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP
-    sendCmd = do
-      size <- A.decimal <* A.space
-      Cmd SSender . SEND <$> A.take size <* A.space
-    message = do
-      msgId <- base64P <* A.space
-      ts <- tsISO8601P <* A.space
-      size <- A.decimal <* A.space
-      Cmd SBroker . MSG msgId ts <$> A.take size <* A.space
-    serverError = Cmd SBroker . ERR <$> errorTypeP
+class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
+  type ProtocolCommand msg = cmd | cmd -> msg
+  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+  protocolPing :: ProtocolCommand msg
+  protocolError :: msg -> Maybe ErrorType
 
--- TODO ignore the end of block, no need to parse it
+instance Protocol BrokerMsg where
+  type ProtocolCommand BrokerMsg = Cmd
+  protocolClientHandshake = smpClientHandshake
+  protocolPing = Cmd SSender PING
+  protocolError = \case
+    ERR e -> Just e
+    _ -> Nothing
 
--- | Parse SMP command.
-parseCommand :: ByteString -> Either ErrorType Cmd
-parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX
+class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
+  type Tag msg
+  encodeProtocol :: msg -> ByteString
+  protocolP :: Tag msg -> Parser msg
+  checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
 
--- | Serialize SMP command.
-serializeCommand :: Cmd -> ByteString
-serializeCommand = \case
-  Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey
-  Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey
-  Cmd SRecipient cmd -> bshow cmd
-  Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody
-  Cmd SSender PING -> "PING"
-  Cmd SBroker (MSG msgId ts msgBody) ->
-    B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody]
-  Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId]
-  Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err
-  Cmd SBroker resp -> bshow resp
-  where
-    serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " "
+instance PartyI p => ProtocolEncoding (Command p) where
+  type Tag (Command p) = CommandTag p
+  encodeProtocol = \case
+    NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
+    SUB -> e SUB_
+    KEY k -> e (KEY_, ' ', k)
+    NKEY k -> e (NKEY_, ' ', k)
+    ACK -> e ACK_
+    OFF -> e OFF_
+    DEL -> e DEL_
+    SEND msg -> e (SEND_, ' ', Tail msg)
+    PING -> e PING_
+    NSUB -> e NSUB_
+    where
+      e :: Encoding a => a -> ByteString
+      e = smpEncode
 
--- | SMP error parser.
-errorTypeP :: Parser ErrorType
-errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
+  protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag)
 
--- | Serialize SMP error.
-serializeErrorType :: ErrorType -> ByteString
-serializeErrorType = bshow
+  checkCredentials (sig, _, queueId, _) cmd = case cmd of
+    -- NEW must have signature but NOT queue ID
+    NEW {}
+      | isNothing sig -> Left $ CMD NO_AUTH
+      | 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
+      | otherwise -> Right cmd
+    -- PING must not have queue ID or signature
+    PING
+      | isNothing sig && B.null queueId -> Right cmd
+      | otherwise -> Left $ CMD HAS_AUTH
+    -- other client commands must have both signature and queue ID
+    _
+      | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
+      | otherwise -> Right cmd
+
+instance ProtocolEncoding Cmd where
+  type Tag Cmd = CmdTag
+  encodeProtocol (Cmd _ c) = encodeProtocol c
+
+  protocolP = \case
+    CT SRecipient tag ->
+      Cmd SRecipient <$> case tag of
+        NEW_ -> NEW <$> _smpP <*> smpP
+        SUB_ -> pure SUB
+        KEY_ -> KEY <$> _smpP
+        NKEY_ -> NKEY <$> _smpP
+        ACK_ -> pure ACK
+        OFF_ -> pure OFF
+        DEL_ -> pure DEL
+    CT SSender tag ->
+      Cmd SSender <$> case tag of
+        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
+  type Tag BrokerMsg = BrokerMsgTag
+  encodeProtocol = \case
+    IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
+    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)
+    PONG -> e PONG_
+    where
+      e :: Encoding a => a -> ByteString
+      e = smpEncode
+
+  protocolP = \case
+    MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP)
+    IDS_ -> IDS <$> (QIK <$> _smpP <*> 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 _ -> Right cmd
+    -- ERR response does not always have queue ID
+    ERR _ -> Right cmd
+    -- PONG response must not have queue ID
+    PONG
+      | B.null queueId -> Right cmd
+      | otherwise -> Left $ CMD HAS_AUTH
+    -- other broker responses must have queue ID
+    _
+      | B.null queueId -> Left $ CMD NO_ENTITY
+      | otherwise -> Right cmd
+
+_smpP :: Encoding a => Parser a
+_smpP = A.space *> smpP
+
+-- | Parse SMP protocol commands and broker messages
+parseProtocol :: ProtocolEncoding msg => ByteString -> Either ErrorType msg
+parseProtocol s =
+  let (tag, params) = B.break (== ' ') s
+   in case decodeTag tag of
+        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)
+checkParty c = case testEquality (sParty @p) (sParty @p') of
+  Just Refl -> Right c
+  Nothing -> Left "bad command party"
+
+checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)
+checkParty' c = case testEquality (sParty @p) (sParty @p') of
+  Just Refl -> Just c
+  _ -> Nothing
+
+instance Encoding ErrorType where
+  smpEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
+    CMD err -> "CMD " <> smpEncode err
+    AUTH -> "AUTH"
+    QUOTA -> "QUOTA"
+    NO_MSG -> "NO_MSG"
+    LARGE_MSG -> "LARGE_MSG"
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
+
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "BLOCK" -> pure BLOCK
+      "SESSION" -> pure SESSION
+      "CMD" -> CMD <$> _smpP
+      "AUTH" -> pure AUTH
+      "QUOTA" -> pure QUOTA
+      "NO_MSG" -> pure NO_MSG
+      "LARGE_MSG" -> pure LARGE_MSG
+      "INTERNAL" -> pure INTERNAL
+      "DUPLICATE_" -> pure DUPLICATE_
+      _ -> fail "bad error type"
+
+instance Encoding CommandError where
+  smpEncode e = case e of
+    UNKNOWN -> "UNKNOWN"
+    SYNTAX -> "SYNTAX"
+    NO_AUTH -> "NO_AUTH"
+    HAS_AUTH -> "HAS_AUTH"
+    NO_ENTITY -> "NO_ENTITY"
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "UNKNOWN" -> pure UNKNOWN
+      "SYNTAX" -> pure SYNTAX
+      "NO_AUTH" -> pure NO_AUTH
+      "HAS_AUTH" -> pure HAS_AUTH
+      "NO_ENTITY" -> pure NO_ENTITY
+      "NO_QUEUE" -> pure NO_ENTITY
+      _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> SignedRawTransmission -> IO (Either TransportError ())
-tPut th (C.Signature sig, t) =
-  tPutEncrypted th $ encode sig <> " " <> t <> " "
+tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
+tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
 
--- | Serialize SMP transmission.
-serializeTransmission :: Transmission -> ByteString
-serializeTransmission (CorrId corrId, queueId, command) =
-  B.intercalate " " [corrId, encode queueId, serializeCommand command]
+encodeTransmission :: ProtocolEncoding c => ByteString -> Transmission c -> ByteString
+encodeTransmission sessionId (CorrId corrId, queueId, command) =
+  smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
 
--- | Validate that it is an SMP client command, used with 'tGet' by 'Simplex.Messaging.Server'.
-fromClient :: Cmd -> Either ErrorType Cmd
-fromClient = \case
-  Cmd SBroker _ -> Left $ CMD PROHIBITED
-  cmd -> Right cmd
-
--- | Validate that it is an SMP server command, used with 'tGet' by 'Simplex.Messaging.Client'.
-fromServer :: Cmd -> Either ErrorType Cmd
-fromServer = \case
-  cmd@(Cmd SBroker _) -> Right cmd
-  _ -> Left $ CMD PROHIBITED
-
--- | Receive and parse transmission from the TCP transport.
+-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
 tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
-tGetParse th = (>>= parse transmissionP TEBadBlock) <$> tGetEncrypted th
+tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
 
--- | Receive client and server transmissions.
---
--- The first argument is used to limit allowed senders.
--- 'fromClient' or 'fromServer' should be used here.
-tGet :: forall c m. (Transport c, MonadIO m) => (Cmd -> Either ErrorType Cmd) -> THandle c -> m SignedTransmissionOrError
-tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate
+-- | Receive client and server transmissions (determined by `cmd` type).
+tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
+tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
   where
-    decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError
+    decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case
-      Right (signature, corrId, queueId, command) ->
-        let decodedTransmission = liftM2 (,corrId,,command) (validSig =<< decode signature) (decode queueId)
-         in either (const $ tError corrId) tParseValidate decodedTransmission
+      Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
+        | sessId == sessionId ->
+          let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
+           in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
+        | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
       Left _ -> tError ""
 
-    validSig :: ByteString -> Either String ByteString
-    validSig sig
-      | B.null sig || C.validKeySize (B.length sig) = Right sig
-      | otherwise = Left "invalid signature size"
+    tError :: ByteString -> m (SignedTransmission cmd)
+    tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
 
-    tError :: ByteString -> m SignedTransmissionOrError
-    tError corrId = return (C.Signature "", (CorrId corrId, "", Left BLOCK))
-
-    tParseValidate :: RawTransmission -> m SignedTransmissionOrError
-    tParseValidate t@(sig, corrId, queueId, command) = do
-      let cmd = parseCommand command >>= fromParty >>= tCredentials t
-      return (C.Signature sig, (CorrId corrId, queueId, cmd))
-
-    tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
-    tCredentials (signature, _, queueId, _) cmd = case cmd of
-      -- IDS response must not have queue ID
-      Cmd SBroker (IDS _ _) -> Right cmd
-      -- ERR response does not always have queue ID
-      Cmd SBroker (ERR _) -> Right cmd
-      -- PONG response must not have queue ID
-      Cmd SBroker PONG
-        | B.null queueId -> Right cmd
-        | otherwise -> Left $ CMD HAS_AUTH
-      -- other responses must have queue ID
-      Cmd SBroker _
-        | B.null queueId -> Left $ CMD NO_QUEUE
-        | otherwise -> Right cmd
-      -- NEW must have signature but NOT queue ID
-      Cmd SRecipient (NEW _)
-        | B.null signature -> Left $ CMD NO_AUTH
-        | not (B.null queueId) -> Left $ CMD HAS_AUTH
-        | otherwise -> Right cmd
-      -- SEND must have queue ID, signature is not always required
-      Cmd SSender (SEND _)
-        | B.null queueId -> Left $ CMD NO_QUEUE
-        | otherwise -> Right cmd
-      -- PING must not have queue ID or signature
-      Cmd SSender PING
-        | B.null queueId && B.null signature -> Right cmd
-        | otherwise -> Left $ CMD HAS_AUTH
-      -- other client commands must have both signature and queue ID
-      Cmd SRecipient _
-        | B.null signature || B.null queueId -> Left $ CMD NO_AUTH
-        | otherwise -> Right cmd
+    tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
+    tParseValidate signed t@(sig, corrId, entityId, command) = do
+      let cmd = parseProtocol command >>= checkCredentials t
+      pure (sig, signed, (CorrId corrId, entityId, cmd))

src/Simplex/Messaging/Server.hs

@@ -5,7 +5,9 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -23,9 +25,16 @@
 -- 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) where
+module Simplex.Messaging.Server
+  ( runSMPServer,
+    runSMPServerBlocking,
+    disconnectTransport,
+    verifyCmdSignature,
+    dummyVerifyCmd,
+  )
+where
 
-import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
@@ -34,20 +43,36 @@ import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.List (intercalate)
 import qualified Data.Map.Strict as M
-import Data.Time.Clock
+import Data.Maybe (isNothing)
+import Data.Set (Set)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Type.Equality
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
+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.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.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
+import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
@@ -65,161 +90,279 @@ 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 :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
-runSMPServerBlocking started cfg@ServerConfig {transports} = do
-  env <- newEnv cfg
-  runReaderT smpServer env
+runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
+
+smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m ()
+smpServer started = do
+  s <- asks server
+  cfg@ServerConfig {transports} <- asks config
+  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)
   where
-    smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
-    smpServer = do
-      s <- asks server
-      raceAny_ (serverThread s : map runServer transports)
-        `finally` withLog closeStoreLog
+    runServer :: (ServiceName, ATransport) -> m ()
+    runServer (tcpPort, ATransport t) = do
+      serverParams <- asks tlsServerParams
+      runTransportServer started tcpPort serverParams (runClient t)
 
-    runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
-    runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t)
+    serverThread ::
+      forall s.
+      Server ->
+      (Server -> TBQueue (QueueId, Client)) ->
+      (Server -> TMap QueueId Client) ->
+      (Client -> TMap QueueId s) ->
+      (s -> m ()) ->
+      m ()
+    serverThread s subQ subs clientSubs unsub = forever $ do
+      atomically updateSubscribers
+        $>>= endPreviousSubscriptions
+        >>= mapM_ unsub
+      where
+        updateSubscribers :: STM (Maybe (QueueId, Client))
+        updateSubscribers = do
+          (qId, clnt) <- readTBQueue $ subQ s
+          let clientToBeNotified = \c' ->
+                if sameClientSession clnt c'
+                  then pure Nothing
+                  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)
+        endPreviousSubscriptions (qId, c) = do
+          void . forkIO . atomically $
+            writeTBQueue (sndQ c) (CorrId "", qId, END)
+          atomically $ TM.lookupDelete qId (clientSubs c)
 
-    serverThread :: MonadUnliftIO m' => Server -> m' ()
-    serverThread Server {subscribedQ, subscribers} = forever . atomically $ do
-      (rId, clnt) <- readTBQueue subscribedQ
-      cs <- readTVar subscribers
-      case M.lookup rId cs of
-        Just Client {rcvQ} -> writeTBQueue rcvQ (CorrId B.empty, rId, Cmd SBroker END)
-        Nothing -> return ()
-      writeTVar subscribers $ M.insert rId clnt cs
+    expireMessagesThread_ :: ServerConfig -> [m ()]
+    expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
+    expireMessagesThread_ _ = []
 
-runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
-runClient _ h = do
-  keyPair <- asks serverKeyPair
-  ServerConfig {blockSize} <- asks config
-  liftIO (runExceptT $ serverHandshake h blockSize keyPair) >>= \case
-    Right th -> runClientTransport th
-    Left _ -> pure ()
+    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} =
+      [logServerStats logStatsStartTime interval]
+    serverStatsThread_ _ = []
+
+    logServerStats :: Int -> Int -> m ()
+    logServerStats startAt logInterval = do
+      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
+      logInfo $ "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
+      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
+      let interval = 1000000 * logInterval
+      forever $ do
+        ts <- liftIO 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
+        let day = utctDay ts
+            (_, wDay) = mondayStartWeek day
+            MonthDay _ mDay = day
+        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
+          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
+        logInfo . T.pack $ intercalate "," [show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
+        threadDelay interval
+      where
+        periodCount :: Int -> TVar (Set RecipientId) -> STM String
+        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
+        periodCount _ _ = pure ""
+
+    runClient :: Transport c => TProxy c -> c -> m ()
+    runClient _ h = do
+      kh <- asks serverIdentity
+      liftIO (runExceptT $ smpServerHandshake h kh) >>= \case
+        Right th -> runClientTransport th
+        Left _ -> pure ()
 
 runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
-runClientTransport th = do
+runClientTransport th@THandle {sessionId} = do
   q <- asks $ tbqSize . config
-  c <- atomically $ newClient q
+  ts <- liftIO getSystemTime
+  c <- atomically $ newClient q sessionId ts
   s <- asks server
-  raceAny_ [send th c, client c s, receive th c]
-    `finally` cancelSubscribers c
+  expCfg <- asks $ inactiveClientExpiration . config
+  raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
+    `finally` clientDisconnected c
+  where
+    disconnectThread_ c (Just expCfg) = [disconnectTransport th c activeAt expCfg]
+    disconnectThread_ _ _ = []
 
-cancelSubscribers :: MonadUnliftIO m => Client -> m ()
-cancelSubscribers Client {subscriptions} =
-  readTVarIO subscriptions >>= mapM_ cancelSub
+clientDisconnected :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
+clientDisconnected c@Client {subscriptions, connected} = do
+  atomically $ writeTVar connected False
+  subs <- readTVarIO subscriptions
+  mapM_ cancelSub subs
+  atomically $ writeTVar subscriptions M.empty
+  cs <- asks $ subscribers . server
+  atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
+  where
+    deleteCurrentClient :: Client -> Maybe Client
+    deleteCurrentClient c'
+      | sameClientSession c c' = Nothing
+      | otherwise = Just c'
+
+sameClientSession :: Client -> Client -> Bool
+sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
 cancelSub :: MonadUnliftIO m => Sub -> m ()
 cancelSub = \case
-  Sub {subThread = SubThread t} -> killThread t
+  Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
   _ -> return ()
 
 receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
-receive h Client {rcvQ} = forever $ do
-  (signature, (corrId, queueId, cmdOrError)) <- tGet fromClient h
-  t <- case cmdOrError of
-    Left e -> return . mkResp corrId queueId $ ERR e
-    Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd))
-  atomically $ writeTBQueue rcvQ t
+receive th Client {rcvQ, sndQ, activeAt} = forever $ do
+  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
+  atomically . writeTVar activeAt =<< liftIO getSystemTime
+  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
+    write q t = atomically $ writeTBQueue q t
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
-send h Client {sndQ} = forever $ do
+send h Client {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  liftIO $ tPut h ("", serializeTransmission t)
+  -- TODO the line below can return Left, but we ignore it and do not disconnect the client
+  void . liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
+  atomically . writeTVar activeAt =<< liftIO getSystemTime
 
-mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission
-mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command)
+disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
+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
 
-verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTransmission -> m Transmission
-verifyTransmission (sig, t@(corrId, queueId, cmd)) = do
-  (corrId,queueId,) <$> case cmd of
-    Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used
-    Cmd SRecipient (NEW k) -> pure $ verifySignature k
-    Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
-    Cmd SSender (SEND _) -> verifyCmd SSender $ verifySend sig . senderKey
-    Cmd SSender PING -> return cmd
+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 $ verifyCmdSignature sig_ signed k
+    Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . 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 -> Cmd) -> m Cmd
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
     verifyCmd party f = do
       st <- asks queueStore
       q <- atomically $ getQueue st party queueId
-      pure $ either (const $ dummyVerify authErr) f q
-    verifySend :: C.Signature -> Maybe SenderPublicKey -> Cmd
-    verifySend "" = maybe cmd (const authErr)
-    verifySend _ = maybe authErr verifySignature
-    verifySignature :: C.PublicKey -> Cmd
-    verifySignature key = if verify key then cmd else authErr
-    verify key
-      | C.publicKeySize key == sigLen = cryptoVerify key
-      | otherwise = dummyVerify False
-    cryptoVerify key = C.verify key sig (serializeTransmission t)
-    smpErr = Cmd SBroker . ERR
-    authErr = smpErr AUTH
-    dummyVerify :: a -> a
-    dummyVerify = seq $
-      cryptoVerify $ case sigLen of
-        128 -> dummyKey128
-        256 -> dummyKey256
-        384 -> dummyKey384
-        512 -> dummyKey512
-        _ -> dummyKey256
-    sigLen = B.length $ C.unSignature sig
+      pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
+    verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
+    verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
+
+verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
+verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
+  where
+    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
 
 -- 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
-dummyKey128 :: C.PublicKey
-dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw=="
+dummyPublicKey :: C.Signature a -> C.PublicKey a
+dummyPublicKey = \case
+  C.SignatureEd25519 _ -> dummyKeyEd25519
+  C.SignatureEd448 _ -> dummyKeyEd448
 
-dummyKey256 :: C.PublicKey
-dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9"
+dummyKeyEd25519 :: C.PublicKey 'C.Ed25519
+dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
 
-dummyKey384 :: C.PublicKey
-dummyKey384 = "MIICITANBgkqhkiG9w0BAQEFAAOCAg4AMIICCQKCAYEAthExp77lSFBMB0RedjgKIU+oNH5lMGdMqDCG0E5Ly7X49rFpfDMMN08GDIgvzg9kcwV3ScbPcjUE19wmAShX9f9k3w38KM3wmIBKSiuCREQl0V3xAYp1SYwiAkMNSSwxuIkDEeSOR56WdEcZvqbB4lY9MQlUv70KriPDxZaqKCTKslUezXHQuYPQX6eMnGFK7hxz5Kl5MajV52d+5iXsa8CA+m/e1KVnbelCO+xhN89xG8ALt0CJ9k5Wwo3myLgXi4dmNankCmg8jkh+7y2ywkzxMwH1JydDtV/FLzkbZsbPR2w93TNrTq1RJOuqMyh0VtdBSpxNW/Ft988TkkX2BAWzx82INw7W6/QbHGNtHNB995R4sgeYy8QbEpNGBhQnfQh7yRWygLTVXWKApQzzfCeIoDDWUS7dMv/zXoasAnpDBj+6UhHv3BHrps7kBvRyZQ2d/nUuAqiGd43ljJ++n6vNyFLgZoiV7HLia/FOGMkdt7j92CNmFHxiT6Xl7kRHAoGBAPNoWny2O7LBxzAKMLmQVHBAiKp6RMx+7URvtQDHDHPaZ7F3MvtvmYWwGzund3cQFAaV1EkJoYeI3YRuj6xdXgMyMaP54On++btArb6jUtZuvlC98qE8dEEHQNh+7TsCiMU+ivbeKFxS9A/B7OVedoMnPoJWhatbA9zB/6L1GNPh"
-
-dummyKey512 :: C.PublicKey
-dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ=="
+dummyKeyEd448 :: C.PublicKey 'C.Ed448
+dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
+client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: Transmission -> m Transmission
+    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
     processCommand (corrId, queueId, cmd) = do
       st <- asks queueStore
       case cmd of
-        Cmd SBroker END -> unsubscribeQueue $> (corrId, queueId, cmd)
-        Cmd SBroker _ -> return (corrId, queueId, cmd)
-        Cmd SSender command -> case command of
-          SEND msgBody -> sendMessage st msgBody
-          PING -> return (corrId, queueId, Cmd SBroker PONG)
-        Cmd SRecipient command -> case command of
-          NEW rKey -> createQueue st rKey
-          SUB -> subscribeQueue queueId
-          ACK -> acknowledgeMsg
-          KEY sKey -> secureQueue_ st sKey
-          OFF -> suspendQueue_ st
-          DEL -> delQueueAndMsgs st
+        Cmd SSender command ->
+          case command of
+            SEND msgBody -> sendMessage st msgBody
+            PING -> pure (corrId, "", PONG)
+        Cmd SNotifier NSUB -> subscribeNotifications
+        Cmd SRecipient command ->
+          case command of
+            NEW rKey dhKey ->
+              ifM
+                (asks $ allowNewQueues . config)
+                (createQueue st rKey dhKey)
+                (pure (corrId, queueId, ERR AUTH))
+            SUB -> subscribeQueue queueId
+            ACK -> acknowledgeMsg
+            KEY sKey -> secureQueue_ st sKey
+            NKEY nKey -> addQueueNotifier_ st nKey
+            OFF -> suspendQueue_ st
+            DEL -> delQueueAndMsgs st
       where
-        createQueue :: QueueStore -> RecipientPublicKey -> m Transmission
-        createQueue st rKey =
-          checkKeySize rKey addSubscribe
+        createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg)
+        createQueue st recipientKey dhKey = do
+          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
+          let rcvDhSecret = C.dh' dhKey privDhKey
+              qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
+              qRec (recipientId, senderId) =
+                QueueRec
+                  { recipientId,
+                    senderId,
+                    recipientKey,
+                    rcvDhSecret,
+                    senderKey = Nothing,
+                    notifier = Nothing,
+                    status = QueueActive
+                  }
+          (corrId,queueId,) <$> addQueueRetry 3 qik qRec
           where
-            addSubscribe =
-              addQueueRetry 3 >>= \case
-                Left e -> return $ ERR e
-                Right (rId, sId) -> do
+            addQueueRetry ::
+              Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m BrokerMsg
+            addQueueRetry 0 _ _ = pure $ ERR INTERNAL
+            addQueueRetry n qik qRec = do
+              ids@(rId, _) <- getIds
+              -- create QueueRec record with these ids and keys
+              atomically (addQueue st $ qRec ids) >>= \case
+                Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
+                Left e -> pure $ ERR e
+                Right _ -> do
                   withLog (`logCreateById` rId)
-                  subscribeQueue rId $> IDS rId sId
-
-            addQueueRetry :: Int -> m (Either ErrorType (RecipientId, SenderId))
-            addQueueRetry 0 = return $ Left INTERNAL
-            addQueueRetry n = do
-              ids <- getIds
-              atomically (addQueue st rKey ids) >>= \case
-                Left DUPLICATE_ -> addQueueRetry $ n - 1
-                Left e -> return $ Left e
-                Right _ -> return $ Right ids
+                  stats <- asks serverStats
+                  atomically $ modifyTVar (qCreated stats) (+ 1)
+                  subscribeQueue rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -232,79 +375,123 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
               n <- asks $ queueIdBytes . config
               liftM2 (,) (randomId n) (randomId n)
 
-        secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission
+        secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
         secureQueue_ st sKey = do
           withLog $ \s -> logSecureQueue s queueId sKey
-          atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey
+          stats <- asks serverStats
+          atomically $ modifyTVar (qSecured stats) (+ 1)
+          atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
-        checkKeySize :: Monad m' => C.PublicKey -> m' (Command 'Broker) -> m' Transmission
-        checkKeySize key action =
-          mkResp corrId queueId
-            <$> if C.validKeySize $ C.publicKeySize key
-              then action
-              else pure . ERR $ CMD KEY_SIZE
+        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
+        addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
+          where
+            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 nId nKey
+                  pure $ NID nId
 
-        suspendQueue_ :: QueueStore -> m Transmission
+        suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
           withLog (`logDeleteQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        subscribeQueue :: RecipientId -> m Transmission
+        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
+          TM.lookup rId subscriptions >>= \case
             Just s -> tryTakeTMVar (delivered s) $> s
             Nothing -> do
               writeTBQueue subscribedQ (rId, clnt)
               s <- newSubscription
-              writeTVar subscriptions $ M.insert rId s subs
+              TM.insert rId s subscriptions
               return s
 
-        unsubscribeQueue :: m ()
-        unsubscribeQueue = do
-          sub <- atomically . stateTVar subscriptions $
-            \cs -> (M.lookup queueId cs, M.delete queueId cs)
-          mapM_ cancelSub sub
+        subscribeNotifications :: m (Transmission BrokerMsg)
+        subscribeNotifications = atomically $ do
+          unlessM (TM.member queueId ntfSubscriptions) $ do
+            writeTBQueue ntfSubscribedQ (queueId, clnt)
+            TM.insert queueId () ntfSubscriptions
+          pure ok
 
-        acknowledgeMsg :: m Transmission
+        acknowledgeMsg :: m (Transmission BrokerMsg)
         acknowledgeMsg =
           atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
             >>= \case
-              Just (Just s) -> deliverMessage tryDelPeekMsg queueId s
+              Just (Just s) -> do
+                stats <- asks serverStats
+                atomically $ modifyTVar (msgRecv stats) (+ 1)
+                atomically $ updateActiveQueues stats queueId
+                deliverMessage tryDelPeekMsg queueId s
               _ -> return $ err NO_MSG
 
-        withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
-        withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
-
-        sendMessage :: QueueStore -> MsgBody -> m Transmission
-        sendMessage st msgBody = do
-          qr <- atomically $ getQueue st SSender queueId
-          either (return . err) storeMessage qr
+        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
+        updateActiveQueues stats qId = do
+          updatePeriod dayMsgQueues
+          updatePeriod weekMsgQueues
+          updatePeriod monthMsgQueues
           where
-            mkMessage :: m Message
-            mkMessage = do
-              msgId <- asks (msgIdBytes . config) >>= randomId
-              ts <- liftIO getCurrentTime
-              return $ Message {msgId, ts, msgBody}
+            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
 
-            storeMessage :: QueueRec -> m Transmission
+        withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
+        withSub rId f = mapM f =<< TM.lookup rId subscriptions
+
+        sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage st msgBody
+          | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
+          | otherwise = do
+            qr <- atomically $ getQueue st SSender queueId
+            either (return . err) storeMessage qr
+          where
+            storeMessage :: QueueRec -> m (Transmission BrokerMsg)
             storeMessage qr = case status qr of
               QueueOff -> return $ err AUTH
-              QueueActive -> do
-                ms <- asks msgStore
-                msg <- mkMessage
-                quota <- asks $ msgQueueQuota . config
-                atomically $ do
-                  q <- getMsgQueue ms (recipientId qr) quota
-                  isFull q >>= \case
-                    False -> writeMsg q msg $> ok
-                    True -> pure $ err QUOTA
+              QueueActive ->
+                mkMessage >>= \case
+                  Left _ -> pure $ err LARGE_MSG
+                  Right msg -> do
+                    ms <- asks msgStore
+                    ServerConfig {messageExpiration, msgQueueQuota} <- asks config
+                    old <- liftIO $ mapM expireBeforeEpoch messageExpiration
+                    resp@(_, _, sent) <- atomically $ do
+                      q <- getMsgQueue ms (recipientId qr) msgQueueQuota
+                      mapM_ (deleteExpiredMsgs q) old
+                      ifM (isFull q) (pure $ err QUOTA) $ do
+                        trySendNotification
+                        writeMsg q msg
+                        pure ok
+                    when (sent == OK) $ do
+                      stats <- asks serverStats
+                      atomically $ modifyTVar (msgSent stats) (+ 1)
+                      atomically $ updateActiveQueues stats $ recipientId qr
+                    pure resp
+              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
 
-        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m Transmission
+                trySendNotification :: STM ()
+                trySendNotification =
+                  forM_ (notifier qr) $ \(nId, _) ->
+                    mapM_ (writeNtf nId) =<< TM.lookup nId notifiers
+
+                writeNtf :: NotifierId -> Client -> STM ()
+                writeNtf nId Client {sndQ = q} =
+                  unlessM (isFullTBQueue sndQ) $
+                    writeTBQueue q (CorrId "", nId, NMSG)
+
+        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg)
         deliverMessage tryPeek rId = \case
           Sub {subThread = NoSub} -> do
             ms <- asks msgStore
@@ -312,13 +499,13 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
             q <- atomically $ getMsgQueue ms rId quota
             atomically (tryPeek q) >>= \case
               Nothing -> forkSub q $> ok
-              Just msg -> atomically setDelivered $> mkResp corrId rId (msgCmd msg)
-          _ -> return ok
+              Just msg -> atomically setDelivered $> (corrId, rId, msgCmd msg)
+          _ -> pure ok
           where
             forkSub :: MsgQueue -> m ()
             forkSub q = do
               atomically . setSub $ \s -> s {subThread = SubPending}
-              t <- forkIO $ subscriber q
+              t <- mkWeakThreadId =<< forkIO (subscriber q)
               atomically . setSub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
@@ -326,50 +513,76 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
             subscriber :: MsgQueue -> m ()
             subscriber q = atomically $ do
               msg <- peekMsg q
-              writeTBQueue sndQ $ mkResp (CorrId B.empty) rId (msgCmd msg)
+              writeTBQueue sndQ (CorrId "", rId, msgCmd msg)
               setSub (\s -> s {subThread = NoSub})
               void setDelivered
 
             setSub :: (Sub -> Sub) -> STM ()
-            setSub f = modifyTVar subscriptions $ M.adjust f rId
+            setSub f = TM.adjust f rId subscriptions
 
             setDelivered :: STM (Maybe Bool)
             setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
 
-        delQueueAndMsgs :: QueueStore -> m Transmission
+            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 -> return $ err e
+              Left e -> pure $ err e
               Right _ -> delMsgQueue ms queueId $> ok
 
-        ok :: Transmission
-        ok = mkResp corrId queueId OK
+        ok :: Transmission BrokerMsg
+        ok = (corrId, queueId, OK)
 
-        err :: ErrorType -> Transmission
-        err = mkResp corrId queueId . ERR
+        err :: ErrorType -> Transmission BrokerMsg
+        err e = (corrId, queueId, ERR e)
 
-        okResp :: Either ErrorType () -> Transmission
+        okResp :: Either ErrorType () -> Transmission BrokerMsg
         okResp = either err $ const ok
 
-        msgCmd :: Message -> Command 'Broker
-        msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
-
 withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withLog action = do
   env <- ask
   liftIO . mapM_ action $ storeLog (env :: Env)
 
-randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded
+randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
-  atomically (randomBytes n gVar)
+  atomically (C.pseudoRandomBytes n gVar)
 
-randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
-randomBytes n gVar = do
-  g <- readTVar gVar
-  let (bytes, g') = randomBytesGenerate n g
-  writeTVar gVar g'
-  return bytes
+saveServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
+  where
+    saveMessages f = do
+      liftIO $ putStrLn $ "saving messages to file " <> f
+      ms <- asks msgStore
+      liftIO . withFile f WriteMode $ \h ->
+        readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
+      where
+        saveQueueMsgs ms h rId =
+          atomically (flushMsgQueue ms rId)
+            >>= mapM_ (B.hPutStrLn h . strEncode . MsgLogRecord rId)
+
+restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
+restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
+  where
+    restoreMessages f = whenM (doesFileExist f) $ do
+      liftIO $ putStrLn $ "restoring messages from file " <> f
+      ms <- asks msgStore
+      quota <- asks $ msgQueueQuota . config
+      liftIO $ mapM_ (restoreMsg ms quota) . B.lines =<< B.readFile f
+      renameFile f $ f <> ".bak"
+      where
+        restoreMsg ms quota s = case strDecode s of
+          Left e -> B.putStrLn $ "message parsing error (" <> B.pack e <> "): " <> B.take 100 s
+          Right (MsgLogRecord rId msg) -> do
+            full <- atomically $ do
+              q <- getMsgQueue ms rId quota
+              ifM (isFull q) (pure True) (writeMsg q msg $> False)
+            when full . B.putStrLn $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId msg)

src/Simplex/Messaging/Server/CLI.hs

@@ -0,0 +1,284 @@
+{-# 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, 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.Transport (ATransport (..), TLS, Transport (..))
+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 (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
+import System.Process (readCreateProcess, shell)
+import Text.Read (readMaybe)
+
+data ServerCLIConfig cfg = ServerCLIConfig
+  { cfgDir :: FilePath,
+    logDir :: FilePath,
+    iniFile :: FilePath,
+    storeLogFile :: FilePath,
+    caKeyFile :: FilePath,
+    caCrtFile :: FilePath,
+    serverKeyFile :: FilePath,
+    serverCrtFile :: FilePath,
+    fingerprintFile :: FilePath,
+    defaultServerPort :: ServiceName,
+    executableName :: String,
+    serverVersion :: String,
+    mkIniFile :: Bool -> ServiceName -> String,
+    mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
+  }
+
+protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
+protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
+  getCliCommand cliCfg >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
+        _ -> initializeServer cliCfg opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
+        _ -> 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!"
+      cleanup cliCfg
+      putStrLn "Deleted configuration and log files"
+
+exitError :: String -> IO ()
+exitError msg = putStrLn msg >> exitFailure
+
+confirmOrExit :: String -> IO ()
+confirmOrExit s = do
+  putStrLn s
+  putStr "Continue (Y/n): "
+  hFlush stdout
+  ok <- getLine
+  when (ok /= "Y") 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 :: ServerCLIConfig cfg -> IO CliCommand
+getCliCommand cliCfg =
+  customExecParser
+    (prefs showHelpOnEmpty)
+    ( info
+        (helper <*> versionOption <*> cliCommandP cliCfg)
+        (header version <> fullDesc)
+    )
+  where
+    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
+    version = serverVersion cliCfg
+
+cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
+cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
+  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 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"
+                  )
+            )
+
+initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
+initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+  cleanup cliCfg
+  createDirectoryIfMissing True cfgDir
+  createDirectoryIfMissing True logDir
+  createX509
+  fp <- saveFingerprint
+  writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
+  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+  printServiceInfo cliCfg fp
+  warnCAPrivateKeyFile
+  where
+    ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
+    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
+
+    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
+  }
+
+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 :: String -> String -> Ini -> T.Text
+strictIni section key ini =
+  fromRight (error ("no key " <> key <> " in section " <> section)) $
+    lookupValue (T.pack section) (T.pack key) ini
+
+readStrictIni :: Read a => String -> String -> Ini -> a
+readStrictIni section key = read . T.unpack . strictIni section key
+
+runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
+runServer cliCfg server ini = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  fp <- checkSavedFingerprint
+  printServiceInfo cliCfg fp
+  let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
+      transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
+      logFile = if enableStoreLog then Just storeLogFile else Nothing
+      cfg = mkServerConfig logFile transports ini
+  printServerConfig logFile transports
+  server cfg
+  where
+    ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
+    checkSavedFingerprint = do
+      savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
+      Fingerprint fp <- loadFingerprint caCrtFile
+      when (B.pack savedFingerprint /= strEncode fp) $
+        exitError "Stored fingerprint is invalid."
+      pure fp
+
+    printServerConfig logFile transports = 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 <> ")..."
+
+cleanup :: ServerCLIConfig cfg -> IO ()
+cleanup ServerCLIConfig {cfgDir, logDir} = do
+  deleteDirIfExists cfgDir
+  deleteDirIfExists logDir
+  where
+    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
+
+printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
+printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
+  putStrLn serverVersion
+  B.putStrLn $ "Fingerprint: " <> strEncode fpStr

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

@@ -2,60 +2,122 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
 import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
+import Data.ByteString.Char8 (ByteString)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock (UTCTime, 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 qualified Simplex.Messaging.Crypto as C
+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 (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 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 System.IO (IOMode (..))
+import System.Mem.Weak (Weak)
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
     tbqSize :: Natural,
+    serverTbqSize :: Natural,
     msgQueueQuota :: Natural,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    storeLog :: Maybe (StoreLog 'ReadMode),
-    blockSize :: Int,
-    serverPrivateKey :: C.FullPrivateKey
-    -- serverId :: ByteString
+    storeLogFile :: Maybe FilePath,
+    storeMsgsFile :: Maybe FilePath,
+    -- | set to False to prohibit creating new queues
+    allowNewQueues :: Bool,
+    -- | 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,
+    -- | CA certificate private key is not needed for initialization
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    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,
+    serverIdentity :: KeyHash,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
     idsDrg :: TVar ChaChaDRG,
-    serverKeyPair :: C.FullKeyPair,
-    storeLog :: Maybe (StoreLog 'WriteMode)
+    storeLog :: Maybe (StoreLog 'WriteMode),
+    tlsServerParams :: T.ServerParams,
+    serverStats :: ServerStats
   }
 
 data Server = Server
   { subscribedQ :: TBQueue (RecipientId, Client),
-    subscribers :: TVar (Map RecipientId Client)
+    subscribers :: TMap RecipientId Client,
+    ntfSubscribedQ :: TBQueue (NotifierId, Client),
+    notifiers :: TMap NotifierId Client
   }
 
 data Client = Client
-  { subscriptions :: TVar (Map RecipientId Sub),
-    rcvQ :: TBQueue Transmission,
-    sndQ :: TBQueue Transmission
+  { subscriptions :: TMap RecipientId Sub,
+    ntfSubscriptions :: TMap NotifierId (),
+    rcvQ :: TBQueue (Transmission Cmd),
+    sndQ :: TBQueue (Transmission BrokerMsg),
+    sessionId :: ByteString,
+    connected :: TVar Bool,
+    activeAt :: TVar SystemTime
   }
 
-data SubscriptionThread = NoSub | SubPending | SubThread ThreadId
+data ServerStats = ServerStats
+  { qCreated :: TVar Int,
+    qSecured :: TVar Int,
+    qDeleted :: TVar Int,
+    msgSent :: TVar Int,
+    msgRecv :: TVar Int,
+    dayMsgQueues :: TVar (Set RecipientId),
+    weekMsgQueues :: TVar (Set RecipientId),
+    monthMsgQueues :: TVar (Set RecipientId),
+    fromTime :: TVar UTCTime
+  }
+
+data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId)
 
 data Sub = Sub
   { subThread :: SubscriptionThread,
@@ -65,15 +127,33 @@ data Sub = Sub
 newServer :: Natural -> STM Server
 newServer qSize = do
   subscribedQ <- newTBQueue qSize
-  subscribers <- newTVar M.empty
-  return Server {subscribedQ, subscribers}
+  subscribers <- TM.empty
+  ntfSubscribedQ <- newTBQueue qSize
+  notifiers <- TM.empty
+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
 
-newClient :: Natural -> STM Client
-newClient qSize = do
-  subscriptions <- newTVar M.empty
+newClient :: Natural -> ByteString -> SystemTime -> STM Client
+newClient qSize sessionId ts = do
+  subscriptions <- TM.empty
+  ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
-  return Client {subscriptions, rcvQ, sndQ}
+  connected <- newTVar True
+  activeAt <- newTVar ts
+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected, activeAt}
+
+newServerStats :: UTCTime -> STM ServerStats
+newServerStats ts = do
+  qCreated <- newTVar 0
+  qSecured <- newTVar 0
+  qDeleted <- newTVar 0
+  msgSent <- newTVar 0
+  msgRecv <- newTVar 0
+  dayMsgQueues <- newTVar S.empty
+  weekMsgQueues <- newTVar S.empty
+  monthMsgQueues <- newTVar S.empty
+  fromTime <- newTVar ts
+  pure ServerStats {qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues, fromTime}
 
 newSubscription :: STM Sub
 newSubscription = do
@@ -81,20 +161,30 @@ newSubscription = do
   return Sub {subThread = NoSub, delivered}
 
 newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
-newEnv config = do
-  server <- atomically $ newServer (tbqSize config)
+newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
+  server <- atomically $ newServer (serverTbqSize config)
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
-  let pk = serverPrivateKey config
-      serverKeyPair = (C.publicKey' pk, pk)
-  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'}
+  storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
+  s' <- restoreQueues queueStore `mapM` storeLog
+  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}
   where
     restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
-    restoreQueues queueStore s = do
-      (queues, s') <- liftIO $ readWriteStoreLog s
-      atomically $ modifyTVar queueStore $ \d -> d {queues, senders = M.foldr' addSender M.empty queues}
+    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
       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 (nId, _) -> M.insert nId (recipientId q)

src/Simplex/Messaging/Server/Expiration.hs

@@ -0,0 +1,17 @@
+{-# 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/MsgStore.hs

@@ -1,20 +1,36 @@
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
-import Data.Time.Clock
+import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime)
 import Numeric.Natural
-import Simplex.Messaging.Protocol (Encoded, MsgBody, RecipientId)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)
 
 data Message = Message
-  { msgId :: Encoded,
-    ts :: UTCTime,
+  { msgId :: MsgId,
+    ts :: SystemTime,
     msgBody :: MsgBody
   }
 
+instance StrEncoding Message where
+  strEncode Message {msgId, ts, msgBody} = strEncode (msgId, ts, msgBody)
+  strP = do
+    (msgId, ts, msgBody) <- strP
+    pure Message {msgId, ts, msgBody}
+
+data MsgLogRecord = MsgLogRecord RecipientId Message
+
+instance StrEncoding MsgLogRecord where
+  strEncode (MsgLogRecord rId msg) = strEncode (rId, msg)
+  strP = MsgLogRecord <$> strP_ <*> strP
+
 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
@@ -22,3 +38,4 @@ class MonadMsgQueue q m where
   tryPeekMsg :: q -> m (Maybe Message) -- non blocking
   peekMsg :: q -> m Message -- blocking
   tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available
+  deleteExpiredMsgs :: q -> Int64 -> m ()

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

@@ -3,39 +3,42 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
+import Control.Concurrent.STM.TBQueue (flushTBQueue)
+import Control.Monad (when)
+import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Numeric.Natural
 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}
 
-newtype MsgStoreData = MsgStoreData {messages :: Map RecipientId MsgQueue}
-
-type STMMsgStore = TVar MsgStoreData
+type STMMsgStore = TMap RecipientId MsgQueue
 
 newMsgStore :: STM STMMsgStore
-newMsgStore = newTVar $ MsgStoreData M.empty
+newMsgStore = TM.empty
 
 instance MonadMsgStore STMMsgStore MsgQueue STM where
   getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
-  getMsgQueue store rId quota = do
-    m <- messages <$> readTVar store
-    maybe (newQ m) return $ M.lookup rId m
+  getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
     where
-      newQ m' = do
+      newQ = do
         q <- MsgQueue <$> newTBQueue quota
-        writeTVar store . MsgStoreData $ M.insert rId q m'
+        TM.insert rId q st
         return q
 
   delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-  delMsgQueue store rId =
-    modifyTVar store $ MsgStoreData . M.delete rId . messages
+  delMsgQueue st rId = TM.delete rId st
+
+  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
 
 instance MonadMsgQueue MsgQueue STM where
   isFull :: MsgQueue -> STM Bool
@@ -53,3 +56,11 @@ instance MonadMsgQueue MsgQueue STM where
   -- atomic delete (== read) last and peek next message if available
   tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
   tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q
+
+  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+  deleteExpiredMsgs (MsgQueue q) old = loop
+    where
+      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
+      delOldMsg Message {ts} =
+        when (systemSeconds ts < old) $
+          tryReadTBQueue q >> loop

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,35 +1,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.QueueStore where
 
 import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
-  { recipientId :: QueueId,
-    senderId :: QueueId,
-    recipientKey :: RecipientPublicKey,
-    senderKey :: Maybe SenderPublicKey,
+  { recipientId :: RecipientId,
+    recipientKey :: RcvPublicVerifyKey,
+    rcvDhSecret :: RcvDhSecret,
+    senderId :: SenderId,
+    senderKey :: Maybe SndPublicVerifyKey,
+    notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
     status :: QueueStatus
   }
+  deriving (Eq, Show)
 
-data QueueStatus = QueueActive | QueueOff deriving (Eq)
+data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
 
 class MonadQueueStore s m where
-  addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ())
-  getQueue :: s -> SParty (a :: Party) -> QueueId -> m (Either ErrorType QueueRec)
-  secureQueue :: s -> RecipientId -> SenderPublicKey -> m (Either ErrorType ())
+  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 -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec)
   suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
   deleteQueue :: s -> RecipientId -> m (Either ErrorType ())
-
-mkQueueRec :: RecipientPublicKey -> (RecipientId, SenderId) -> QueueRec
-mkQueueRec recipientKey (recipientId, senderId) =
-  QueueRec
-    { recipientId,
-      senderId,
-      recipientKey,
-      senderKey = Nothing,
-      status = QueueActive
-    }

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
@@ -11,82 +12,82 @@
 
 module Simplex.Messaging.Server.QueueStore.STM where
 
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
+import Control.Monad
+import Data.Functor (($>))
 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 QueueStoreData = QueueStoreData
-  { queues :: Map RecipientId QueueRec,
-    senders :: Map SenderId RecipientId
+data QueueStore = QueueStore
+  { queues :: TMap RecipientId (TVar QueueRec),
+    senders :: TMap SenderId RecipientId,
+    notifiers :: TMap NotifierId RecipientId
   }
 
-type QueueStore = TVar QueueStoreData
-
 newQueueStore :: STM QueueStore
-newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty}
+newQueueStore = do
+  queues <- TM.empty
+  senders <- TM.empty
+  notifiers <- TM.empty
+  pure QueueStore {queues, senders, notifiers}
 
 instance MonadQueueStore QueueStore STM where
-  addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ())
-  addQueue store rKey ids@(rId, 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 (mkQueueRec rKey ids) queues,
-              senders = M.insert sId rId senders
-            }
-        return $ Right ()
+  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
 
-  getQueue :: QueueStore -> SParty (p :: Party) -> QueueId -> STM (Either ErrorType QueueRec)
-  getQueue store SRecipient rId = do
-    cs <- readTVar store
-    return $ getRcpQueue cs rId
-  getQueue store SSender sId = do
-    cs <- readTVar store
-    let rId = M.lookup sId $ senders cs
-    return $ maybe (Left AUTH) (getRcpQueue cs) rId
-  getQueue _ SBroker _ =
-    return $ Left INTERNAL
+  getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
+  getQueue QueueStore {queues, senders, notifiers} party qId =
+    toResult <$> (mapM readTVar =<< getVar)
+    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)
 
-  secureQueue store rId sKey =
-    updateQueues store rId $ \cs c ->
-      case senderKey c of
-        Just _ -> (Left AUTH, cs)
-        _ -> (Right (), cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})
+  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 _ -> pure Nothing
+        _ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
+
+  addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)
+  addQueueNotifier QueueStore {queues, notifiers} rId nId nKey = do
+    ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
+      withQueue rId queues $ \qVar ->
+        readTVar qVar >>= \q -> case notifier q of
+          Just _ -> pure Nothing
+          _ -> do
+            writeTVar qVar q {notifier = Just (nId, nKey)}
+            TM.insert nId rId notifiers
+            pure $ Just q
 
   suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  suspendQueue store rId =
-    updateQueues store rId $ \cs c ->
-      (Right (), cs {queues = M.insert rId c {status = QueueOff} (queues cs)})
+  suspendQueue QueueStore {queues} rId =
+    withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
 
   deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  deleteQueue store rId =
-    updateQueues store rId $ \cs c ->
-      ( Right (),
-        cs
-          { queues = M.delete rId (queues cs),
-            senders = M.delete (senderId c) (senders cs)
-          }
-      )
+  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) $ \(nId, _) -> TM.delete nId notifiers
+          pure $ Right ()
+      _ -> pure $ Left AUTH
 
-updateQueues ::
-  QueueStore ->
-  RecipientId ->
-  (QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)) ->
-  STM (Either ErrorType ())
-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
+toResult :: Maybe a -> Either ErrorType a
+toResult = maybe (Left AUTH) Right
 
-getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
-getRcpQueue cs rId = maybe (Left AUTH) Right . M.lookup rId $ queues cs
+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

src/Simplex/Messaging/Server/StoreLog.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Simplex.Messaging.Server.StoreLog
   ( StoreLog, -- constructors are not exported
@@ -14,6 +15,7 @@ module Simplex.Messaging.Server.StoreLog
     closeStoreLog,
     logCreateQueue,
     logSecureQueue,
+    logAddNotifier,
     logDeleteQueue,
     readWriteStoreLog,
   )
@@ -21,10 +23,7 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad (unless)
-import Data.Attoparsec.ByteString.Char8 (Parser)
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first, second)
-import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -33,8 +32,7 @@ import Data.Functor (($>))
 import Data.List (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Parsers (base64P, parseAll)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..))
 import Simplex.Messaging.Transport (trimCR)
@@ -49,37 +47,44 @@ data StoreLog (a :: IOMode) where
 
 data StoreLogRecord
   = CreateQueue QueueRec
-  | SecureQueue QueueId SenderPublicKey
+  | SecureQueue QueueId SndPublicVerifyKey
+  | AddNotifier QueueId NotifierId NtfPublicVerifyKey
   | DeleteQueue QueueId
 
-storeLogRecordP :: Parser StoreLogRecord
-storeLogRecordP =
-  "CREATE " *> createQueueP
-    <|> "SECURE " *> secureQueueP
-    <|> "DELETE " *> (DeleteQueue <$> base64P)
-  where
-    createQueueP = CreateQueue <$> queueRecP
-    secureQueueP = SecureQueue <$> base64P <* A.space <*> C.pubKeyP
-    queueRecP = do
-      recipientId <- "rid=" *> base64P <* A.space
-      senderId <- "sid=" *> base64P <* A.space
-      recipientKey <- "rk=" *> C.pubKeyP <* A.space
-      senderKey <- "sk=" *> optional C.pubKeyP
-      pure QueueRec {recipientId, senderId, recipientKey, senderKey, status = QueueActive}
+instance StrEncoding QueueRec where
+  strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
+    B.unwords
+      [ "rid=" <> strEncode recipientId,
+        "rk=" <> strEncode recipientKey,
+        "rdh=" <> strEncode rcvDhSecret,
+        "sid=" <> strEncode senderId,
+        "sk=" <> strEncode senderKey
+      ]
+      <> maybe "" notifierStr notifier
+    where
+      notifierStr (nId, nKey) = " nid=" <> strEncode nId <> " nk=" <> strEncode nKey
 
-serializeStoreLogRecord :: StoreLogRecord -> ByteString
-serializeStoreLogRecord = \case
-  CreateQueue q -> "CREATE " <> serializeQueue q
-  SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey
-  DeleteQueue rId -> "DELETE " <> encode rId
-  where
-    serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey} =
-      B.unwords
-        [ "rid=" <> encode recipientId,
-          "sid=" <> encode senderId,
-          "rk=" <> C.serializePubKey recipientKey,
-          "sk=" <> maybe "" C.serializePubKey senderKey
-        ]
+  strP = do
+    recipientId <- "rid=" *> strP_
+    recipientKey <- "rk=" *> strP_
+    rcvDhSecret <- "rdh=" *> strP_
+    senderId <- "sid=" *> strP_
+    senderKey <- "sk=" *> 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 nId nKey -> strEncode (Str "NOTIFIER", rId, nId, nKey)
+    DeleteQueue rId -> strEncode (Str "DELETE", rId)
+
+  strP =
+    "CREATE " *> (CreateQueue <$> strP)
+      <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
+      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP_ <*> strP)
+      <|> "DELETE " *> (DeleteQueue <$> strP)
 
 openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
 openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
@@ -101,15 +106,18 @@ closeStoreLog = \case
 
 writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO ()
 writeStoreLogRecord (WriteStoreLog _ h) r = do
-  B.hPutStrLn h $ serializeStoreLogRecord r
+  B.hPutStrLn h $ strEncode r
   hFlush h
 
 logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()
 logCreateQueue s = writeStoreLogRecord s . CreateQueue
 
-logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO ()
+logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
 logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
 
+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
 
@@ -136,11 +144,12 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo
     returnResult :: ([LogParsingError], Map RecipientId QueueRec) -> IO (Map RecipientId QueueRec)
     returnResult (errs, res) = mapM_ printError errs $> res
     parseLogRecord :: LB.ByteString -> Either LogParsingError StoreLogRecord
-    parseLogRecord = (\s -> first (,s) $ parseAll storeLogRecordP s) . trimCR . LB.toStrict
+    parseLogRecord = (\s -> first (,s) $ strDecode s) . trimCR . LB.toStrict
     procLogRecord :: Map RecipientId QueueRec -> StoreLogRecord -> Map RecipientId QueueRec
     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 nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m
       DeleteQueue qId -> M.delete qId m
     printError :: LogParsingError -> IO ()
     printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/TMap.hs

@@ -0,0 +1,82 @@
+module Simplex.Messaging.TMap
+  ( TMap,
+    empty,
+    singleton,
+    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 #-}
+
+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

@@ -1,10 +1,11 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -24,25 +25,31 @@
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
 module Simplex.Messaging.Transport
-  ( -- * Transport connection class
+  ( -- * SMP transport parameters
+    supportedSMPVersions,
+    simplexMQVersion,
+
+    -- * Transport connection class
     Transport (..),
     TProxy (..),
     ATransport (..),
+    TransportPeer (..),
 
-    -- * Transport over TCP
-    runTransportServer,
-    runTransportClient,
+    -- * TLS Transport
+    TLS (..),
+    SessionId,
+    connectTLS,
+    closeTLS,
+    supportedParameters,
+    withTlsUnique,
 
-    -- * TCP transport
-    TCP (..),
-
-    -- * SMP encrypted transport
+    -- * SMP transport
     THandle (..),
     TransportError (..),
-    serverHandshake,
-    clientHandshake,
-    tPutEncrypted,
-    tGetEncrypted,
+    smpServerHandshake,
+    smpClientHandshake,
+    tPutBlock,
+    tGetBlock,
     serializeTransportError,
     transportErrorP,
 
@@ -53,38 +60,44 @@ where
 
 import Control.Applicative ((<|>))
 import Control.Monad.Except
-import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except (throwE)
-import Crypto.Cipher.Types (AuthTag)
+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.Bifunctor (first)
-import Data.ByteArray (xor)
+import Data.Bitraversable (bimapM)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import Data.Default (def)
 import Data.Functor (($>))
-import Data.Maybe(fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.String
-import Data.Word (Word32)
 import GHC.Generics (Generic)
-import GHC.IO.Exception (IOErrorType (..))
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Generic.Random (genericArbitraryU)
 import Network.Socket
-import Network.Transport.Internal (decodeNum16, decodeNum32, encodeEnum16, encodeEnum32, encodeWord32)
+import qualified Network.TLS as T
+import qualified Network.TLS.Extra as TE
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Parsers (parse, parseAll, parseRead1, parseString)
-import Simplex.Messaging.Util (bshow, liftError)
-import System.IO
-import System.IO.Error
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
+import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
+import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
-import UnliftIO.Concurrent
-import UnliftIO.Exception (Exception, IOException)
+import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
+-- * Transport parameters
+
+smpBlockSize :: Int
+smpBlockSize = 16384
+
+supportedSMPVersions :: VersionRange
+supportedSMPVersions = mkVersionRange 1 1
+
+simplexMQVersion :: String
+simplexMQVersion = "2.3.1"
+
 -- * Transport connection class
 
 class Transport c where
@@ -93,11 +106,16 @@ class Transport c where
 
   transportName :: TProxy c -> String
 
-  -- | Upgrade client socket to connection (used in the server)
-  getServerConnection :: Socket -> IO c
+  transportPeer :: c -> TransportPeer
 
-  -- | Upgrade server socket to connection (used in the client)
-  getClientConnection :: Socket -> IO c
+  -- | Upgrade server TLS context to connection (used in the server)
+  getServerConnection :: T.Context -> IO c
+
+  -- | Upgrade client TLS context to connection (used in the client)
+  getClientConnection :: T.Context -> IO c
+
+  -- | tls-unique channel binding per RFC5929
+  tlsUnique :: c -> SessionId
 
   -- | Close connection
   closeConnection :: c -> IO ()
@@ -115,176 +133,189 @@ class Transport c where
   putLn :: c -> ByteString -> IO ()
   putLn c = cPut c . (<> "\r\n")
 
+data TransportPeer = TClient | TServer
+  deriving (Eq, Show)
+
 data TProxy c = TProxy
 
 data ATransport = forall c. Transport c => ATransport (TProxy c)
 
--- * Transport over TCP
+-- * TLS Transport
 
--- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
---
--- All accepted connections are passed to the passed function.
-runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m ()
-runTransportServer started port server = do
-  clients <- newTVarIO S.empty
-  E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do
-    c <- liftIO $ acceptConnection sock
-    tid <- forkFinally (server c) (const $ liftIO $ closeConnection c)
-    atomically . modifyTVar clients $ S.insert tid
+data TLS = TLS
+  { tlsContext :: T.Context,
+    tlsPeer :: TransportPeer,
+    tlsUniq :: ByteString,
+    buffer :: TVar ByteString,
+    getLock :: TMVar ()
+  }
+
+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
+    pure ctx
+
+getTLS :: TransportPeer -> T.Context -> IO TLS
+getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
   where
-    closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
-    closeServer clients sock = do
-      readTVarIO clients >>= mapM_ killThread
-      close sock
-      void . atomically $ tryPutTMVar started False
-    acceptConnection :: Transport c => Socket -> IO c
-    acceptConnection sock = accept sock >>= getServerConnection . fst
+    newTLS tlsUniq = do
+      buffer <- newTVarIO ""
+      getLock <- newTMVarIO ()
+      pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, buffer, getLock}
 
-startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
-startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
+withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
+withTlsUnique peer cxt f =
+  cxtFinished peer cxt
+    >>= maybe (closeTLS cxt >> ioe_EOF) f
   where
-    resolve =
-      let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
-       in head <$> getAddrInfo (Just hints) Nothing (Just port)
-    open addr = do
-      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-      setSocketOption sock ReuseAddr 1
-      withFdSocket sock setCloseOnExecIfNeeded
-      bind sock $ addrAddress addr
-      listen sock 1024
-      return sock
-    setStarted sock = atomically (tryPutTMVar started True) >> pure sock
+    cxtFinished TServer = T.getPeerFinished
+    cxtFinished TClient = T.getFinished
 
--- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> (c -> m a) -> m a
-runTransportClient host port client = do
-  c <- liftIO $ startTCPClient host port
-  client c `E.finally` liftIO (closeConnection c)
+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 ()
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> IO c
-startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
-  where
-    err :: IOException
-    err = mkIOError NoSuchThing "no address" Nothing Nothing
+supportedParameters :: T.Supported
+supportedParameters =
+  def
+    { T.supportedVersions = [T.TLS13, T.TLS12],
+      T.supportedCiphers =
+        [ TE.cipher_TLS13_CHACHA20POLY1305_SHA256, -- for TLS13
+          TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- for TLS12
+        ],
+      T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
+      T.supportedSecureRenegotiation = False,
+      T.supportedGroups = [T.X448, T.X25519]
+    }
 
-    resolve :: IO [AddrInfo]
-    resolve =
-      let hints = defaultHints {addrSocketType = Stream}
-       in getAddrInfo (Just hints) (Just host) (Just port)
+instance Transport TLS where
+  transportName _ = "TLS"
+  transportPeer = tlsPeer
+  getServerConnection = getTLS TServer
+  getClientConnection = getTLS TClient
+  tlsUnique = tlsUniq
+  closeConnection tls = closeTLS $ tlsContext tls
 
-    tryOpen :: IOException -> [AddrInfo] -> IO c
-    tryOpen e [] = E.throwIO e
-    tryOpen _ (addr : as) =
-      E.try (open addr) >>= either (`tryOpen` as) pure
+  cGet :: TLS -> Int -> IO ByteString
+  cGet TLS {tlsContext, buffer, getLock} n =
+    E.bracket_
+      (atomically $ takeTMVar getLock)
+      (atomically $ putTMVar getLock ())
+      $ do
+        b <- readChunks =<< readTVarIO buffer
+        let (s, b') = B.splitAt n b
+        atomically $ writeTVar buffer b'
+        pure s
+    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
 
-    open :: AddrInfo -> IO c
-    open addr = do
-      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-      connect sock $ addrAddress addr
-      getClientConnection sock
+  cPut :: TLS -> ByteString -> IO ()
+  cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
 
--- * TCP transport
-
-newtype TCP = TCP {tcpHandle :: Handle}
-
-instance Transport TCP where
-  transportName _ = "TCP"
-  getServerConnection = fmap TCP . getSocketHandle
-  getClientConnection = getServerConnection
-  closeConnection = hClose . tcpHandle
-  cGet = B.hGet . tcpHandle
-  cPut = B.hPut . tcpHandle
-  getLn = fmap trimCR . B.hGetLine . tcpHandle
-
-getSocketHandle :: Socket -> IO Handle
-getSocketHandle conn = do
-  h <- socketToHandle conn ReadWriteMode
-  hSetBinaryMode h True
-  hSetNewlineMode h NewlineMode {inputNL = CRLF, outputNL = CRLF}
-  hSetBuffering h LineBuffering
-  return h
+  getLn :: TLS -> IO ByteString
+  getLn TLS {tlsContext, buffer, getLock} = do
+    E.bracket_
+      (atomically $ takeTMVar getLock)
+      (atomically $ putTMVar getLock ())
+      $ do
+        b <- readChunks =<< readTVarIO buffer
+        let (s, b') = B.break (== '\n') b
+        atomically $ writeTVar buffer (B.drop 1 b') -- drop '\n' we made a break at
+        pure $ trimCR s
+    where
+      readChunks :: ByteString -> IO ByteString
+      readChunks b
+        | B.elem '\n' b = pure b
+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
+        e -> E.throwIO e
 
 -- | Trim trailing CR from ByteString.
 trimCR :: ByteString -> ByteString
 trimCR "" = ""
 trimCR s = if B.last s == '\r' then B.init s else s
 
--- * SMP encrypted transport
-
-data SMPVersion = SMPVersion Int Int Int Int
-  deriving (Eq, Ord)
-
-instance IsString SMPVersion where
-  fromString = parseString $ parseAll smpVersionP
-
-major :: SMPVersion -> (Int, Int)
-major (SMPVersion a b _ _) = (a, b)
-
-currentSMPVersion :: SMPVersion
-currentSMPVersion = "0.4.0.0"
-
-serializeSMPVersion :: SMPVersion -> ByteString
-serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d]
-
-smpVersionP :: Parser SMPVersion
-smpVersionP =
-  let ver = A.decimal <* A.char '.'
-   in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal
+-- * SMP transport
 
 -- | The handle for SMP encrypted transport connection over Transport .
 data THandle c = THandle
   { connection :: c,
-    sndKey :: SessionKey,
-    rcvKey :: SessionKey,
-    blockSize :: Int
+    sessionId :: SessionId,
+    blockSize :: Int,
+    -- | agreed server protocol version
+    thVersion :: Version
   }
 
-data SessionKey = SessionKey
-  { aesKey :: C.Key,
-    baseIV :: C.IV,
-    counter :: TVar Word32
+-- | TLS-unique channel binding
+type SessionId = ByteString
+
+data ServerHandshake = ServerHandshake
+  { smpVersionRange :: VersionRange,
+    sessionId :: SessionId
   }
 
 data ClientHandshake = ClientHandshake
-  { blockSize :: Int,
-    sndKey :: SessionKey,
-    rcvKey :: SessionKey
+  { -- | agreed SMP server protocol version
+    smpVersion :: Version,
+    -- | server identity - CA certificate fingerprint
+    keyHash :: C.KeyHash
   }
 
+instance Encoding ClientHandshake where
+  smpEncode ClientHandshake {smpVersion, keyHash} = smpEncode (smpVersion, keyHash)
+  smpP = do
+    (smpVersion, keyHash) <- smpP
+    pure ClientHandshake {smpVersion, keyHash}
+
+instance Encoding ServerHandshake where
+  smpEncode ServerHandshake {smpVersionRange, sessionId} =
+    smpEncode (smpVersionRange, sessionId)
+  smpP = do
+    (smpVersionRange, sessionId) <- smpP
+    pure ServerHandshake {smpVersionRange, sessionId}
+
 -- | Error of SMP encrypted transport over TCP.
 data TransportError
   = -- | error parsing transport block
     TEBadBlock
-  | -- | block encryption error
-    TEEncrypt
-  | -- | block decryption error
-    TEDecrypt
+  | -- | message does not fit in transport block
+    TELargeMsg
+  | -- | incorrect session ID
+    TEBadSession
   | -- | transport handshake error
-    TEHandshake HandshakeError
+    TEHandshake {handshakeErr :: HandshakeError}
   deriving (Eq, Generic, Read, Show, Exception)
 
+instance ToJSON TransportError where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "TE"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "TE"
+
 -- | Transport handshake error.
 data HandshakeError
-  = -- | encryption error
-    ENCRYPT
-  | -- | decryption error
-    DECRYPT
-  | -- | error parsing protocol version
+  = -- | parsing error
+    PARSE
+  | -- | incompatible peer version
     VERSION
-  | -- | error parsing RSA key
-    RSA_KEY
-  | -- | error parsing server transport header or invalid block size
-    HEADER
-  | -- | error parsing AES keys
-    AES_KEYS
-  | -- | not matching RSA key hash
-    BAD_HASH
-  | -- | lower major agent version than protocol version
-    MAJOR_VERSION
-  | -- | TCP transport terminated
-    TERMINATED
+  | -- | incorrect server identity
+    IDENTITY
   deriving (Eq, Generic, Read, Show, Exception)
 
+instance ToJSON HandshakeError where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
 instance Arbitrary TransportError where arbitrary = genericArbitraryU
 
 instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
@@ -293,202 +324,66 @@ instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
 transportErrorP :: Parser TransportError
 transportErrorP =
   "BLOCK" $> TEBadBlock
-    <|> "AES_ENCRYPT" $> TEEncrypt
-    <|> "AES_DECRYPT" $> TEDecrypt
+    <|> "LARGE_MSG" $> TELargeMsg
+    <|> "SESSION" $> TEBadSession
     <|> TEHandshake <$> parseRead1
 
 -- | Serialize SMP encrypted transport error.
 serializeTransportError :: TransportError -> ByteString
 serializeTransportError = \case
-  TEEncrypt -> "AES_ENCRYPT"
-  TEDecrypt -> "AES_DECRYPT"
   TEBadBlock -> "BLOCK"
+  TELargeMsg -> "LARGE_MSG"
+  TEBadSession -> "SESSION"
   TEHandshake e -> bshow e
 
--- | Encrypt and send block to SMP encrypted transport.
-tPutEncrypted :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
-tPutEncrypted THandle {connection = c, sndKey, blockSize} block =
-  encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case
-    Left _ -> pure $ Left TEEncrypt
-    Right (authTag, msg) -> Right <$> cPut c (C.authTagToBS authTag <> msg)
+-- | Pad and send block to SMP transport.
+tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
+tPutBlock THandle {connection = c, blockSize} block =
+  bimapM (const $ pure TELargeMsg) (cPut c) $
+    C.pad block blockSize
 
--- | Receive and decrypt block from SMP encrypted transport.
-tGetEncrypted :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetEncrypted THandle {connection = c, rcvKey, blockSize} =
-  cGet c blockSize >>= decryptBlock rcvKey >>= \case
-    Left _ -> pure $ Left TEDecrypt
-    Right "" -> ioe_EOF
-    Right msg -> pure $ Right msg
+-- | Receive block from SMP transport.
+tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
+tGetBlock THandle {connection = c, blockSize} =
+  cGet c blockSize >>= \case
+    "" -> ioe_EOF
+    msg -> pure . first (const TELargeMsg) $ C.unPad msg
 
-encryptBlock :: SessionKey -> Int -> ByteString -> IO (Either C.CryptoError (AuthTag, ByteString))
-encryptBlock k@SessionKey {aesKey} size block = do
-  ivBytes <- makeNextIV k
-  runExceptT $ C.encryptAES aesKey ivBytes size block
-
-decryptBlock :: SessionKey -> ByteString -> IO (Either C.CryptoError ByteString)
-decryptBlock k@SessionKey {aesKey} block = do
-  let (authTag, msg') = B.splitAt C.authTagSize block
-  ivBytes <- makeNextIV k
-  runExceptT $ C.decryptAES aesKey ivBytes msg' (C.bsToAuthTag authTag)
-
-makeNextIV :: SessionKey -> IO C.IV
-makeNextIV SessionKey {baseIV, counter} = atomically $ do
-  c <- readTVar counter
-  writeTVar counter $ c + 1
-  pure $ iv c
-  where
-    (start, rest) = B.splitAt 4 $ C.unIV baseIV
-    iv c = C.IV $ (start `xor` encodeWord32 c) <> rest
-
--- | Server SMP encrypted transport handshake.
+-- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
---
--- The numbers in function names refer to the steps in the document.
-serverHandshake :: forall c. Transport c => c -> Int -> C.FullKeyPair -> ExceptT TransportError IO (THandle c)
-serverHandshake c srvBlockSize (k, pk) = do
-  checkValidBlockSize srvBlockSize
-  liftIO sendHeaderAndPublicKey_1
-  encryptedKeys <- receiveEncryptedKeys_4
-  ClientHandshake {blockSize, sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys
-  checkValidBlockSize blockSize
-  th <- liftIO $ transportHandle c rcvKey sndKey blockSize -- keys are swapped here
-  sendWelcome_6 th
-  pure th
-  where
-    sendHeaderAndPublicKey_1 :: IO ()
-    sendHeaderAndPublicKey_1 = do
-      let sKey = C.encodePubKey k
-          header = ServerHeader {blockSize = srvBlockSize, keySize = B.length sKey}
-      cPut c $ binaryServerHeader header
-      cPut c sKey
-    receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString
-    receiveEncryptedKeys_4 =
-      liftIO (cGet c $ C.publicKeySize k) >>= \case
-        "" -> throwE $ TEHandshake TERMINATED
-        ks -> pure ks
-    decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO ClientHandshake
-    decryptParseKeys_5 encKeys =
-      liftError (const $ TEHandshake DECRYPT) (C.decryptOAEP pk encKeys)
-        >>= liftEither . parseClientHandshake
-    sendWelcome_6 :: THandle c -> ExceptT TransportError IO ()
-    sendWelcome_6 th = ExceptT . tPutEncrypted th $ serializeSMPVersion currentSMPVersion <> " "
+smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+smpServerHandshake c kh = do
+  let th@THandle {sessionId} = smpTHandle c
+  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
+  getHandshake th >>= \case
+    ClientHandshake {smpVersion, keyHash}
+      | keyHash /= kh ->
+        throwE $ TEHandshake IDENTITY
+      | smpVersion `isCompatible` supportedSMPVersions -> do
+        pure (th :: THandle c) {thVersion = smpVersion}
+      | otherwise -> throwE $ TEHandshake VERSION
 
--- | Client SMP encrypted transport handshake.
+-- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
---
--- The numbers in function names refer to the steps in the document.
-clientHandshake :: forall c. Transport c => c -> Maybe Int -> Maybe C.KeyHash -> ExceptT TransportError IO (THandle c)
-clientHandshake c blkSize_ keyHash = do
-  mapM_ checkValidBlockSize blkSize_
-  (k, blkSize) <- getHeaderAndPublicKey_1_2
-  let clientBlkSize = fromMaybe blkSize blkSize_
-  chs@ClientHandshake {sndKey, rcvKey} <- liftIO $ generateKeys_3 clientBlkSize
-  sendEncryptedKeys_4 k chs
-  th <- liftIO $ transportHandle c sndKey rcvKey clientBlkSize
-  getWelcome_6 th >>= checkVersion
-  pure th
-  where
-    getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey, Int)
-    getHeaderAndPublicKey_1_2 = do
-      header <- liftIO (cGet c serverHeaderSize)
-      ServerHeader {blockSize, keySize} <- liftEither $ parse serverHeaderP (TEHandshake HEADER) header
-      checkValidBlockSize blockSize
-      s <- liftIO $ cGet c keySize
-      maybe (pure ()) (validateKeyHash_2 s) keyHash
-      key <- liftEither $ parseKey s
-      pure (key, blockSize)
-    parseKey :: ByteString -> Either TransportError C.PublicKey
-    parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryPubKeyP
-    validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO ()
-    validateKeyHash_2 k (C.KeyHash kHash)
-      | C.sha256Hash k == kHash = pure ()
-      | otherwise = throwE $ TEHandshake BAD_HASH
-    generateKeys_3 :: Int -> IO ClientHandshake
-    generateKeys_3 blkSize = ClientHandshake blkSize <$> generateKey <*> generateKey
-    generateKey :: IO SessionKey
-    generateKey = do
-      aesKey <- C.randomAesKey
-      baseIV <- C.randomIV
-      pure SessionKey {aesKey, baseIV, counter = undefined}
-    sendEncryptedKeys_4 :: C.PublicKey -> ClientHandshake -> ExceptT TransportError IO ()
-    sendEncryptedKeys_4 k chs =
-      liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake chs)
-        >>= liftIO . cPut c
-    getWelcome_6 :: THandle c -> ExceptT TransportError IO SMPVersion
-    getWelcome_6 th = ExceptT $ (>>= parseSMPVersion) <$> tGetEncrypted th
-    parseSMPVersion :: ByteString -> Either TransportError SMPVersion
-    parseSMPVersion = first (const $ TEHandshake VERSION) . A.parseOnly (smpVersionP <* A.space)
-    checkVersion :: SMPVersion -> ExceptT TransportError IO ()
-    checkVersion smpVersion =
-      when (major smpVersion > major currentSMPVersion) . throwE $
-        TEHandshake MAJOR_VERSION
+smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
+smpClientHandshake c keyHash = do
+  let th@THandle {sessionId} = smpTHandle c
+  ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
+  if sessionId /= sessId
+    then throwE TEBadSession
+    else case smpVersionRange `compatibleVersion` supportedSMPVersions of
+      Just (Compatible smpVersion) -> do
+        sendHandshake th $ ClientHandshake {smpVersion, keyHash}
+        pure (th :: THandle c) {thVersion = smpVersion}
+      Nothing -> throwE $ TEHandshake VERSION
 
-checkValidBlockSize :: Int -> ExceptT TransportError IO ()
-checkValidBlockSize blkSize =
-  when (blkSize `notElem` transportBlockSizes) . throwError $ TEHandshake HEADER
+sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
+sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
-data ServerHeader = ServerHeader {blockSize :: Int, keySize :: Int}
-  deriving (Eq, Show)
+getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
+getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
-binaryRsaTransport :: Int
-binaryRsaTransport = 0
-
-transportBlockSizes :: [Int]
-transportBlockSizes = map (* 1024) [4, 8, 16, 32, 64]
-
-serverHeaderSize :: Int
-serverHeaderSize = 8
-
-binaryServerHeader :: ServerHeader -> ByteString
-binaryServerHeader ServerHeader {blockSize, keySize} =
-  encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> encodeEnum16 keySize
-
-serverHeaderP :: Parser ServerHeader
-serverHeaderP = ServerHeader <$> int32 <* binaryRsaTransportP <*> int16
-
-serializeClientHandshake :: ClientHandshake -> ByteString
-serializeClientHandshake ClientHandshake {blockSize, sndKey, rcvKey} =
-  encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> serializeKey sndKey <> serializeKey rcvKey
-  where
-    serializeKey :: SessionKey -> ByteString
-    serializeKey SessionKey {aesKey, baseIV} = C.unKey aesKey <> C.unIV baseIV
-
-clientHandshakeP :: Parser ClientHandshake
-clientHandshakeP = ClientHandshake <$> int32 <* binaryRsaTransportP <*> keyP <*> keyP
-  where
-    keyP :: Parser SessionKey
-    keyP = do
-      aesKey <- C.aesKeyP
-      baseIV <- C.ivP
-      pure SessionKey {aesKey, baseIV, counter = undefined}
-
-int32 :: Parser Int
-int32 = decodeNum32 <$> A.take 4
-
-int16 :: Parser Int
-int16 = decodeNum16 <$> A.take 2
-
-binaryRsaTransportP :: Parser ()
-binaryRsaTransportP = binaryRsa =<< int16
-  where
-    binaryRsa :: Int -> Parser ()
-    binaryRsa n
-      | n == binaryRsaTransport = pure ()
-      | otherwise = fail "unknown transport mode"
-
-parseClientHandshake :: ByteString -> Either TransportError ClientHandshake
-parseClientHandshake = parse clientHandshakeP $ TEHandshake AES_KEYS
-
-transportHandle :: c -> SessionKey -> SessionKey -> Int -> IO (THandle c)
-transportHandle c sk rk blockSize = do
-  sndCounter <- newTVarIO 0
-  rcvCounter <- newTVarIO 0
-  pure
-    THandle
-      { connection = c,
-        sndKey = sk {counter = sndCounter},
-        rcvKey = rk {counter = rcvCounter},
-        blockSize
-      }
+smpTHandle :: Transport c => c -> THandle c
+smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}

src/Simplex/Messaging/Transport/Client.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Transport.Client
+  ( runTransportClient,
+    runTLSTransportClient,
+    smpClientHandshake,
+  )
+where
+
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Default (def)
+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 qualified Network.TLS as T
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.KeepAlive
+import System.IO.Error
+import UnliftIO.Exception (IOException)
+import qualified UnliftIO.Exception as E
+
+-- | Connect to passed TCP host:port and pass handle to the client.
+runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> 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 -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do
+  let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
+  c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
+  client c `E.finally` liftIO (closeConnection c)
+
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
+startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
+  where
+    err :: IOException
+    err = mkIOError NoSuchThing "no address" Nothing Nothing
+
+    resolve :: IO [AddrInfo]
+    resolve =
+      let hints = defaultHints {addrSocketType = Stream}
+       in getAddrInfo (Just hints) (Just host) (Just port)
+
+    tryOpen :: IOException -> [AddrInfo] -> IO c
+    tryOpen e [] = E.throwIO e
+    tryOpen _ (addr : as) =
+      E.try (open addr) >>= either (`tryOpen` as) pure
+
+    open :: AddrInfo -> IO c
+    open addr = do
+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+      connect sock $ addrAddress addr
+      mapM_ (setSocketKeepAlive sock) keepAliveOpts
+      ctx <- connectTLS clientParams sock
+      getClientConnection ctx
+
+-- readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
+
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
+mkTLSClientParams supported caStore_ 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
+    }
+
+validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
+validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
+validateCertificateChain _ _ _ (X.CertificateChain [_]) = pure [XV.EmptyChain]
+validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_, caCert]) =
+  if Fingerprint kh == XV.getFingerprint caCert X.HashSHA256
+    then x509validate
+    else pure [XV.UnknownCA]
+  where
+    x509validate :: IO [XV.FailedReason]
+    x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
+      where
+        hooks = XV.defaultHooks
+        checks = XV.defaultChecks
+        certStore = XS.makeCertificateStore sc
+        cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
+        serviceID = (host, port)
+validateCertificateChain _ _ _ _ = pure [XV.AuthorityTooDeep]

src/Simplex/Messaging/Transport/HTTP2.hs

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

@@ -0,0 +1,128 @@
+{-# 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 (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 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

@@ -0,0 +1,70 @@
+{-# 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` [])

src/Simplex/Messaging/Transport/KeepAlive.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Transport.KeepAlive where
+
+import Foreign.C (CInt (..))
+import Network.Socket
+
+data KeepAliveOpts = KeepAliveOpts
+  { keepIdle :: Int,
+    keepIntvl :: Int,
+    keepCnt :: Int
+  }
+  deriving (Show)
+
+defaultKeepAliveOpts :: KeepAliveOpts
+defaultKeepAliveOpts =
+  KeepAliveOpts
+    { keepIdle = 30,
+      keepIntvl = 15,
+      keepCnt = 4
+    }
+
+_SOL_TCP :: CInt
+_SOL_TCP = 6
+
+#if defined(mingw32_HOST_OS)
+-- Windows
+
+-- The values are copied from windows::Win32::Networking::WinSock
+-- https://microsoft.github.io/windows-docs-rs/doc/windows/Win32/Networking/WinSock/index.html
+
+_TCP_KEEPIDLE :: CInt
+_TCP_KEEPIDLE = 3
+
+_TCP_KEEPINTVL :: CInt
+_TCP_KEEPINTVL = 17
+
+_TCP_KEEPCNT :: CInt
+_TCP_KEEPCNT = 16
+
+#else
+-- Mac/Linux
+
+#if defined(darwin_HOST_OS)
+foreign import capi "netinet/tcp.h value TCP_KEEPALIVE" _TCP_KEEPIDLE :: CInt
+#else
+foreign import capi "netinet/tcp.h value TCP_KEEPIDLE" _TCP_KEEPIDLE :: CInt
+#endif
+
+foreign import capi "netinet/tcp.h value TCP_KEEPINTVL" _TCP_KEEPINTVL :: CInt
+
+foreign import capi "netinet/tcp.h value TCP_KEEPCNT" _TCP_KEEPCNT :: CInt
+
+#endif
+
+setSocketKeepAlive :: Socket -> KeepAliveOpts -> IO ()
+setSocketKeepAlive sock KeepAliveOpts {keepCnt, keepIdle, keepIntvl} = do
+  setSocketOption sock KeepAlive 1
+  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPIDLE) keepIdle
+  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPINTVL) keepIntvl
+  setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPCNT) keepCnt

src/Simplex/Messaging/Transport/Server.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Transport.Server
+  ( runTransportServer,
+    runTCPServer,
+    loadSupportedTLSServerParams,
+    loadTLSServerParams,
+    loadFingerprint,
+    smpServerHandshake,
+  )
+where
+
+import Control.Concurrent.STM (stateTVar)
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import qualified Crypto.Store.X509 as SX
+import Data.Default (def)
+import qualified Data.X509 as X
+import Data.X509.Validation (Fingerprint (..))
+import qualified Data.X509.Validation as XV
+import Network.Socket
+import qualified Network.TLS as T
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport
+import Simplex.Messaging.Util (catchAll_)
+import System.Exit (exitFailure)
+import System.Mem.Weak (Weak, deRefWeak)
+import UnliftIO.Concurrent
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+-- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
+--
+-- All accepted connections are passed to the passed function.
+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
+runTransportServer started port serverParams server = do
+  u <- askUnliftIO
+  liftIO . runTCPServer started port $ \conn ->
+    E.bracket
+      (connectTLS serverParams conn >>= getServerConnection)
+      closeConnection
+      (unliftIO u . server)
+
+-- | Run TCP server without TLS
+runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
+runTCPServer started port server = do
+  clients <- atomically TM.empty
+  clientId <- newTVarIO 0
+  E.bracket
+    (startTCPServer started port)
+    (closeServer started clients)
+    $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
+      -- catchAll_ is needed here in case the connection was closed earlier
+      cId <- atomically $ stateTVar clientId $ \cId -> (cId + 1, cId + 1)
+      let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
+      tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
+      atomically $ TM.insert cId tId clients
+
+closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
+closeServer started clients sock = do
+  readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
+  close sock
+  void . atomically $ tryPutTMVar started False
+
+startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
+startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
+  where
+    resolve =
+      let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
+       in head <$> getAddrInfo (Just hints) Nothing (Just port)
+    open addr = do
+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+      setSocketOption sock ReuseAddr 1
+      withFdSocket sock setCloseOnExecIfNeeded
+      bind sock $ addrAddress addr
+      listen sock 1024
+      return sock
+    setStarted sock = atomically (tryPutTMVar started True) >> pure sock
+
+loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
+loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
+
+loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
+loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
+  fromCredential <$> loadServerCredential
+  where
+    loadServerCredential :: IO T.Credential
+    loadServerCredential =
+      T.credentialLoadX509Chain certificateFile [caCertificateFile] privateKeyFile >>= \case
+        Right credential -> pure credential
+        Left _ -> putStrLn "invalid credential" >> exitFailure
+    fromCredential :: T.Credential -> T.ServerParams
+    fromCredential credential =
+      def
+        { T.serverWantClientCert = False,
+          T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
+          T.serverHooks = def,
+          T.serverSupported = serverSupported
+        }
+
+loadFingerprint :: FilePath -> IO Fingerprint
+loadFingerprint certificateFile = do
+  (cert : _) <- SX.readSignedObject certificateFile
+  pure $ XV.getFingerprint (cert :: X.SignedExact X.Certificate) X.HashSHA256

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -1,23 +1,39 @@
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Transport.WebSockets (WS (..)) where
 
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Network.Socket (Socket)
+import qualified Data.ByteString.Lazy as BL
+import qualified Network.TLS as T
 import Network.WebSockets
 import Network.WebSockets.Stream (Stream)
 import qualified Network.WebSockets.Stream as S
-import Simplex.Messaging.Transport (TProxy, Transport (..), TransportError (..), trimCR)
+import Simplex.Messaging.Transport
+  ( TProxy,
+    Transport (..),
+    TransportError (..),
+    TransportPeer (..),
+    closeTLS,
+    trimCR,
+    withTlsUnique,
+  )
 
-data WS = WS {wsStream :: Stream, wsConnection :: Connection}
+data WS = WS
+  { wsPeer :: TransportPeer,
+    tlsUniq :: ByteString,
+    wsStream :: Stream,
+    wsConnection :: Connection
+  }
 
 websocketsOpts :: ConnectionOptions
 websocketsOpts =
   defaultConnectionOptions
     { connectionCompressionOptions = NoCompression,
-      connectionFramePayloadSizeLimit = SizeLimit 8192,
+      connectionFramePayloadSizeLimit = SizeLimit $ 16 * 1024, -- TODO move to Protocol
       connectionMessageDataSizeLimit = SizeLimit 65536
     }
 
@@ -25,21 +41,17 @@ instance Transport WS where
   transportName :: TProxy WS -> String
   transportName _ = "WebSockets"
 
-  getServerConnection :: Socket -> IO WS
-  getServerConnection sock = do
-    s <- S.makeSocketStream sock
-    WS s <$> acceptClientRequest s
-    where
-      acceptClientRequest :: Stream -> IO Connection
-      acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
+  transportPeer :: WS -> TransportPeer
+  transportPeer = wsPeer
 
-  getClientConnection :: Socket -> IO WS
-  getClientConnection sock = do
-    s <- S.makeSocketStream sock
-    WS s <$> sendClientRequest s
-    where
-      sendClientRequest :: Stream -> IO Connection
-      sendClientRequest s = newClientConnection s "" "/" websocketsOpts []
+  getServerConnection :: T.Context -> IO WS
+  getServerConnection = getWS TServer
+
+  getClientConnection :: T.Context -> IO WS
+  getClientConnection = getWS TClient
+
+  tlsUnique :: WS -> ByteString
+  tlsUnique = tlsUniq
 
   closeConnection :: WS -> IO ()
   closeConnection = S.close . wsStream
@@ -60,3 +72,28 @@ instance Transport WS where
     if B.null s || B.last s /= '\n'
       then E.throwIO TEBadBlock
       else pure $ B.init s
+
+getWS :: TransportPeer -> T.Context -> IO WS
+getWS wsPeer cxt = withTlsUnique wsPeer cxt connectWS
+  where
+    connectWS tlsUniq = do
+      s <- makeTLSContextStream cxt
+      wsConnection <- connectPeer wsPeer s
+      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection}
+    connectPeer :: TransportPeer -> Stream -> IO Connection
+    connectPeer TServer = acceptClientRequest
+    connectPeer TClient = sendClientRequest
+    acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
+    sendClientRequest s = newClientConnection s "" "/" websocketsOpts []
+
+makeTLSContextStream :: T.Context -> IO Stream
+makeTLSContextStream cxt =
+  S.makeStream readStream writeStream
+  where
+    readStream :: IO (Maybe ByteString)
+    readStream =
+      (Just <$> T.recvData cxt) `E.catch` \case
+        T.Error_EOF -> pure Nothing
+        e -> E.throwIO e
+    writeStream :: Maybe BL.ByteString -> IO ()
+    writeStream = maybe (closeTLS cxt) (T.sendData cxt)

src/Simplex/Messaging/Util.hs

@@ -1,29 +1,16 @@
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE RankNTypes #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Util where
 
+import qualified Control.Exception as E
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import UnliftIO.Async
-import UnliftIO.Exception (Exception)
-import qualified UnliftIO.Exception as E
-
-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)
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
 raceAny_ = r []
@@ -35,21 +22,59 @@ infixl 4 <$$>, <$?>
 
 (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
 (<$$>) = fmap . fmap
+{-# INLINE (<$$>) #-}
 
 (<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b
-f <$?> m = m >>= either fail pure . f
+f <$?> m = either fail pure . f =<< m
+{-# INLINE (<$?>) #-}
 
 bshow :: Show a => a -> ByteString
 bshow = B.pack . show
+{-# INLINE bshow #-}
+
+maybeWord :: (a -> ByteString) -> Maybe a -> ByteString
+maybeWord f = maybe "" $ B.cons ' ' . f
+{-# INLINE maybeWord #-}
 
 liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
 liftIOEither a = liftIO a >>= liftEither
+{-# INLINE liftIOEither #-}
 
 liftError :: (MonadIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a
 liftError f = liftEitherError f . runExceptT
+{-# INLINE liftError #-}
 
 liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a
 liftEitherError f a = liftIOEither (first f <$> a)
+{-# INLINE liftEitherError #-}
 
 tryError :: MonadError e m => m a -> m (Either e a)
 tryError action = (Right <$> action) `catchError` (pure . Left)
+{-# INLINE tryError #-}
+
+tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
+tryE m = (Right <$> m) `catchE` (pure . Left)
+{-# INLINE tryE #-}
+
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM ba t f = ba >>= \b -> if b then t else f
+{-# INLINE ifM #-}
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM b a = ifM b a $ pure ()
+{-# INLINE whenM #-}
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM b = ifM b $ pure ()
+{-# INLINE unlessM #-}
+
+($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
+f $>>= g = f >>= fmap join . mapM g
+
+catchAll :: IO a -> (E.SomeException -> IO a) -> IO a
+catchAll = E.catch
+{-# INLINE catchAll #-}
+
+catchAll_ :: IO a -> IO a -> IO a
+catchAll_ a = catchAll a . const
+{-# INLINE catchAll_ #-}

src/Simplex/Messaging/Version.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Simplex.Messaging.Version
+  ( Version,
+    VersionRange (minVersion, maxVersion),
+    pattern VersionRange,
+    VersionI (..),
+    VersionRangeI (..),
+    Compatible,
+    pattern Compatible,
+    mkVersionRange,
+    safeVersionRange,
+    isCompatible,
+    proveCompatible,
+    compatibleVersion,
+  )
+where
+
+import Control.Applicative (optional)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Word (Word16)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Util ((<$?>))
+
+pattern VersionRange :: Word16 -> Word16 -> VersionRange
+pattern VersionRange v1 v2 <- VRange v1 v2
+
+{-# COMPLETE VersionRange #-}
+
+type Version = Word16
+
+data VersionRange = VRange
+  { minVersion :: Version,
+    maxVersion :: Version
+  }
+  deriving (Eq, Show)
+
+-- | construct valid version range, to be used in constants
+mkVersionRange :: Version -> Version -> VersionRange
+mkVersionRange v1 v2
+  | v1 <= v2 = VRange v1 v2
+  | otherwise = error "invalid version range"
+
+safeVersionRange :: Version -> Version -> Maybe VersionRange
+safeVersionRange v1 v2
+  | v1 <= v2 = Just $ VRange v1 v2
+  | otherwise = Nothing
+
+instance Encoding VersionRange where
+  smpEncode (VRange v1 v2) = smpEncode (v1, v2)
+  smpP =
+    maybe (fail "invalid version range") pure
+      =<< safeVersionRange <$> smpP <*> smpP
+
+instance StrEncoding VersionRange where
+  strEncode (VRange v1 v2)
+    | v1 == v2 = strEncode v1
+    | otherwise = strEncode v1 <> "-" <> strEncode v2
+  strP = do
+    v1 <- strP
+    v2 <- maybe (pure v1) (const strP) =<< optional (A.char '-')
+    maybe (fail "invalid version range") pure $ safeVersionRange v1 v2
+
+instance ToJSON VersionRange where
+  toJSON (VRange v1 v2) = toJSON (v1, v2)
+  toEncoding (VRange v1 v2) = toEncoding (v1, v2)
+
+instance FromJSON VersionRange where
+  parseJSON v =
+    (\(v1, v2) -> maybe (Left "bad VersionRange") Right $ safeVersionRange v1 v2)
+      <$?> parseJSON v
+
+class VersionI a where
+  type VersionRangeT a
+  version :: a -> Version
+  toVersionRangeT :: a -> VersionRange -> VersionRangeT a
+
+class VersionRangeI a where
+  type VersionT a
+  versionRange :: a -> VersionRange
+  toVersionT :: a -> Version -> VersionT a
+
+instance VersionI Version where
+  type VersionRangeT Version = VersionRange
+  version = id
+  toVersionRangeT _ vr = vr
+
+instance VersionRangeI VersionRange where
+  type VersionT VersionRange = Version
+  versionRange = id
+  toVersionT _ v = v
+
+newtype Compatible a = Compatible_ a
+
+pattern Compatible :: a -> Compatible a
+pattern Compatible a <- Compatible_ a
+
+{-# COMPLETE Compatible #-}
+
+isCompatible :: VersionI a => a -> VersionRange -> Bool
+isCompatible x (VRange v1 v2) = let v = version x in v1 <= v && v <= v2
+
+isCompatibleRange :: VersionRangeI a => a -> VersionRange -> Bool
+isCompatibleRange x (VRange min2 max2) = min1 <= max2 && min2 <= max1
+  where
+    VRange min1 max1 = versionRange x
+
+proveCompatible :: VersionI a => a -> VersionRange -> Maybe (Compatible a)
+proveCompatible x vr = x `mkCompatibleIf` (x `isCompatible` vr)
+
+compatibleVersion :: VersionRangeI a => a -> VersionRange -> Maybe (Compatible (VersionT a))
+compatibleVersion x vr =
+  toVersionT x (min max1 max2) `mkCompatibleIf` isCompatibleRange x vr
+  where
+    max1 = maxVersion $ versionRange x
+    max2 = maxVersion vr
+
+mkCompatibleIf :: a -> Bool -> Maybe (Compatible a)
+x `mkCompatibleIf` cond = if cond then Just $ Compatible_ x else Nothing

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.0
+resolver: lts-18.28
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -36,15 +36,22 @@ packages:
 #
 extra-deps:
   - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
-  - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
+  - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
-# - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885
-# - git: https://github.com/commercialhaskell/stack.git
-#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#
-# extra-deps: []
-
+  - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987 # below dependancies are to update Aeson to 2.0.3
+  - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
+  - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
+  - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005
+  - semialign-1.2.0.1@sha256:0e179b4d3a8eff79001d374d6c91917c6221696b9620f0a4d86852fc6a9b9501,2836
+  - text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498
+  - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
+  - github: simplex-chat/aeson
+    commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
+  # - ../hs-tls/core
+  # - github: simplex-chat/hs-tls
+  #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e
+  #   subdirs:
+  #     - core
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

tests/AgentTests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -10,26 +9,37 @@
 
 module AgentTests (agentTests) where
 
+import AgentTests.ConnectionRequestTests
+import AgentTests.DoubleRatchetTests (doubleRatchetTests)
 import AgentTests.FunctionalAPITests (functionalAPITests)
 import AgentTests.SQLiteTests (storeTests)
+import AgentTests.SchemaDump (schemaDumpTest)
 import Control.Concurrent
+import Control.Monad (forM_)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
-import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
+import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent.Protocol
+import qualified Simplex.Messaging.Agent.Protocol as A
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
 import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
+import Simplex.Messaging.Util (bshow)
 import System.Directory (removeFile)
 import System.Timeout
 import Test.Hspec
 
 agentTests :: ATransport -> Spec
 agentTests (ATransport t) = do
+  describe "Connection request" connectionRequestTests
+  describe "Double ratchet tests" doubleRatchetTests
   describe "Functional API" $ functionalAPITests (ATransport t)
   describe "SQLite store" storeTests
+  describe "SQLite schema dump" schemaDumpTest
   describe "SMP agent protocol syntax" $ syntaxTests t
-  describe "Establishing duplex connection" do
+  describe "Establishing duplex connection" $ do
     it "should connect via one server and one agent" $
       smpAgentTest2_1_1 $ testDuplexConnection t
     it "should connect via one server and one agent (random IDs)" $
@@ -42,16 +52,29 @@ agentTests (ATransport t) = do
       smpAgentTest2_2_2 $ testDuplexConnection t
     it "should connect via 2 servers and 2 agents (random IDs)" $
       smpAgentTest2_2_2 $ testDuplexConnRandomIds t
-  describe "Connection subscriptions" do
+  describe "Establishing connections via `contact connection`" $ do
+    it "should connect via contact connection with one server and 3 agents" $
+      smpAgentTest3 $ testContactConnection t
+    it "should connect via contact connection with one server and 2 agents (random IDs)" $
+      smpAgentTest2_2_1 $ testContactConnRandomIds t
+    it "should support rejecting contact request" $
+      smpAgentTest2_2_1 $ testRejectContactRequest t
+  describe "Connection subscriptions" $ do
     it "should connect via one server and one agent" $
       smpAgentTest3_1_1 $ testSubscription t
     it "should send notifications to client when server disconnects" $
       smpAgentServerTest $ testSubscrNotification t
-  describe "Message delivery" do
+  describe "Message delivery and server reconnection" $ do
     it "should deliver messages after losing server connection and re-connecting" $
       smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
+    it "should connect to the server when server goes up if it initially was down" $
+      smpAgentTestN [] $ testServerConnectionAfterError t
     it "should deliver pending messages after agent restarting" $
       smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
+    it "should concurrently deliver messages to connections without blocking" $
+      smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
+    it "should deliver messages if one of connections has quota exceeded" $
+      smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
 
 -- | receive message to handle `h`
 (<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
@@ -64,7 +87,7 @@ h #: t = tPutRaw h t >> (<#:) h
 -- | action and expected response
 -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
 (#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation
-action #> (corrId, cAlias, cmd) = action `shouldReturn` (corrId, cAlias, Right cmd)
+action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd)
 
 -- | action and predicate for the response
 -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`
@@ -72,13 +95,13 @@ action #> (corrId, cAlias, cmd) = action `shouldReturn` (corrId, cAlias, Right c
 action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
 
 correctTransmission :: ATransmissionOrError a -> ATransmission a
-correctTransmission (corrId, cAlias, cmdOrErr) = case cmdOrErr of
-  Right cmd -> (corrId, cAlias, cmd)
+correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
+  Right cmd -> (corrId, connId, cmd)
   Left e -> error $ show e
 
 -- | receive message to handle `h` and validate that it is the expected one
 (<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
-h <# (corrId, cAlias, cmd) = (h <#:) `shouldReturn` (corrId, cAlias, Right cmd)
+h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)
 
 -- | receive message to handle `h` and validate it using predicate `p`
 (<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
@@ -98,94 +121,161 @@ pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
-  ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW")
-  let qInfo' = serializeSmpQueueInfo qInfo
-  bob #: ("11", "alice", "JOIN " <> qInfo' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "bob", Right (REQ confId "bob's connInfo")) <- (alice <#:)
-  alice #: ("2", "bob", "ACPT " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
+  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
+  let cReq' = strEncode cReq
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
+  alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   bob <# ("", "alice", INFO "alice's connInfo")
   bob <# ("", "alice", CON)
   alice <# ("", "bob", CON)
-  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 1)
-  alice <# ("", "bob", SENT 1)
+  -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
+  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 5)
+  alice <# ("", "bob", SENT 5)
   bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-  bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
-  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 2)
-  alice <# ("", "bob", SENT 2)
+  bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
+  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 6)
+  alice <# ("", "bob", SENT 6)
   bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
-  bob #: ("13", "alice", "ACK 2") #> ("13", "alice", OK)
-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 3)
-  bob <# ("", "alice", SENT 3)
+  bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 7)
+  bob <# ("", "alice", SENT 7)
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  alice #: ("3a", "bob", "ACK 3") #> ("3a", "bob", OK)
-  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 4)
-  bob <# ("", "alice", SENT 4)
+  alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
+  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 8)
+  bob <# ("", "alice", SENT 8)
   alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
-  alice #: ("4a", "bob", "ACK 4") #> ("4a", "bob", OK)
+  alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
-  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 5)
-  bob <# ("", "alice", MERR 5 (SMP AUTH))
+  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 9)
+  bob <# ("", "alice", MERR 9 (SMP AUTH))
   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
   alice #:# "nothing else should be delivered to alice"
 
 testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnRandomIds _ alice bob = do
-  ("1", bobConn, Right (INV qInfo)) <- alice #: ("1", "", "NEW")
-  let qInfo' = serializeSmpQueueInfo qInfo
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> qInfo' <> " 14\nbob's connInfo")
-  ("", bobConn', Right (REQ confId "bob's connInfo")) <- (alice <#:)
+  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
+  let cReq' = strEncode cReq
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
+  ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
   bobConn' `shouldBe` bobConn
-  alice #: ("2", bobConn, "ACPT " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
+  alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
   bob <# ("", aliceConn, INFO "alice's connInfo")
   bob <# ("", aliceConn, CON)
   alice <# ("", bobConn, CON)
-  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 1)
-  alice <# ("", bobConn, SENT 1)
+  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 5)
+  alice <# ("", bobConn, SENT 5)
   bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
-  bob #: ("12", aliceConn, "ACK 1") #> ("12", aliceConn, OK)
-  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 2)
-  alice <# ("", bobConn, SENT 2)
+  bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
+  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 6)
+  alice <# ("", bobConn, SENT 6)
   bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
-  bob #: ("13", aliceConn, "ACK 2") #> ("13", aliceConn, OK)
-  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 3)
-  bob <# ("", aliceConn, SENT 3)
+  bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
+  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 7)
+  bob <# ("", aliceConn, SENT 7)
   alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
-  alice #: ("3a", bobConn, "ACK 3") #> ("3a", bobConn, OK)
-  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 4)
-  bob <# ("", aliceConn, SENT 4)
+  alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
+  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 8)
+  bob <# ("", aliceConn, SENT 8)
   alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
-  alice #: ("4a", bobConn, "ACK 4") #> ("4a", bobConn, OK)
+  alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
   alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
-  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 5)
-  bob <# ("", aliceConn, MERR 5 (SMP AUTH))
+  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 9)
+  bob <# ("", aliceConn, MERR 9 (SMP AUTH))
   alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
   alice #:# "nothing else should be delivered to alice"
 
+testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
+testContactConnection _ alice bob tom = do
+  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")
+  let cReq' = strEncode cReq
+
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
+  ("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
+  alice <# ("", "bob", INFO "bob's connInfo 2")
+  alice <# ("", "bob", CON)
+  bob <# ("", "alice", CON)
+  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 5)
+  alice <# ("", "bob", SENT 5)
+  bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
+  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
+
+  tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
+  alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
+  ("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
+  tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
+  alice <# ("", "tom", INFO "tom's connInfo 2")
+  alice <# ("", "tom", CON)
+  tom <# ("", "alice", CON)
+  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 5)
+  alice <# ("", "tom", SENT 5)
+  tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
+  tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
+
+testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
+testContactConnRandomIds _ alice bob = do
+  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")
+  let cReq' = strEncode cReq
+
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
+  ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  aliceContact' `shouldBe` aliceContact
+
+  ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
+  ("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  aliceConn' `shouldBe` aliceConn
+
+  bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
+  alice <# ("", bobConn, INFO "bob's connInfo 2")
+  alice <# ("", bobConn, CON)
+  bob <# ("", aliceConn, CON)
+
+  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 5)
+  alice <# ("", bobConn, SENT 5)
+  bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
+  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
+
+testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
+testRejectContactRequest _ alice bob = do
+  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")
+  let cReq' = strEncode cReq
+  bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
+  ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)
+  -- RJCT must use correct contact connection
+  alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
+  alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
+  alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED)
+  bob #:# "nothing should be delivered to bob"
+
 testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testSubscription _ alice1 alice2 bob = do
   (alice1, "alice") `connect` (bob, "bob")
-  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 1)
-  bob <# ("", "alice", SENT 1)
+  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 5)
+  bob <# ("", "alice", SENT 5)
   alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
-  alice1 #: ("1", "bob", "ACK 1") #> ("1", "bob", OK)
-  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 2)
-  bob <# ("", "alice", SENT 2)
+  alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
+  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
   alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-  alice1 #: ("2", "bob", "ACK 2") #> ("2", "bob", OK)
+  alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
   alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
   alice1 <# ("", "bob", END)
-  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 3)
-  bob <# ("", "alice", SENT 3)
+  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 7)
+  bob <# ("", "alice", SENT 7)
   alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-  alice2 #: ("22", "bob", "ACK 3") #> ("22", "bob", OK)
+  alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
   alice1 #:# "nothing else should be delivered to alice1"
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
 testSubscrNotification t (server, _) client = do
-  client #: ("1", "conn1", "NEW") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
+  client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
-  client <# ("", "conn1", DOWN)
+  client <# ("", "", DOWN testSMPServer ["conn1"])
   withSmpServer (ATransport t) $
     client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
 
@@ -193,40 +283,80 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
 testMsgDeliveryServerRestart t alice bob = do
   withServer $ do
     connect (alice, "alice") (bob, "bob")
-    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 1)
-    bob <# ("", "alice", SENT 1)
+    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 5)
+    bob <# ("", "alice", SENT 5)
     alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
-    alice #: ("11", "bob", "ACK 1") #> ("11", "bob", OK)
+    alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
-  alice <# ("", "bob", DOWN)
-  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 2)
+  let server = (SMPServer "localhost" testPort2 testKeyHash)
+  alice <# ("", "", DOWN server ["bob"])
+  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 6)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
-    bob <# ("", "alice", SENT 2)
-    alice <# ("", "bob", UP)
+    bob <# ("", "alice", SENT 6)
+    alice <# ("", "", UP server ["bob"])
     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-    alice #: ("12", "bob", "ACK 2") #> ("12", "bob", OK)
+    alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
 
   removeFile testStoreLogFile
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
 
+testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
+testServerConnectionAfterError t _ = do
+  withAgent1 $ \bob -> do
+    withAgent2 $ \alice -> do
+      withServer $ do
+        connect (bob, "bob") (alice, "alice")
+
+      bob <# ("", "", DOWN server ["alice"])
+      alice <# ("", "", DOWN server ["bob"])
+      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
+      alice #:# "nothing else delivered before the server is restarted"
+      bob #:# "nothing else delivered before the server is restarted"
+
+  withAgent1 $ \bob -> do
+    withAgent2 $ \alice -> do
+      bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
+      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
+      withServer $ do
+        alice <# ("", "bob", SENT 5)
+        bob <# ("", "", UP server ["alice"])
+        bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
+        bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
+        alice <# ("", "", UP server ["bob"])
+        alice #: ("1", "bob", "SEND 11\nhello again") #> ("1", "bob", MID 6)
+        alice <# ("", "bob", SENT 6)
+        bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
+
+  removeFile testStoreLogFile
+  removeFile testDB
+  removeFile testDB2
+  where
+    server = SMPServer "localhost" testPort2 testKeyHash
+    withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
+    withAgent1 = withAgent agentTestPort testDB
+    withAgent2 = withAgent agentTestPort2 testDB2
+    withAgent :: String -> String -> (c -> IO a) -> IO a
+    withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
+
 testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
 testMsgDeliveryAgentRestart t bob = do
+  let server = SMPServer "localhost" testPort2 testKeyHash
   withAgent $ \alice -> do
     withServer $ do
       connect (bob, "bob") (alice, "alice")
-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 1)
-      alice <# ("", "bob", SENT 1)
+      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
+      alice <# ("", "bob", SENT 5)
       bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-      bob #: ("11", "alice", "ACK 1") #> ("11", "alice", OK)
+      bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
       bob #:# "nothing else delivered before the server is down"
 
-    bob <# ("", "alice", DOWN)
-    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 2)
+    bob <# ("", "", DOWN server ["alice"])
+    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 6)
     alice #:# "nothing else delivered before the server is restarted"
     bob #:# "nothing else delivered before the server is restarted"
 
@@ -236,11 +366,11 @@ testMsgDeliveryAgentRestart t bob = do
       alice <#= \case
         (corrId, "bob", cmd) ->
           (corrId == "3" && cmd == OK)
-            || (corrId == "" && cmd == SENT 2)
+            || (corrId == "" && cmd == SENT 6)
         _ -> False
-      bob <# ("", "alice", UP)
+      bob <# ("", "", UP server ["alice"])
       bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
-      bob #: ("12", "alice", "ACK 2") #> ("12", "alice", OK)
+      bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
   removeFile testDB
@@ -248,22 +378,73 @@ testMsgDeliveryAgentRestart t bob = do
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort
 
+testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
+testConcurrentMsgDelivery _ alice bob = do
+  connect (alice, "alice") (bob, "bob")
+
+  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")
+  let cReq' = strEncode cReq
+  bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
+  ("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)
+  -- below commands would be needed to accept bob's connection, but alice does not
+  -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
+  -- bob <# ("", "alice", INFO "alice's connInfo")
+  -- bob <# ("", "alice", CON)
+  -- alice <# ("", "bob", CON)
+
+  -- the first connection should not be blocked by the second one
+  sendMessage (alice, "alice") (bob, "bob") "hello"
+  -- alice #: ("2", "bob", "SEND :hello") #> ("2", "bob", MID 1)
+  -- alice <# ("", "bob", SENT 1)
+  -- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
+  -- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
+  bob <# ("", "alice", SENT 6)
+  -- if delivery is blocked it won't go further
+  alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
+  alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
+
+testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
+testMsgDeliveryQuotaExceeded _ alice bob = do
+  connect (alice, "alice") (bob, "bob")
+  connect (alice, "alice2") (bob, "bob2")
+  forM_ [1 .. 4 :: Int] $ \i -> do
+    let corrId = bshow i
+        msg = "message " <> bshow i
+    (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND :" <> msg)
+    alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
+  (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
+
+  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 5)
+  -- if delivery is blocked it won't go further
+  alice <# ("", "bob2", SENT 5)
+
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
-  ("c1", _, Right (INV qInfo)) <- h1 #: ("c1", name2, "NEW")
-  let qInfo' = serializeSmpQueueInfo qInfo
-  h2 #: ("c2", name1, "JOIN " <> qInfo' <> " 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (REQ connId "info2")) <- (h1 <#:)
-  h1 #: ("c3", name2, "ACPT " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
+  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
+  let cReq' = strEncode cReq
+  h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
+  ("", _, Right (CONF connId "info2")) <- (h1 <#:)
+  h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
   h2 <# ("", name1, INFO "info1")
   h2 <# ("", name1, CON)
   h1 <# ("", name2, CON)
 
+sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
+sendMessage (h1, name1) (h2, name2) msg = do
+  ("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND :" <> msg)
+  name2' `shouldBe` name2
+  h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
+  ("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} msg')) <- (h2 <#:)
+  name1' `shouldBe` name1
+  msg' `shouldBe` msg
+  h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False
+
 -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
 -- connect' h1 h2 = do
---   ("c1", conn2, Right (INV qInfo)) <- h1 #: ("c1", "", "NEW")
---   let qInfo' = serializeSmpQueueInfo qInfo
---   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> qInfo' <> " 5\ninfo2")
+--   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
+--   let cReq' = strEncode cReq
+--   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
 --   ("", _, Right (REQ connId "info2")) <- (h1 <#:)
 --   h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
 --   h2 <# ("", conn1, INFO "info1")
@@ -271,28 +452,35 @@ connect (h1, name1) (h2, name2) = do
 --   h1 <# ("", conn2, CON)
 --   pure (conn1, conn2)
 
-samplePublicKey :: ByteString
-samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"
+sampleDhKey :: ByteString
+sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
 
 syntaxTests :: forall c. Transport c => TProxy c -> Spec
 syntaxTests t = do
   it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
-  describe "NEW" do
-    describe "valid" do
-      -- TODO: add tests with defined connection alias
-      it "without parameters" $ ("211", "", "NEW") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
-    describe "invalid" do
-      -- TODO: add tests with defined connection alias
-      it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
+  describe "NEW" $ do
+    describe "valid" $ do
+      -- TODO: add tests with defined connection id
+      it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
+    describe "invalid" $ do
+      -- TODO: add tests with defined connection id
+      it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
 
-  describe "JOIN" do
-    describe "valid" do
-      -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)
-      -- TODO: add tests with defined connection alias
+  describe "JOIN" $ do
+    describe "valid" $ do
       it "using same server as in invitation" $
-        ("311", "a", "JOIN smp::localhost:5000::1234::" <> samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")
-    describe "invalid" do
-      -- TODO: JOIN is not merged yet - to be added
+        ( "311",
+          "a",
+          "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
+            <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
+            <> "%40localhost%3A5001%2F3456-w%3D%3D%23"
+            <> urlEncode True sampleDhKey
+            <> "&v=1"
+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> " 14\nbob's connInfo"
+        )
+          >#> ("311", "a", "ERR SMP AUTH")
+    describe "invalid" $ do
       it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
   where
     -- simple test for one command with the expected response
@@ -301,4 +489,4 @@ syntaxTests t = do
 
     -- simple test for one command with a predicate for the expected response
     (>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation
-    command >#>= p = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, cAlias, cmd) -> (cId, cAlias, B.words cmd))
+    command >#>= p = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd))

tests/AgentTests/ConnectionRequestTests.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module AgentTests.ConnectionRequestTests where
+
+import Data.ByteString (ByteString)
+import Network.HTTP.Types (urlEncode)
+import Simplex.Messaging.Agent.Protocol
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Ratchet
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtocolServer (..), smpClientVRange)
+import Simplex.Messaging.Version
+import Test.Hspec
+
+uri :: String
+uri = "smp.simplex.im"
+
+srv :: SMPServer
+srv =
+  ProtocolServer
+    { host = "smp.simplex.im",
+      port = "5223",
+      keyHash = C.KeyHash "\215m\248\251"
+    }
+
+queue :: SMPQueueUri
+queue =
+  SMPQueueUri
+    { smpServer = srv,
+      senderId = "\223\142z\251",
+      clientVRange = smpClientVRange,
+      dhPublicKey = testDhKey
+    }
+
+testDhKey :: C.PublicKeyX25519
+testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
+
+testDhKeyStr :: ByteString
+testDhKeyStr = strEncode testDhKey
+
+testDhKeyStrUri :: ByteString
+testDhKeyStrUri = urlEncode True testDhKeyStr
+
+connReqData :: ConnReqUriData
+connReqData =
+  ConnReqUriData
+    { crScheme = simplexChat,
+      crAgentVRange = smpAgentVRange,
+      crSmpQueues = [queue]
+    }
+
+testDhPubKey :: C.PublicKeyX448
+testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="
+
+testE2ERatchetParams :: E2ERatchetParamsUri 'C.X448
+testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhPubKey
+
+testE2ERatchetParams13 :: E2ERatchetParamsUri 'C.X448
+testE2ERatchetParams13 = E2ERatchetParamsUri (mkVersionRange 1 3) testDhPubKey testDhPubKey
+
+connectionRequest :: AConnectionRequestUri
+connectionRequest =
+  ACR SCMInvitation $
+    CRInvitationUri connReqData testE2ERatchetParams
+
+connectionRequest12 :: AConnectionRequestUri
+connectionRequest12 =
+  ACR SCMInvitation $
+    CRInvitationUri
+      connReqData {crAgentVRange = mkVersionRange 1 2, crSmpQueues = [queue, queue]}
+      testE2ERatchetParams13
+
+connectionRequestTests :: Spec
+connectionRequestTests =
+  describe "connection request parsing / serializing" $ do
+    it "should serialize SMP queue URIs" $ do
+      strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+        `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr
+      strEncode queue {clientVRange = mkVersionRange 1 2}
+        `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr
+    it "should parse SMP queue URIs" $ do
+      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> testDhKeyStr)
+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr)
+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr)
+        `shouldBe` Right queue
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
+        `shouldBe` Right queue
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1-2&dh=" <> testDhKeyStr)
+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
+    it "should serialize connection requests" $ do
+      strEncode connectionRequest
+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
+        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+      strEncode connectionRequest12
+        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
+        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+        <> testDhKeyStrUri
+        <> "&e2e=v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+    it "should parse connection requests" $ do
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
+            <> testDhKeyStrUri
+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&v=1"
+        )
+        `shouldBe` Right connectionRequest
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+            <> testDhKeyStrUri
+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&v=1"
+        )
+        `shouldBe` Right connectionRequest
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+            <> testDhKeyStrUri
+            <> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&v=1-1"
+        )
+        `shouldBe` Right connectionRequest
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D"
+            <> testDhKeyStrUri
+            <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+            <> testDhKeyStrUri
+            <> "&e2e=extra_key%3Dnew%26v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&some_new_param=abc"
+            <> "&v=1-2"
+        )
+        `shouldBe` Right connectionRequest12