Compare commits

..
3 Commits
Author SHA1 Message Date
Evgeny Poberezkin 091fbdd0e9 rename simplexmq-legacy into simplexmq-v0 (#270)
* rename simplexmq-legacy into simplexmq-v0

* split UnliftIO instance of ExceptT
2022-01-11 07:27:30 +00:00
Evgeny Poberezkin 8e4c9634e9 update to use legacy name 2022-01-08 10:13:21 +00:00
Evgeny Poberezkin e237c97d6e legacy package name: simplexmq-legacy 2022-01-08 10:03:27 +00:00
147 changed files with 5324 additions and 19649 deletions
-1
View File
@@ -1 +0,0 @@
* @epoberezkin @efim-poberezkin
-1
View File
@@ -1,2 +1 @@
github: simplex-chat
open_collective: simplex-chat
+1 -1
View File
@@ -1,4 +1,4 @@
{
"template": "${{UNCATEGORIZED}}",
"pr_template": "- ${{TITLE}}"
"pr_template": "- ${{TITLE}}\n"
}
+5 -21
View File
@@ -19,9 +19,9 @@ jobs:
- name: Setup Stack
uses: haskell/actions/setup@v1
with:
ghc-version: "8.10.7"
ghc-version: '8.8.4'
enable-stack: true
stack-version: "latest"
stack-version: 'latest'
- name: Cache dependencies
uses: actions/cache@v2
@@ -31,13 +31,11 @@ jobs:
- 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
@@ -49,32 +47,18 @@ jobs:
commitMode: true
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: |
See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md).
Commits:
Commits, chronological:
${{ 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 }}
-5
View File
@@ -2,8 +2,3 @@
*.db
*.db.bak
*.session.sql
tests/tmp
dist-newstyle/
cabal.project.local
cabal.project.local~
-181
View File
@@ -1,184 +1,3 @@
# 3.3.0
SMP server:
- allow repeated KEY command with the same key (to avoid failures on retries)
SMP agent:
- enable/disable connection notifications
- asynchronous commands that retry on network error
- use SQLCipher
# 3.2.0
SMP agent:
- Support multiple server hostnames (including onion hostnames) in server addresses.
- Network configuration options.
- Options to define rules to choose server hostname.
# 3.1.0
SMP server and agent:
- SMP protocol v4: batching multiple server commands/responses in a transport block.
# 3.0.0
SMP server:
- restore undeliverd messages when the server is restarted.
- SMP protocol v3 to support push notification:
- updated SEND and MSG to add message flags (for notification flag that contros whether the notification is sent and for any future extensions) and to move message meta-data sent to the recipient into the encrypted envelope.
- update NKEY and NID to add e2e encryption keys (for the notification meta-data encryption between SMP server and the client), and update NMSG to include this meta-data.
- update ACK command to include message ID (to avoid acknowledging unprocessed message).
- add NDEL commands to remove notification subscription credentials from SMP queue.
- add GET command to receive messages without subscription - to be used in iOS notification service extension to receive messages without terminating app subscriptions.
SMP agent:
- new protocol for duplex connection handshake reducing traffic and connection time.
- support for SMP notifications server and managing device token.
- remove redundant FQDN validation from TLS handshake to prepare for access via Tor.
- support for fully stopping agent and for termporary suspending agent operations.
- improve management of duplicate message delivery.
SMP notifications server v1.0:
- SMP notifications protocol with version negotiation during handshake.
- device token registration and verification (via background notification).
- SMP notification subscriptions and push notifications via APNS.
- restoring notification subscriptions when the server is restarted.
# 2.3.0
SMP server:
- Save and restore undelivered messages, to avoid losing them. To save messages the server has to be stopped with SIGINT signal, if it is stopped with SIGTERM undelivered messages would not be saved.
# 2.2.0
SMP server:
- Fix sockets/threads/memory leak
SMP agent:
- Support stopping and resuming agent with `disconnectAgentClient` / `resumeAgentClient`
# 2.1.1
SMP server:
- gracefully close sockets on client disconnection
- CLI warning when deleting server configuration
# 2.1.0
SMP server:
- configuration to expire inactive clients in ini file, increased TTL and check interval for client expiration
# 2.0.0
Push notifications server (beta):
- supports APNS
- manage device tokens verification via notification delivery
- sending periodic background notification to check messages (not more frequent than every 20 min)
SMP server:
- disconnect inactive clients after some period
- remove undelivered messages after 30 days
- log aggregate usage daily stats: only the number of queues created/secured/deleted/used and messages sent/delivered is logged, as one line per day, so we can plan server capacity and diagnose any problems.
SMP agent:
- manage device tokens and notification server connection
- DOWN/UP events to the agent user about server disconnections/reconnections are now sent once per server
# 1.1.0
SMP server:
- message TTL and periodic deletion of old messages
- configuration to prevent creation of the new queues
SMP agent:
- asynchronous connection handshake
- configurable SMP servers at run-time
- use TCP keep-alive for connection stability
- improve stability of connection subscriptions
- auto-vacuum DB to remove deleted records
# 1.0.3
SMP server:
- Reduce server message queue quota to 128 messages.
SMP agent:
- Add "yes to migrations" option.
- Make new SMP client attempt to reconnect on network error.
- Reduce connection handshake expiration to 2 days.
JSON encoding of types used in simplex-chat, some other minor adjustments.
# 1.0.2
General:
- Enable TLS 1.3 parameters for TLS handshake (server and client).
- Switch from hs-tls fork to original repo now that it supports getFinished and getPeerFinished APIs for both TLS 1.2 and TLS 1.3.
SMP server:
- Perform TLS handshake in a separate thread per-connection.
SMP agent:
- Cease attempts to send HELLO after one week timeout.
- Coalesce requests to connect to SMP servers, to have 1 connection per server.
# 1.0.1
SMP server:
- Explicitly set line buffering in stdout/stderr to log each line when output is redirected to files.
# 1.0.0
Security and privacy improvements:
- Faster and more secure 2-layer E2E encryption with additional encryption layer between servers and recipients:
- application messages in each duplex connection (managed by SMP agents - see [overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md)) are encrypted using [double-ratchet algorithm](https://www.signal.org/docs/specifications/doubleratchet/), providing forward secrecy and break-in recovery. This layer uses two Curve448 keys per client for [X3DH key agreement](https://www.signal.org/docs/specifications/x3dh/), SHA512 based HKDFs and AES-GCM AEAD encryption.
- SMP client messages are additionally E2E encrypted in each SMP queue to avoid cipher-text correlation of messages sent via multiple redundant queues (that will be supported soon). This and the next layer use [NaCl crypto_box algorithm](https://nacl.cr.yp.to/index.html) with XSalsa20Poly1305 cipher and Curve25519 keys for DH key agreement.
- 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.
+40 -110
View File
@@ -3,181 +3,111 @@
[![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).
📢 **v0.5.1 brings a hotfix to the server's subscription management logic, to apply it log in to your server via SSH and run the following command. If you have store log enabled for your server, information about already established queues will be preserved.** If you're doing a custom installation instead of Linode or DigitalOcean you may have to change the path for binary download.
**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.
```sh
systemctl stop smp-server
curl -L -o /opt/simplex/bin/smp-server https://github.com/simplex-chat/simplexmq/releases/download/v0.5.1/smp-server-ubuntu-20_04-x86-64
systemctl start smp-server
```
## Message broker for unidirectional (simplex) queues
SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
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.
SimpleXMQ is implemented in Haskell - it benefits from robust software transactional memory (STM) and concurrency primitives that Haskell provides.
## SimpleXMQ roadmap
- 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 queue redundancy and rotation in SMP agent duplex 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)).
- Streams - high performance message queues. See [Streams RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-02-28-streams.md) for details.
## Components
### SMP server
[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies. 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.
To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
To enable the queue logging, uncomment `enable: on` option in `smp-server.ini` configuration file that is created the first time the server is started.
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.
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>`.
To enable store log, initialize server using `smp-server -l` command, or modify `smp-server.ini` created during initialization (uncomment `enable: on` option in the store log section). Use `smp-server --help` for other usage tips.
Starting from version 2.3.0, when store log is enabled, the server would also enable saving undelivered messages on exit and restoring them on start. This can be disabled via a separate setting `restore_messages` in `smp-server.ini` file. Saving messages would only work if the server is stopped with SIGINT signal (keyboard interrupt), if it is stopped with SIGTERM signal the messages would not be saved.
> **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
#### 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 server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
### SMP client library
[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
- execute commands with a functional API.
- receive messages and other notifications via STM queue.
- automatically send keep-alive commands.
### SMP agent
[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
## Using SMP server and SMP agent
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:
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 servers:
`smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im`
`smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im`
`smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im`
`smp2.simplex.im#z5W2QLQ1Br3Yd6CoWg7bIq1bHdwK7Y8bEiEXBs/WfAg=` (London, UK)
`smp3.simplex.im#nxc7HnrnM8dOKgkMp008ub/9o9LXJlxlMrMpR+mfMQw=` (Fremont, CA)
It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
## Deploy SMP server on Linux
You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
- 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.
- Optionally, `smp-server` can be setup for having an onion address in `tor` network. See: [`scripts/tor`](./scripts/tor/). In this case, the server address can have both public and onion hostname pointing to the same server, to allow two people connect when only one of them is using Tor. The server address would be: `smp://<fingerprint>@<public_hostname>,<onion_hostname>`
See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
<img alt="Docker" src="./img/docker.svg" align="right" width="200">
## Deploy SMP server with Docker
SMP server could also be deployed using `Docker`.
See: [`scripts/docker`](./scripts/docker/)
[<img alt="Linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
[<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
## Deploy SMP server on Linode
\* You can use free credit Linode offers when [creating a new account](https://www.linode.com/) to deploy an SMP server.
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.
Deployment on Linode is performed via StackScripts, which serve as recipes for Linode instances, also called Linodes. To deploy SMP server on Linode:
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:
- Create a Linode account or login with an already existing one.
- Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode".
- You can optionally configure the following parameters:
- SMP Server store log flag for queue persistence on server restart, recommended.
- [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
- read/write for "linodes"
- read/write for "domains"
- Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
- 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/) .
- [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.
- 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 `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>`.
- 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.
Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
## Deploy SMP server on DigitalOcean
> 🚧 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:
You can deploy SMP server using [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 (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.
- 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.
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](./design/server.svg)
![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
## SMP agent design
![SMP agent design](./design/agent2.svg)
![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
## License
[AGPL v3](./LICENSE)
[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
-88
View File
@@ -1,88 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Logger.Simple
import Data.Functor (($>))
import Data.Ini (lookupValue)
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 v1.2.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\
\enable: "
<> (if enableStoreLog then "on" else "off")
<> "\n\
\log_stats: off\n\n\
\[TRANSPORT]\n\
\port: "
<> defaultServerPort
<> "\n\
\websockets: off\n",
mkServerConfig = \storeLogFile transports ini ->
let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
logStats = settingIsOn "STORE_LOG" "log_stats"
in NtfServerConfig
{ transports,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 16,
subQSize = 64,
pushQSize = 128,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
inactiveClientExpiration = Nothing,
storeLogFile,
resubscribeDelay = 50000, -- 50ms
caCertificateFile = caCrtFile,
privateKeyFile = serverKeyFile,
certificateFile = serverCrtFile,
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log"
}
}
+4 -14
View File
@@ -1,5 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
@@ -7,21 +6,12 @@ module Main where
import Control.Logger.Simple
import qualified Data.List.NonEmpty as L
import Simplex.Messaging.Agent (runSMPAgent)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Server (runSMPAgent)
import Simplex.Messaging.Client (defaultNetworkConfig)
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport (TCP, Transport (..))
cfg :: AgentConfig
cfg = defaultAgentConfig
servers :: InitialAgentServers
servers =
InitialAgentServers
{ smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
ntf = [],
netCfg = defaultNetworkConfig
}
cfg = defaultAgentConfig {smpServers = L.fromList ["localhost:5223#bU0K+bRg24xWW//lS0umO1Zdw/SXqpJNtm1/RrPLViE="]}
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -30,4 +20,4 @@ main :: IO ()
main = do
putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
setLogLevel LogInfo -- LogError
withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
withGlobalLogging logCfg $ runSMPAgent (transport @TCP) cfg
+262 -94
View File
@@ -1,109 +1,277 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Control.Logger.Simple
import Data.Functor (($>))
import Data.Ini (lookupValue)
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 Simplex.Messaging.Server (runSMPServer)
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, supportedSMPServerVRange)
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 System.FilePath (combine)
import System.IO (IOMode (..), hFlush, stdout)
import Text.Read (readEither)
cfgPath :: FilePath
cfgPath = "/etc/opt/simplex"
defaultServerPort :: ServiceName
defaultServerPort = "5223"
logPath :: FilePath
logPath = "/var/opt/simplex"
defaultBlockSize :: Int
defaultBlockSize = 4096
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
serverConfig :: ServerConfig
serverConfig =
ServerConfig
{ tbqSize = 16,
serverTbqSize = 128,
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"
main :: IO ()
main = do
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
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"
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") <> "\n")
<> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
\# they are preserved in the .bak file until the next restart.\n"
<> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n")
<> ("log_stats: off\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 ->
let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
logStats = settingIsOn "STORE_LOG" "log_stats"
in 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 =
settingIsOn "INACTIVE_CLIENTS" "disconnect"
$> ExpirationConfig
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
},
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
smpServerVRange = supportedSMPServerVRange
}
}
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"
)
-17
View File
@@ -1,17 +0,0 @@
packages: .
-- packages: . ../direct-sqlcipher ../sqlcipher-simple
source-repository-package
type: git
location: https://github.com/simplex-chat/aeson.git
tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
source-repository-package
type: git
location: https://github.com/simplex-chat/direct-sqlcipher.git
tag: 34309410eb2069b029b8fc1872deb1e0db123294
source-repository-package
type: git
location: https://github.com/simplex-chat/sqlcipher-simple.git
tag: 5e154a2aeccc33ead6c243ec07195ab673137221
-1
View File
File diff suppressed because one or more lines are too long

Before

Width:  |  Height:  |  Size: 8.1 KiB

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

Before

Width:  |  Height:  |  Size: 3.1 KiB

After

Width:  |  Height:  |  Size: 3.1 KiB

+117
View File
@@ -0,0 +1,117 @@
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, -- TODO add defauls here and below in the new schema
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;
+9
View File
@@ -0,0 +1,9 @@
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;
+3
View File
@@ -0,0 +1,3 @@
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'';
+11
View File
@@ -0,0 +1,11 @@
ALTER TABLE connections ADD conn_mode TEXT NOT NULL DEFAULT 'INV';
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;
+9
View File
@@ -0,0 +1,9 @@
# 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`).
+18 -46
View File
@@ -1,7 +1,7 @@
name: simplexmq
version: 3.3.0
name: simplexmq-v0
version: 0.5.3
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,73 +15,50 @@ homepage: https://github.com/simplex-chat/simplexmq#readme
license: AGPL-3
author: simplex.chat
maintainer: chat@simplex.chat
copyright: 2020-2022 simplex.chat
copyright: 2020 simplex.chat
category: Chat, Network, Web, System, Cryptography
extra-source-files:
- README.md
- CHANGELOG.md
- migrations/*.*
dependencies:
- aeson == 2.0.*
- ansi-terminal >= 0.10 && < 0.12
- asn1-encoding == 0.9.*
- asn1-types == 0.3.*
- async == 2.2.*
- attoparsec == 0.14.*
- base >= 4.14 && < 5
- attoparsec == 0.13.*
- base >= 4.7 && < 5
- base64-bytestring >= 1.0 && < 1.3
- bytestring == 0.10.*
- case-insensitive == 1.2.*
- composition == 1.0.*
- constraints >= 0.12 && < 0.14
- containers == 0.6.*
- cryptonite >= 0.27 && < 0.30
- cryptostore == 0.2.*
- data-default == 0.7.*
- direct-sqlcipher == 2.3.*
- direct-sqlite == 2.3.*
- directory == 1.3.*
- file-embed >= 0.0.14.0 && <= 0.0.15.0
- 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.2.7 && < 3.2
- network-transport == 0.5.4
- optparse-applicative >= 0.15 && < 0.17
- network == 3.1.*
- network-transport == 0.5.*
- QuickCheck == 2.14.*
- process == 1.6.*
- random >= 1.1 && < 1.3
- simple-logger == 0.1.*
- socks == 0.6.*
- sqlcipher-simple == 0.4.*
- sqlite-simple == 0.4.*
- stm == 2.5.*
- template-haskell == 2.16.*
- text == 1.2.*
- time == 1.9.*
- time-compat == 1.9.*
- time-manager == 0.0.*
- tls >= 1.6.0 && < 1.7
- 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
@@ -91,15 +68,10 @@ executables:
source-dirs: apps/smp-server
main: Main.hs
dependencies:
- simplexmq
ghc-options:
- -threaded
ntf-server:
source-dirs: apps/ntf-server
main: Main.hs
dependencies:
- simplexmq
- cryptostore == 0.2.*
- ini == 0.4.*
- optparse-applicative >= 0.15 && < 0.17
- simplexmq-v0
ghc-options:
- -threaded
@@ -107,7 +79,7 @@ executables:
source-dirs: apps/smp-agent
main: Main.hs
dependencies:
- simplexmq
- simplexmq-v0
ghc-options:
- -threaded
@@ -116,7 +88,7 @@ tests:
source-dirs: tests
main: Test.hs
dependencies:
- simplexmq
- simplexmq-v0
- hspec == 2.7.*
- hspec-core == 2.7.*
- HUnit == 1.6.*
+37 -13
View File
@@ -123,7 +123,7 @@ Each SMP message client body, once decrypted, contains 3 parts (one of them may
- to send and to acknowledge user messages (`clientMsg`, `acknowledgeMsg`)
- 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.
- `msgPadding` - an optional message padding to make all SMP messages have constant size, to prevent servers from observing the actual message size.
### Messages between SMP agents
@@ -131,34 +131,56 @@ Message syntax below uses [ABNF][3] with [case-sensitive strings extension][4].
```abnf
decryptedSmpMessageBody = agentMsgHeader CRLF agentMessage CRLF msgPadding
agentMsgHeader = agentMsgId SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent
agentMsgHeader = agentMsgId SP agentTimestamp 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 /
clientMsg / invitationMsg /
clientMsg / invitationMsg/ acknowledgeMsg /
newQueueMessage / deleteQueueMsg
msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size)
helloMsg = %s"H"
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
replyQueueMsg = %s"R" connectionRequest ; `connectionRequest` is defined below
replyQueueMsg = %s"REPLY" SP connectionRequest ; `connectionRequest` is defined below
; this message can only be sent by the second connection party
clientMsg = %s"M" clientMsgBody
clientMsg = %s"MSG" SP size CRLF clientMsgBody CRLF ; CRLF is in addition to CRLF in decryptedSmpMessageBody
size = 1*DIGIT
clientMsgBody = *OCTET
; TODO remove and move to "public" header
invitationMsg = %s"INV" SP connReqInvitation SP connInfo
; `connReqInvitation` and `connInfo` are defined below
newQueueMsg = %s"N" queueURI
acknowledgeMsg = %s"ACK" SP agentMsgId SP msgHash SP ackStatus
; NOT SUPPORTED in the current implementation
msgHash = encoded
; base64 encoded hash of the received message
ackStatus = %s"OK" / ackError
ackError = %s"ERR" SP ackErrorType
ackErrorType = ackUnknownMsg / ackProhibitedMsg / ackSyntaxErr
ackUnknownMsg = %s"UNKNOWN"
ackProhibitedMsg = %s"PROHIBITED" ; unexpected message e.g. "HELLO" or "REPLY"
ackSyntaxErr = %s"SYNTAX" SP syntaxErrCode
syntaxErrCode = 1*DIGIT ; TODO
newQueueMsg = %s"NEW" SP queueURI
; this message can be sent by any party to add SMP queue to the connection.
; NOT SUPPORTED in the current implementation
deleteQueueMsg = %s"D" queueURI
deleteQueueMsg = %s"DEL" SP 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
@@ -192,7 +214,7 @@ This message is sent to add an additional SMP queue to the connection. Unlike RE
#### 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.
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 only queue in the connection to which the agent could send the messages, it MAY also delete the reply queue(s) in the connection.
## SMP agent commands
@@ -203,11 +225,13 @@ 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 [connId] CRLF agentCommand
agentTransmission = [corrId] CRLF [cAlias] CRLF agentCommand
corrId = 1*(%x21-7F) ; any characters other than control/whitespace
connId = encoded
cAlias = cId / cName
cId = encoded
cName = 1*(ALPHA / DIGIT / "_" / "-")
agentCommand = (userCmd / agentMsg) CRLF
userCmd = newCmd / joinCmd / letCmd / acceptCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd
@@ -280,7 +304,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 ; sending agent message ID
senderMeta = %s"S=" agentMsgId "," agentTimestamp ; sending agent message metadata
brokerMsgId = encoded
brokerTimestamp = <date-time>
msgIntegrity = ok / msgIntegrityError
@@ -1,71 +0,0 @@
sequenceDiagram
participant A as Alice
participant AA as Alice's<br>agent
participant AS as Alice's<br>server
participant BS as Bob's<br>server
participant BA as Bob's<br>agent
participant B as Bob
note over AA, BA: status (receive/send): NONE/NONE
note over A, AA: 1. request connection<br>from agent
A ->> AA: NEW: create<br>duplex connection
note over AA, AS: 2. create Alice's SMP queue
AA ->> AS: NEW: create SMP queue
AS ->> AA: IDS: SMP queue IDs
note over AA: status: NEW/NONE
AA ->> A: INV: invitation<br>to connect
note over A, B: 3. out-of-band invitation
A ->> B: OOB: invitation to connect
note over BA, B: 4. accept connection
B ->> BA: JOIN:<br>via invitation info
note over BA: status: NONE/NEW
note over BA, BS: 5. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/NEW
note over BA, AA: 6. establish Alice's SMP queue
BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
note over BA: status: NEW/CONFIRMED
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE
AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
note over AA: status: SECURED/CONFIRMED
BS ->> BA: MSG: Alice's info and<br>sender's server key
note over BA: status: CONFIRMED/CONFIRMED
BA ->> B: INFO: Alice's info
BA ->> BS: ACK: confirm message
BA ->> BS: KEY: secure queue
note over BA: status: SECURED/CONFIRMED
BA ->> AS: SEND: HELLO: only needs to be sent once in v2
note over BA: status: SECURED/ACTIVE
note over BA, B: 7a. notify Bob<br>about connection success
BA ->> B: CON: connected
AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
note over AA: status: SECURED/ACTIVE
AA ->> AS: ACK: confirm message
note over A, AA: 7a. notify Alice<br>about connection success
AA ->> A: CON: connected
AA ->> BS: SEND: HELLO: only needs to be sent once in v2
note over AA: status: ACTIVE/ACTIVE
BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
note over BA: status: ACTIVE/ACTIVE
BA ->> BS: ACK: confirm message
@@ -33,8 +33,8 @@ sequenceDiagram
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
AA ->> A: REQ: connection request ID<br>and Bob's info
A ->> AA: ACPT: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE
@@ -1,30 +0,0 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant A as agent
participant P as push server
participant APN as APN
note over M, APN: get device token
M ->> APN: registerForRemoteNotifications()
APN ->> M: device token
note over M, P: register device token with push server
M ->> C: /_ntf register <token>
C ->> A: registerNtfToken(<token>)
A ->> P: TNEW
P ->> A: ID (tokenId)
A ->> C: registered
C ->> M: registered
note over M, APN: verify device token
P ->> APN: E2E encrypted code<br>in background<br>notification
APN ->> M: deliver background notification with e2ee verification token
M ->> C: /_ntf verify <e2ee code>
C ->> A: verifyNtfToken(<e2ee code>)
A ->> P: TVFY code
P ->> A: OK / ERR
A ->> C: verified
C ->> M: verified
note over M, APN: now token ID can be used
@@ -1,40 +0,0 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant A as agent
participant S as SMP server
participant N as NTF server
participant APN as APN
note over M, APN: register subscription
alt register existing
M -->> A: on /_ntf register, for subscribed queues
else create new connection
A -->> S: NEW / JOIN
note over A, S: ...<br>Connection handshake<br>...
S -->> A: CON
end
A ->> S: NKEY nKey
S ->> A: NID nId
A ->> N: SNEW tknId dhKey (smpServer, nId, nKey)
N ->> A: ID subId dhKey
N ->> S: NSUB nId
S ->> N: OK [/ NMSG]
note over M, APN: notify about message
S ->> N: NMSG
N ->> APN: APNSMutableContent<br>ntfQueue, nonce
APN ->> M: UNMutableNotificationContent
note over M, S: ...<br>Client awaken, message is received<br>...
S ->> M: message
note over M: mutate notification
note over M, APN: change APN token
APN ->> M: new device token
M -->> C: /_ntf_sub update tkn
C -->> A: updateNtfToken()
A -->> N: TUPD tknId newDeviceToken
note over M, N: ...<br>Verify token<br>...
-313
View File
@@ -1,313 +0,0 @@
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 users 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 wont match (and potentially wont be able to decrypt them in case they dont 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 users 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 users 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.
+259
View File
@@ -0,0 +1,259 @@
# SimpleX: messaging and application network
## Table of contents
- [SimpleX objectives](#simplex-objectives)
- [SimpleX network](#simplex-network)
- [Threat model](#threat-model)
## 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 identify and to some extent compensate for the presence of the active attacker who may modify, delete or add messages.
- Privacy: network server operators should have no ability to read or modify messages without detection, and it should be impossible or hard to infer the contacts the users communicate with. Non-malicious network operators should retain no record of participants communications.
- 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 should be delivered without alteration, in the same order, and any unauthorized message change should be detected by the recipient.
- 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 privacy, in particular meta-data privacy (who talks to whom and when), and security, in particular security against active attacks, than the alternative instant messaging solutions.
3. Balance user experience with privacy requirements, prioritizing experience of mobile device users.
## SimpleX network
### Overview
SimpleX network provides asynchronous messaging infrastructure that aims to deliver on the above objectives and to avoid the disadvantages of the alternative solutions.
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.
- 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 (requiring a separate type of server to host them, which is out of scope of this document).
- servers do not store any user information (no user profiles, contacts or messages, once they are delivered), and can use in-memory persistence only.
- users can change server provider(s) without losing their communication contacts, simply by changing the configuration on which servers the new queues are created.
SimpleX network has design similar to P2P networks, but unlike most P2P networks it consists of clients and servers, without dependency on any centralized component. Servers provide anonymous unidirectional message queues in order to:
- continuously accept messages for the recipients, even when they are offline.
- provide recipient anonymity, as the messaging queues do not identify the users, and different addresses of the same queue are used for senders and recipients to provide additional protection against server traffic correlation, in case transport connections are compromised.
Coincidentally, SimpleX network reminds [Pond messenger](https://github.com/agl/pond) design, the main differences are:
- Clients can receive messages via multiple servers (in Pond users use one home server and it serves as a user permanent address),
- Clients do not need to poll servers to receive messages, the messages from subscribed queues are delivered via an open transport connection as they are received by the servers, resulting in low latency of message delivery.
### SimpleX servers
Clients communicate with servers (but not with other clients) using SimpleX Messaging Protocol (SMP) running over some transport protocol that provides server authentication, confidentiality with forward secrecy, integrity and transport channel binding (to prevent SMP commands replay).
Users can use multiple servers. They choose the servers they use to receive the messages through, and they communicate with the servers chosen by the recipients to send messages.
It is assumed that users have some degree of trust to the servers, for one of the following reasons:
- They deploy and control the servers themselves from the available open-source code. The advantage of self-deployed servers is that users have full control of server information and activity, but the downside is that it is easier to correlate incoming and outgoing messages by observing server traffic, assuming small number of messages sent via user-hosted servers and irregular communication time. It can be mitigated by:
- sending noise traffic.
- future protocol versions can add configurable per queue message delivery delays (compromising on one of the design objectives of low latency).
- using SMP servers via an onion routing or mix network.
- They use servers from the trusted commercial providers. The more clients the provider has, the less meta-data about the communication times is leaked to the network observers, and even if transport confidentiality is compromised it is not possible to correlate sent and received traffic without compromising the server, because the clients use different queue IDs to send and receive messages, and the message delivered to the recipient is additionally encrypted by the server.
- To some extent, users trust their contacts and the servers they chose that the users send messages to. The client applications could further improve user trust to the servers chosen by their contacts by supporting either the list of servers that are “allowed to send to” or “prohibited to send to” (e.g., known trusted or compromised servers, certain IP ranges, server geographical locations etc.).
If users use the free servers deployed by the volunteers, there is a risk that the server code can maliciously record all queues and messages (even though encrypted) sent via the same transport connection and to gain a partial knowledge of the users communications graph and other meta-data. User clients can mitigate it by using some overlay network that protects the privacy of TCP connections, e.g., Tor, and by sending noise traffic between the end users.
The servers authorize users to access (send/receive/etc.) their message queues via a digital signature of transmissions using a unique key pair different for each queue sender and recipient, so no information that is required for the server to authorize users allows to aggregate user communications across multiple queues.
### Transport
SimpleX network does not rely on transport or overlay network for server or client authentication. SMP protocol itself must provide integrity, forward secure confidentiality of communicating parties and mutual authentication even if transport protocol (but not the server) is compromised by the active attacker.
To protect against MITM attack on the transport, the clients should verify server self-signed certificate during TLS handshake by validating its pre-shared hash of the certificate in the server address (either as part of client configuration or passed in SMP connection request).
Clients use TLS1.3 protocol to connect to the server, restricting supported cryptographic protocols as defined in SimpleX Messaging Protocol.
After TCP transport connection is established, and the server is authenticated, the client sends blocks of a fixed size 16Kb, and the server replies with the blocks of the same size. When the actual message is smaller, it should be padded before encryption, and if it is larger, it can be split to chunks by the client application. The first blocks from the client and the server should include protocol version so that the party with the higher version can confirm compatibility and the transport channel identifier as described in SMP protocol.
Client can terminate the server transport connection without losing any messages removal of the message from the server and the delivery of the next message happens when the client acknowledges the message reception (normally, after it is persisted in the clients database).
Depending on the privacy requirements of the clients, the client can use a separate transport connection per queue, or receive messages from multiple queues via a single transport connection, for efficiency. In our implementations this configuration will be available to the end users.
### Server implementation
- does not store user access logs.
- does not store messages after the client has received them.
- permanently removes queues after they are deleted by the users
- only stores messages in transit in server operating memory; as clients are expected to use multiple servers to deliver each message, the message loss in one of the servers is acceptable.
### SimpleX clients and agents
Clients are assumed to be running on the trusted devices and can use the locally encrypted storage for messages, contacts, groups and other resources.
SimpleX clients implementing application-level protocols communicate with SimpleX servers via agents. SimpleX agents can be accessed in one of the following ways:
- via TCP network using trusted network connection or an overlay transport network.
- 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.
The last option is the most secure, as it reduces the number of attack vectors in comparison with other options. The current implementation of SimpleX Chat uses this approach.
SimpleX agents provide the following operations:
- Creating and managing bi-directional (duplex) client connections and delivering messages via redundant groups of SimpleX queues.
- Exchanging keys and providing end-to-end encryption. The current prototype uses RSA cryptography with ad-hoc hybrid encryption scheme, we are currently switching it to X3DH for key exchange and double ratchet protocol for E2E encryption.
Communication between the client and the agent and the communication between the agents (via end-to-end encrypted messages delivered via SMP protocol) is described by SimpleX Agent Protocol.
Bi-directional client connections consist of multiple “send” and multiple “receive” queues (for redundancy) that agents use to send and receive messages; each queue should be used for limited amount of time, the rotation of queues is negotiated using SimpleX Agent Protocol.
There are two ways that SimpleX network users can establish the connection:
- Users communicate the initial connection invitation out-of-band, via link or via QR code. This out-of-band communication is assumed secure against active attacks and insecure against passive attacks. Once the connection is established that users are assumed to have confirmed out-of-band, the connection can no longer be compromised even if out-of-band invitation was obtained by the attacker. This out-of-band invitation does not contain any personal information, only the address of the queue and public key for the key exchange for end-to-end encryption.
- Users can create a “contact queue(s)” on SMP servers that would be used to receive connection requests. The important distinction with commonly used addressing systems is that this queue is only used to pass the connection request and not for subsequent messages. So, while it is possible to spam users who created such contact queues with connection requests, they can be removed without disrupting the communication with the existing contacts.
The reply queue addresses and the key exchange for the reply queues is negotiated via the direct queue.
### Message encryption
Messages are encrypted end-to-end using double ratchet protocol. Once the sending client deletes messages it wont be able to decrypt them again. While messages are numbered within the queue, this only reveals to the servers how messages have been exchanged in a given queue that has a limited lifetime, so the total number of messages exchanged between contacts is not revealed.
The next queue to use is negotiated between agents in encrypted messages, and in most cases, it will be on another server (unless the client is configured to use one server, which is not recommended).
### Client storage
It is assumed that the client device and the storage is trusted, but clients can implement storage encryption using a user-provided passphrase.
## Threat model
### Assumptions
User protects their information and keys.
SimpleX Chat software is authentic.
User device is not compromised, excluding the scenarios below where it is explicitly stated it is compromised.
Used cryptographic primitives are not compromised.
### SimpleX Messaging Protocol server
**can:**
- learn when a queue recipient or sender is online via transmission times.
- correlate multiple queues to a single user in case they are accessed via the same transport connection or from the same IP address.
- correlate multiple queues to a single user based on the time they are accessed. Clients that use message notification servers can mitigate it by only subscribing to the queues after they receive the notifications and disconnecting after some time of inactivity.
- know how many messages is sent via the queue, clients can mitigate it with noise traffic.
- add, drop, duplicate or corrupt messages, but it will be detected by the client on SimpleX Agent Protocol level. Using multiple servers to deliver each message mitigates the loss of messages.
**cannot:**
- decrypt messages
- compromise e2e encryption with MITM attack (as server is only used to pass one of two keys in DH exchange, the first key is passed out-of-band)
### A global passive adversary monitoring all Internet traffic
**can:**
- learn who is using SimpleX Chat.
- learn when messages are sent and received.
- learn which SimpleX Messaging Protocol servers are used.
- in case of low traffic on the servers, correlate senders and recipients by the time messages sent and received.
- observe the approximate size of the files transmitted to O(log log M) of file size precision.
**cannot, even in case of compromised transport protocol:**
- correlate senders and recipients by the content of messages (as different queue IDs are used for senders and recipients, with additional encryption layer in the delivered messages).
### A local network attacker
**can:**
- observe when a user is using SimpleX Chat.
- block SimpleX Chat traffic.
- determine which servers the user communicates with.
- observe the approximate size of files transmissions and receptions.
**cannot:**
- see who sends messages to the user and who the user sends the messages to
### An attacker who obtained users decrypted chat database
**can:**
- see the history of all messages
- see shared profiles of contacts and groups
- receive new user messages, but the user will detect it as the number and the hash of the previous message wont match. Also, they will be instantly alerted that an unknown device is connected to their message queues, as long as they are online at the same time, as message queues only allow one active subscription.
- delete users message queues, so the contacts wont be able to send messages.
- send messages from the user to their contacts, but the recipients will detect it as soon as the user sends the next message, because the previous message hash wont match (and potentially wont be able to decrypt them in case they dont keep the previous ratchet keys).
**cannot:**
- impersonate a sender and send messages to the user whose database was stolen without also compromising the server (to place the message in the queue) or the user's device at a subsequent time (to place the message in the database).
### A users contact
**can:**
- spam the user with messages.
- forever retain messages from the user.
**cannot:**
- prove to a third-party that a message came from a user (assuming a users device is not seized)
- prove that two contacts they have is the same user.
- two contacts cannot confirm if they are communicating with the same user.
### An attacker with Internet access
**can:**
- DoS SimpleX messaging servers.
- spam the user who created a “contact queue” (queue for accepting connection requests) by sending multiple connection requests.
**cannot:**
- send messages to the user who they are not connected with.
+114 -286
View File
@@ -14,7 +14,6 @@
- [Simplex queue IDs](#simplex-queue-ids)
- [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)
@@ -24,7 +23,6 @@
- [Subscribe to queue](#subscribe-to-queue)
- [Secure queue command](#secure-queue-command)
- [Enable notifications command](#enable-notifications-command)
- [Disable notifications command](#disable-notifications-command)
- [Acknowledge message delivery](#acknowledge-message-delivery)
- [Suspend queue](#suspend-queue)
- [Delete queue](#delete-queue)
@@ -51,8 +49,6 @@ It's designed with the focus on communication security and integrity, under the
It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
## Introduction
The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
@@ -93,7 +89,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 decrypts the messages with the key negotiated during the creation of the queue.
- 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.
- Participant identities are not shared with the server - new unique keys and queue IDs are used for each queue.
@@ -103,7 +99,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 end-to-end encrypted using the DH secret agreed via out-of-band message and SMP confirmation.
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.
**Simplex queue diagram:**
@@ -120,19 +116,14 @@ The SMP queue URIs MUST include server identity, queue hostname, an optional por
The [ABNF][8] syntax of the queue URI is:
```abnf
queueURI = %s"smp://" smpServer "/" queueId "#" recipientDhPublicKey
smpServer = serverIdentity "@" srvHost [":" port]
queueURI = %s"smp://" smpServer "/" queueId "#" serverSignaturePublicKey
; serverSignaturePublicKey syntax is defined below
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.
@@ -149,61 +140,55 @@ To create and start using a simplex queue Alice and Bob follow these steps:
1. Alice creates a simplex queue on the server:
1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
4. 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).
5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
5. The server sends `"IDS"` response with queue IDs (`queueIds`):
6. The server sends `"IDS"` response with queue IDs (`queueIds`):
- Recipient ID `RID` for Alice to manage the queue and to receive the messages.
- Recipient ID `RID` for Alice to manage the queue and to receive the messages.
- Sender ID `SID` for Bob to send messages to the queue.
- 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`.
- Sender ID `SID` for Bob to send messages to the queue.
2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include:
- Unique "public" key (`EK`) that Bob must use for E2E key agreement.
- Unique "public" key (`EK`) that Bob must use to encrypt messages.
- SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
- SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
- Sender queue ID `SID` for Bob to use.
- Sender queue ID `SID` for Bob to use.
3. Bob, having received the out-of-band message from Alice, connects to the queue:
1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
2. Prepares the confirmation message for Alice to secure the queue. This message includes:
2. Prepares the confirmation message for Alice to secure the queue. This message includes:
- Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
- Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
- Optionally, any additional information (application specific, e.g. Bob's profile name and details).
- Optionally, any additional information (application specific, e.g. Bob's profile name and details).
3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)):
1. She decrypts received message body using the secret `SS`.
1. She decrypts received message with "private" key `EK`.
2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
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.
5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
6. The simplex queue `RID` is now ready to be used.
@@ -217,21 +202,21 @@ Bob now can securely send messages to Alice:
1. Bob sends the message:
1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier provided to the server).
2. Alice receives the message(s):
1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
This flow is show on sequence diagram below.
@@ -358,42 +343,26 @@ To protect the privacy of the recipients, there are several commands in SMP prot
The clients can optionally instruct a dedicated push notification server to subscribe to notifications and deliver push notifications to the device, which can then retrieve the messages in the background and send local notifications to the user - this is out of scope of SMP protocol. The commands that SMP protocol provides to allow it:
- `enableNotifications` (`"NKEY"`) with `notifierId` (`"NID"`) response - see [Enable notifications command](#enable-notifications-command).
- `disableNotifications` (`"NDEL"`) - see [Disable notifications command](#disable-notifications-command).
- `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
- `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
## SMP commands
## SMP Transmission andtransport block structure
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
Each transmission between the client and the server must have this format/syntax (after the decryption):
```abnf
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/block for SMP v3 between the client and the server must have this format/syntax:
```abnf
paddedTransmission = <padded(transmission), 16384>
transmission = [signature] SP signed
signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
; 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
transmission = [signature] SP signed SP pad ; pad to the fixed block size
signed = sessionIdentifier SP [corrId] SP [queueId] SP cmd ; corrId is required in client commands and server responses,
; corrId is empty in server notifications.
cmd = ping / recipientCmd / send / subscribeNotifications / serverMsg
recipientCmd = create / subscribe / secure / enableNotifications /
acknowledge / suspend / delete
serverMsg = queueIds / message / notifierId / messageNotification /
unsubscribed / ok / error
corrId = 1*(%x21-7F) ; any characters other than control/whitespace
queueId = encoded ; empty queue ID is used with "create" command
signature = encoded
; empty signature can be used with "send" before the queue is secured with secure command
; signature is always empty with "ping" and "serverMsg"
@@ -402,28 +371,6 @@ encoded = <base64 encoded binary>
`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
Transport block for SMP v4 has this syntax:
```abnf
paddedTransportBlock = <padded(transportBlock), 16384>
transportBlock = transmissionCount transmissions
transmissionCount = 1*1 OCTET ; equal or greater than 1
transmissions = transmissionLength transmission [transmissions]
transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
```
## SMP commands
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
```abnf
smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg
recipientCmd = create / subscribe / secure / enableNotifications / disableNotifications /
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
@@ -455,36 +402,45 @@ 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 " recipientSignaturePublicKey recipientDhPublicKey
recipientSignaturePublicKey = length x509encoded
; the recipient's Ed25519 or Ed448 public key to verify commands for this queue
create = %s"NEW" SP recipientSignaturePublicKey SP recipientDhPublicKey
recipientSignaturePublicKey = signaturePublicKey
; the recipient's public key to verify commands for this queue
recipientDhPublicKey = length x509encoded
; the recipient's Curve25519 key for DH exchange to derive the secret
signaturePublicKey = signatureScheme ":" x509encoded
signatureScheme = %s"rsa" | %s"ed25519" | %s"ed448"
; "rsa" means deprecated RSA-PSS signature scheme,
; it must not be used for the new queues.
recipientDhPublicKey = dhPublicKey
dhPublicKey = encryptionScheme ":" x509encoded
; the recipient's 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>
encryptionScheme = %s"x25519" | %s"x448"
; TODO change to define the encryption scheme, e.g. "crypto_box"
length = 1*1 OCTET
x509encoded = <base64 X509 key encoding>
```
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 " recipientId senderId srvDhPublicKey
serverDhPublicKey = length x509encoded
; the server's Curve25519 key for DH exchange to derive the secret
queueIds = %s"IDS" SP recipientId SP senderId
SP serverSignaturePublicKey SP serverDhPublicKey
serverSignaturePublicKey = signatureKey
; the server's public key to verify responses and messages for this queue
serverDhPublicKey = dhPublicKey
; the server's 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
recipientId = encoded
senderId = encoded
```
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 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).
`IDS` response transmission MUST be sent signed with `serverSignaturePublicKey` this verifies that the server has the private key that will be used to sign subsequent responses and messages for this queue. This response should be sent with empty queue ID (the third part of the transmission).
#### Subscribe to queue
@@ -505,9 +461,9 @@ This transmission and its response MUST be signed.
This command is sent by the recipient to the server to add sender's key to the queue:
```abnf
secure = %s"KEY " senderSignaturePublicKey
senderSignaturePublicKey = length x509encoded
; the sender's Ed25519 or Ed448 key to verify SEND commands for this queue
secure = %s"KEY" SP senderSignaturePublicKey
senderSignaturePublicKey = signaturePublicKey
; the sender's 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.
@@ -519,42 +475,21 @@ Once the queue is secured only signed messages can be sent to it.
This command is sent by the recipient to the server to add notifier's key to the queue, to allow push notifications server to receive notifications when the message arrives, via a separate queue ID, without receiving message content.
```abnf
enableNotifications = %s"NKEY " notifierKey recipientNotificationDhPublicKey
notifierKey = length x509encoded
; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue
recipientNotificationDhPublicKey = length x509encoded
; the recipient's Curve25519 key for DH exchange to derive the secret
; that the server will use to encrypt notification metadata (encryptedNMsgMeta in NMSG)
; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
enableNotifications = %s"NKEY" SP notifierKey
notifierKey = signatureScheme ":" x509encoded ; the notifier's 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 srvNotificationDhPublicKey
notifierId = length *OCTET ; 16-24 bytes
srvNotificationDhPublicKey = length x509encoded
; the server's Curve25519 key for DH exchange to derive the secret
; that the server will use to encrypt notification metadata to the recipient (encryptedNMsgMeta in NMSG)
notifierId = %s"NID" SP notifierId
recipientId = encoded
```
This response is sent with the recipient's queue ID (the third part of the transmission).
To receive the message notifications, `subscribeNotifications` command ("NSUB") must be sent signed with the notifier's key.
#### Disable notifications command
This command is sent by the recipient to the server to remove notifier's credentials from the queue:
```abnf
disableNotifications = %s"NDEL"
```
The server must respond `ok` to this command if it was successful.
Once notifier's credentials are removed server will no longer send "NMSG" for this queue to notifier.
#### Acknowledge message delivery
The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted:
@@ -602,19 +537,10 @@ Currently SMP defines only one command that can be used by senders - `send` mess
This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured:
```abnf
send = %s"SEND " msgFlags SP smpEncMessage
msgFlags = notificationFlag reserved
notificationFlag = %s"T" / %s"F"
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
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
```
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.
@@ -632,93 +558,15 @@ 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
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
decryptedBody = [clientHeader] CRLF clientBody CRLF
clientHeader = senderKeyMsg
senderKeyMsg = %s"KEY" SP senderKey
senderKey = signatureScheme ":" x509encoded ; the sender's public key to sign SEND commands for this queue
clientBody = *OCTET
```
`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
@@ -746,20 +594,18 @@ See its syntax in [Create queue command](#create-queue-command)
The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is:
```abnf
message = %s"MSG " msgId encryptedRcvMsgBody
encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 16088
encryptedRcvMsgBody = <encrypt rcvMsgBody> ; server-encrypted meta-data and padded sent msgBody
rcvMsgBody = timestamp msgFlags SP paddedSentMsgBody
msgId = length 24*24OCTET
timestamp = 8*8OCTET
message = %s"MSG" SP encryptedMessage
encryptedMessage = <encrypt sentMessage>
sentMessage = msgId SP timestamp SP size SP msgBody SP
msgId = encoded
timestamp = <date-time defined in RFC3339>
```
`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.
`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).
`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).
`timestamp` - the UTC time when the server received the message from the sender, must be in date-time format defined by [RFC 3339][10]
`paddedSentMsgBody` - see syntax in [Send message](#send-message)
`msgBody` - 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.
@@ -776,19 +622,10 @@ See its syntax in [Enable notifications command](#enable-notifications-command)
The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command ("NSUB") on the currently open transport connection. The syntax for the message notification delivery is:
```abnf
messageNotification = %s"NMSG " nmsgNonce encryptedNMsgMeta
encryptedNMsgMeta = <encrypted message metadata passed in notification>
; metadata E2E encrypted between server and recipient containing server's message ID and timestamp (allows extension),
; to be passed to the recipient by the notifier for them to decrypt
; with key negotiated in NKEY and NID commands using nmsgNonce
nmsgNonce = <nonce used in NaCl crypto_box encryption scheme>
; nonce used by the server for encryption of message metadata, to be passed to the recipient by the notifier
; for them to use in decryption of E2E encrypted metadata
messageNotification = %s"NMSG"
```
Message notification does not contain any message data or non E2E encrypted metadata.
Message notification does not contain any message data or meta-data, it only notifies that the message is available.
#### Subscription END notification
@@ -803,24 +640,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.
- sent message is too large (> 16088) to be delivered (`LARGE_MSG`).
- incorrect message body size (`SIZE`).
- internal server error (`INTERNAL`).
The syntax for error responses:
```abnf
error = %s"ERR " errorType
errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY"
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"
```
Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
@@ -842,7 +679,6 @@ ok = %s"OK"
Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223.
For scenarios when meta-data privacy is critical, it is recommended that clients:
- communicating over Tor network,
- establish a separate connection for each SMP queue,
- send noise traffic (using PING command).
@@ -850,45 +686,38 @@ For scenarios when meta-data privacy is critical, it is recommended that clients
In addition to that, the servers can be deployed as Tor onion services.
The transport protocol should provide the following:
- server authentication (by matching server certificate hash with `serverIdentity`),
- forward secrecy (by encrypting the traffic using ephemeral keys agreed during transport handshake),
- integrity (preventing data modification by the attacker without detection),
- unique channel binding (`sessionIdentifier`) to include in the signed part of SMP transmissions.
By default, the client and server communicate using [TLS 1.3 protocol][13] restricted to:
- TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices),
- TLS_AES_256_GCM_SHA384 cypher suite,
- 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.
- servers must send only one self-signed certificate in the handshake, clients must abort the connection in case more than one certificate is sent.
- server and client TLS configuration should not allow resuming the sessions.
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.
During TLS handshake the client must validate that the hash of the server certificate SPKI block 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.
Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes).
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:
The first block sent by the client should be `clientHello` and the server should respond with `serverHello`:
```abnf
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.
clientHello = SP smpVersion SP reserved pad
serverHello = sessionIdentifier SP smpVersion SP reserved pad
sessionIdentifier = <base64 encoded> ; unique session identifier derived from transport connection handshake
; it should be included in all SMP transmissions sent in this transport connection.
clientHello = smpVersion pad
; chosen SMP protocol version - it must be the maximum supported version
; within the range offered by the server
smpVersion = 2*2OCTET ; Word16 version number
pad = *OCTET
smpVersion = %s"SMP v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ; semver format, the version in this document is v0.5.0
reserved = <reserved for additional information>
pad = 1*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).
For TLS 1.3 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.
The communication party (client or server) that has the lower protocol version should assume that this version will be supported by another party, the party with the higher protocol version should abort the connection in case they cannot support the lower version.
[1]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack
[2]: https://en.wikipedia.org/wiki/End-to-end_encryption
@@ -905,4 +734,3 @@ For TLS transport client should assert that `sessionIdentifier` is equal to `tls
[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
-18
View File
@@ -1,18 +0,0 @@
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
-16
View File
@@ -1,16 +0,0 @@
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
+8 -8
View File
@@ -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_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>`.
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>`.
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_id> STREAM <stream_id> <size>` notification.
4. Receiving client would send `<conn_id> SJOIN <stream_id>` command to the receiving agent.
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.
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_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)
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)
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_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.
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.
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_id> 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_alias> 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).
@@ -17,7 +17,7 @@ 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):
`conn_alias? 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).
@@ -1,21 +0,0 @@
# SMP confirmation timeout recovery
## Problem
When sending an SMP confirmation a network timeout can lead to the following race condition:
- server receives the confirmation while the joining party fails to receive the server's response;
- joining party deletes the connection together with credentials sent in the confirmation for securing the queue;
- initiating party will receive the confirmation from the server and secure the queue;
- on subsequent attempt to join via the same invitation link initiating party will generate new credentials and fail authorization.
This renders the joining party permanently unable to join via that invitation link and complete the connection.
## Solution
A possible solution is to keep and try to reuse same credentials on subsequent attempts:
- joining party has to remember invitation link when saving the connection;
- if SMP confirmation fails due to network timeout joining party doesn't delete the connection and keeps the credentials;
- when joining, joining party checks whether such invitation link was already used for a connection, if yes:
- joining party tries to send SMP confirmation with the same credentials;
- if this SMP confirmation fails with authorization error (for example it can happen due to race condition explained above) joining party tries to send HELLO message;
- if HELLO message fails with authorization error (it can happen if connection was deleted or secured with different credentials), the recovery is no longer possible and connection can be deleted.
-26
View File
@@ -1,26 +0,0 @@
# Accessing SMP servers via Tor
## Problem
While SMP protocol is focussed on minimizing application-level meta-data by using pair-wise identifiers instead of user profile identifiers, it is important for many users to protect their IP addresses.
Further, even if IP addresses are hidden by onion routing, clients should be able to choose to use a separate TCP connection to subscribe to each queue, even though it increases traffic and battery consumption, as otherwise the servers can observe multiple queues accessed by the same client.
## Solution and requirements
While some users may want to access SMP servers via tor, some other users (even their contacts) may want the opposite - e.g., if they use the network when accessing Tor would be suspicious (or blocked).
Therefore we need to support the connections when one of the user accesses the same server via Tor (and, possibly, via onion address), while another user accesses this server without Tor.
At the same time the user accessing the server via Tor may not want that their contacts access this server without Tor, and it also may be possible that the server is not available under a normal (not .onion) address.
The proposed options for connecting via Tor are:
1. Access servers via Socks proxy: no/yes (specify port?)
2. Use .onion addresses: no/when available/warn/always
3. Require senders to use .onion addresses: yes/no
4. Use separate TCP connection for each queue
While it should be possible for SMP servers to have two addresses (with and without Tor), the queues should only use one server address - if the queue started being accessed via .onion address it should not be possible to access it via a normal address. Queue addresses in connection invitations should support dual server addresses (when senders are not required ot use .onion address).
At the same time, the queue with the normal addresses can be accessed with and without Tor, depending on the current device settings.
+3 -3
View File
@@ -31,7 +31,7 @@ Agent disconnected from host:port
### Received command from the client
```
n --> A : corrId connId parsed_command // raw_command
n --> A : corrId connAlias 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 : connId parsed_message // raw_message
Agent msg : connAlias parsed_message // raw_message
```
### Sent response / message to the client
```
n <-- A : corrId connId parsed_command // raw_command
n <-- A : corrId connAlias parsed_command // raw_command
```
### Database changes
-91
View File
@@ -1,91 +0,0 @@
# Notification server
## Background and motivation
SimpleX Chat clients should receive message notifications when not being online and/or subscribed to SMP servers.
To avoid revealing identities of clients directly to SMP servers via any kind of push notification tokens, a new party called SimpleX Notification Server is introduced to act as a service for subscribing to SMP server queue notifications on behalf of clients and sending push notifications to them.
## Proposal
TCP service using the same TLS transport as SMP server, with the fixed size blocks (256 bytes?) and the following set of commands:
### Protocol
#### Create subscription
Command:
`%s"CREATE " ntfSmpQueueURI ntfPrivateKey token subPublicKey`
Response:
`s%"OK"`
#### Check subscription status
Command:
`%s"CHECK " ntfSmpQueueURI`
Response:
```abnf
statusResp = %s"STAT " status
status = %s"ERR AUTH" / "ERR SMP AUTH" / %s"ERR SMP TIMEOUT" / %s"ACTIVE" / %s"PENDING"
```
#### Update subscription device token
Command:
`%s"TOKEN " ntfSmpQueueURI token`
Response:
`s%"OK" / %s"ERR"`
#### Delete subscription (e.g. when deleting the queue or moving to another notification server)
Command:
`%s"DELETE " SP ntfSmpQueueURI`
Response:
`s%"OK" / %s"ERR"`
### Agent schema changes
See [migration](../src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220322_notifications.hs)
### Agent code
```haskell
data NtfOptions = NtfOptions
{ ntfServer :: Server, -- same type as for SMP servers, probably will be renamed
ntfToken :: ByteString,
ntfInitialCheckDelay :: Int, -- initial check delay after subscription is created, seconds
ntfPeriodicCheckInterval :: Int -- subscription check interval, seconds
}
data AgentConfig = AgentConfig {
-- ...
initialNtfOpts :: Maybe NtfOptions
-- ...
}
data AgentClient = AgentClient {
-- ...
ntfOpts :: TVar (Maybe NtfOptions)
-- ...
}
```
A configuration parameter `initialNtfOpts :: Maybe NtfOptions` - if it is set or changes the agent would automatically manage subscriptions as SMP queues are subscribed/created/deleted and as the token or server changes.
There will be a method to update notifications configuration in case token or server changes.
All subscriptions will be managed in a separate subscription management loop, that would always take the earliest un-updated subscription that requires some action (ntf_sub_action column) and perform this action - the table of subscription would serve both as the table of existing subscriptions and required actions.
E.g. if the queue is subscribed and there is no notification subscription, it will be created in the table with "create" action, and the loop would create it and schedule "check" action on it.
-34
View File
@@ -1,34 +0,0 @@
# SMP protocol changes to support push notifications on iOS
## Problem
There are already commands/responses to allow subscriptions to message notifications - NKEY/NID, NSUB/NMSG. These commands will be used by SMP agent (NKEY/NID) and by notification server (NSUB/NMSG) to have message notifications delivered to notification server, so it can forward them to APNS server using device token.
There are two remaining problems that these commands do not solve.
1. Receiving the message when notification arrives.
iOS requires creating a bundled notification service extension (NSE) that runs in isolated container and, if we were to use the existing commands, would have SMP subscription to the same SMP servers as the main app, triggering resubscriptions every time the message reception switches between the app and NSE. That would cause a substantial increase in traffic and battery consumption to the users.
2. Showing notifications for service messages.
Users do not expect to see notifications for every single SMP messages - e.g., we currently do not show notifications when messages are edited and deleted, and users do not expect them. NSE requires that for every received push notification there should be some notification shown to the users. So only we would have to show a notification for message deletes and updates, we would have to show it for all service messages - e.g. user accepted file invitation, or file transmission has started, contact profile updates and so on.
We considered differentiating whether notifications are sent per queue, from the recipient side, so we do not send notifications for file queues. But it seems insufficient, particularly if we add such features as message receipts, status updates, etc.
## Proposal
1. To retrieve messages when push notifications arrive, we will add 2 SMP commands:
- GET: retrieve one message from the connection. Resonse could be either MSG (the same as when MSG is delivered, but with the correlation id) or GMSG (to simplify processing) TBC during implementation. If message is not available, the response could be ERR NO_MSG
- ACK or GACK: acknowledge that the message was processed by the client and can be removed - TBC which one is better. The response is OK or ERR NO_MSG if there was nothing to acknowledge (same as with ACK now)
This would allow receiving a single message from the queue without subscription, this way avoiding that the main app is unsubscribed from the queue.
2. The only way to avoid showing unnecessary notifications (status updates, service messages, etc.) is to avoid sending them. That requires instructing SMP server whether notification should be sent both per queue, from the recipient side, and per message - from the sender side. So the notification would only be sent if the queue has them enabled (via NKEY command) and the sender includes an additional flag in SEND command. The same flag should be included into MSG, so when the message is retrieved with GET command, the client knows, on the agent or chat level (or both), whether this message should have notification shown to the user, and if not - retrieve the next one(s) as well.
This is a substantial change to SMP protocol, that would require client and server upgrade for notifications to be supported.
We should consider whether to increase the SMP protocol version number to 2, so that the new clients can connect to the old clients but without notifications, or we could keep the old commands in the protocol and instead of adding flags to the existing commands, create new commands.
We can also consider making commands extensible so that the new flags can be added (and ignored by parsers if not supported) to at least some existing commands.
-75
View File
@@ -1,75 +0,0 @@
# DB access and processing messages for iOS notification service extension
## Problem
The only way to receive/process notificaitons is via a separate NSE process that requires a concurrent DB and network access.
SQLite concurenncy does not work, so we need to sync database access.
The problem is complex, as we do not directly control db access from the app, it can be triggered by the message arriving and it may fail to complete in case the app is suspended in the background.
So we need to prevent db access from starting when we know the app is about to be suspended.
The last problem is how to receive and process messages in NSE - should it use recently added GET command or should it subscribe to the connections that receive messages and process messages normally.
To summarize, 2 problems need to be solved:
1. sync db access between 2 (or more, if we add share extension) processes
2. prevent access from starting when the process is due to suspend, only complete operations.
3. Receiveing and processing agent messages in NSE
## Proposed solution
For problem 1, we can use Posix semaphores from our core code, in the same bracket that manages database connection - it would wait for semaphore to be free and unlock it once the db operation is complete.
For problem 2, we need to communicate from the app when it goes to the background to prevent database access starting and completing before the suspension. This would set some `aboutToSuspend` STM flag (or the opposite) that would prevent operations from progressing (using STM retry, that would block until the flag has the value allowing operation to progress).
Several possibilities can be considered:
- use this flag in the bracket that provides DB connections. While simple, it may lock some operations in the middle and may also lead to the situation when network operation succeeds but database access was blocked, and the database is not updated.
- use this flag to stop network operations that would require database updates - like sending messages, subscriptions and ACK - all these operations would require database access once they succeed.
- use two flags, for both cases above, but set them at different times since going to background - block new network operations as soon as the app goes to the background and block database access once the app is about to be suspended.
The last option seems more robust. To do it, there will be an api allowing the app to communicat its phase:
- app going to the background would trigger blocking new network operations and start a new background task - `background` phase.
- background task receiving completion warning, or, maybe, some time after it is started - probably 20 seconds - or whatever happens earlier - would trigger call blocking db access - `suspended` phase.
- app becoming active would trigger unblocking both flags - `active` phase.
`/_app phase <phase>` where `phase` can be one of the above values.
NSE would also use the same phases:
- sending `active` when it is started (the process starts as active, but it is possible that the new notification arrives to the same process, after the previous one sent background/suspension)
- sending `background + suspended` (or `suspended` should set both flags) once it is finished processing the notification, provided no new notification arrived and started processing - this should be tracked in NSE.
For problem 3, NSE can do one of the following:
- use SUB and process messages normally - the downside is that the app will have to resubscribe and it has to be tracked.
- use GET and process messages by pushing them through the processing function - the downside it that a rewiring of message processing is needed.
- use GET but deliver messages through the same queue as when they arrive normally (in which case getMessage agent function should not return the message, but will return a flag showing whether the message was received, or, possibly, or, possibly will return a message but the message would also be sent to the queue?).
- process messages in agent manually and in chat via the queue.
One of the downside of GET is that it requires calling GET again after ACK. We could have two variants of ACK (or additional ACK parameter) - one that never delivers a new message, and another one that does. In this case, if get needs to process the next message (when the current one has no notification flag), it can call ACK that delivers the next message. But, it is probably a premature optimization, and having general support of batched commands would add more value.
Additional problem is concurrency in NSE - if the new notification from the same queue arrives before the current one finishes processing in the same process one of the following can happen:
- the 2nd notification naively call GET and receives the same message.
- the 2nd notification waits until the first finished processing, in which case it can run out of time.
The problem is that the app won't know it's the same queue, as nId is encrypted, so the agent should handle this scenario when the new call to getMessage is made before the previous one finished processing, and differentiate between calls made for additional messages (possibly, getMessage should include previous message ID, if it is available) and the first call.
EDIT: GETs have to be sent from UI to chat and from chat to agent as function calls, but the agent will have to queue get calls to make sure they return different messages. GET call would return message flags (incl. notification flag), so that the UI can send the next GET if needed without waiting.
Considered alternative: include notification content in the message and have NSE only perform decryption, without any network IO. In this case notification content would be in SEND and in NMSG, e2e encrypted.
While promising, as it solves network coordination issues and makes GET unnecessary, it creates mutliple other problems, so it was rejected:
- message content is exposed to centralized ntf and apns servers, creating additional attack vector.
- it adds complexity in security critical parts of the stack - double ratchet encryption, as it requires either storing message keys and using different IVs for notifications, or initializing completely separate ratchet for notifications content.
- it reduces the size of the message.
- it makes user experience worse, as:
- it would not accelerate handshake for new contacts and for file delivery - this approach only works for content messages.
- it would open the app without the new messages - the users would have to wait until the messages are received. It is also bad for "security optics" - the users might think that the message content was exposed to notifications.
-61
View File
@@ -1,61 +0,0 @@
sequenceDiagram
participant M as iOS message<br>notification
participant S as iOS system
participant N as iOS NSE
participant U as iOS UI
participant C as Core chat
participant A as Core agent
M ->> N: notification
S ->> N: get app pref
note over N: ignore,<br>app is active
note over M, A: app going to background
S ->> U: phase: background<br>(possibly, "will" method)
U ->> S: set app pref "pausing"
U ->> C: /_app phase paused, result CRCmdOk
C ->> A: pauseAgent<br>(no new network IO)
M ->> N: notification
S ->> N: get app pref
note over N: wait/poll for<br>"paused"/"suspending"/"suspended"<br>event/pref
A ->> C: event "IO paused"<br>(after in-flight op completed)<br>PHASE PAUSED
C ->> U: event "IO paused" (CRAppPaused)
U ->> S: set shared pref "paused"
note over M, A: process notification
M ->> N: notification
S ->> N: get app pref<br>continue if<br>"paused"/"suspending"/"suspended"
N ->> S: set NSE pref "active"
N ->> C: /_get message
C ->> A: getMessage
A ->> C: msg flags
C ->> N: msg flags
note over N: get messages<br>until notification flag set
A ->> C: MSG/CONF/INFO
C ->> N: some event
N ->> S: set NSE pref "completed"
N ->> S: show notification
note over M, A: app about to be suspended<br>(or 15-20 sec after background)
S ->> U: background task notice
U ->> S: set app pref "suspending"
U ->> C: /_app phase suspended, response ok
C ->> A: suspendAgent<br>(no new DB)
A ->> C: event "DB paused"<br>(after in-flight op completed)<br>PHASE SUSPENDED
C ->> U: event "DB paused" (CRAppSuspended)
U ->> S: set app pref "suspended"
note over M, A: app about to be activated
S ->> U: phase: active<br>(or inactive?)<br><br>(possibly, "will" method)
S ->> U: get NSE pref
U ->> S: set app pref "activating"
alt nse active?
U ->> C: /_app phase inactive
note over U: poll/wait till NSE pref is "completed"
end
U ->> C: /_app phase active (response result)
C ->> A: activateAgent<br>(allow IO/DB)
A ->> C: result ()
C ->> U: CRCmdOk
U ->> S: set app pref "active"
-25
View File
@@ -1,25 +0,0 @@
# smp-server docker container
0. Install `docker` to your host.
1. Build your `smp-server` image:
- **Option 1** - Compile `smp-server` from source (stable branch):
```sh
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-build.Dockerfile .
```
- **Option 2** - Download latest `smp-server` from [latest Github release](https://github.com/simplex-chat/simplexmq/releases/latest):
```sh
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-download.Dockerfile .
```
2. Run new docker container:
```sh
docker run -d \
--name smp-server \
-e addr="your_ip_or_domain" \
-p 5223:5223 \
-v ${PWD}/config:/etc/opt/simplex \
-v ${PWD}/logs:/var/opt/simplex \
smp-server
```
Configuration files and logs will be written to [`config`](./config) and [`logs`](./logs) folders respectively.
-1
View File
@@ -1 +0,0 @@
smp-server configuration, certificate and fingerprint will be stored here
-23
View File
@@ -1,23 +0,0 @@
#!/usr/bin/env sh
confd="/etc/opt/simplex"
logd="/var/opt/simplex/"
# Check if server has been initialized
if [ ! -f "$confd/smp-server.ini" ]; then
# If not, determine ip or domain
case $addr in
'') printf "Please specify \$addr environment variable.\n"; exit 1 ;;
*[a-zA-Z]*) smp-server init -l -n "$addr" ;;
*) smp-server init -l --ip "$addr" ;;
esac
fi
# backup store log
[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log.bak
# rotate server log
[ -f "$logd/smp-server.log" ] && mv "$logd"/smp-server.log "$logd"/smp-server-"$(date +'%FT%T')".log
# Finally, run smp-sever. Notice that "exec" here is important:
# smp-server replaces our helper script, so that it can catch INT signal
exec smp-server start > "$logd"/smp-server.log 2>&1
-1
View File
@@ -1 +0,0 @@
smp-server general logs, stored messages and statistics (if enabled) will be stored here
@@ -1,53 +0,0 @@
FROM ubuntu:focal AS final
FROM ubuntu:focal AS build
### Build stage
# Install curl and git and smp-related dependencies
RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev
# Install ghcup
RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghcup && \
chmod +x /usr/bin/ghcup
# Install ghc
RUN ghcup install ghc
# Install cabal
RUN ghcup install cabal
# Set both as default
RUN ghcup set ghc && \
ghcup set cabal
# Clone simplexmq repository
RUN git clone https://github.com/simplex-chat/simplexmq
# and cd to it
WORKDIR ./simplexmq
# Adjust PATH
ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
# Compile smp-server
RUN cabal update
RUN cabal install
### Final stage
FROM final
# Install OpenSSL dependency
RUN apt-get update && apt-get install -y openssl
# Copy compiled smp-server from build stage
COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
# Copy our helper script
COPY ./entrypoint /usr/bin/entrypoint
# Open smp-server listening port
EXPOSE 5223
# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
STOPSIGNAL SIGINT
# Finally, execute helper script
ENTRYPOINT [ "/usr/bin/entrypoint" ]
@@ -1,20 +0,0 @@
FROM ubuntu:focal
# Install curl
RUN apt-get update && apt-get install -y curl
# Download latest smp-server release and assign executable permission
RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64 -o /usr/bin/smp-server && \
chmod +x /usr/bin/smp-server
# Copy our helper script
COPY ./entrypoint /usr/bin/entrypoint
# Open smp-server listening port
EXPOSE 5223
# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
STOPSIGNAL SIGINT
# Finally, execute helper script
ENTRYPOINT [ "/usr/bin/entrypoint" ]
-178
View File
@@ -1,178 +0,0 @@
#!/bin/bash
# <UDF name="enable_store_log" label="Store log - persist notification subscriptions to append only log and restore them upon server restart." default="on" oneof="on, off" />
# <UDF name="api_token" label="Linode API token - enable Linode to create tags with server address, fingerprint and version. Note: minimal permissions token should have are read/write access to `linodes` (to create tags) and `domains` (to add A record for the third level domain if FQDN is provided)." default="" />
# <UDF name="fqdn" label="FQDN (Fully Qualified Domain Name) - provide third level domain name (e.g. ntf.example.com). If provided use `ntf://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `ntf://fingerprint@IP` instead." default="" />
# <UDF name="apns_key_id" label="APNS key ID." default="" />
# Log all stdout output to stackscript.log
exec &> >(tee -i /var/log/stackscript.log)
# Uncomment next line to enable debugging features
# set -xeo pipefail
cd $HOME
# https://superuser.com/questions/1638779/automatic-yess-to-linux-update-upgrade
# https://superuser.com/questions/1412054/non-interactive-apt-upgrade
sudo DEBIAN_FRONTEND=noninteractive \
apt-get \
-o Dpkg::Options::=--force-confold \
-o Dpkg::Options::=--force-confdef \
-y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
update
sudo DEBIAN_FRONTEND=noninteractive \
apt-get \
-o Dpkg::Options::=--force-confold \
-o Dpkg::Options::=--force-confdef \
-y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
dist-upgrade
# TODO install unattended-upgrades
sudo DEBIAN_FRONTEND=noninteractive \
apt-get \
-o Dpkg::Options::=--force-confold \
-o Dpkg::Options::=--force-confdef \
-y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
install jq
# Add firewall
echo "y" | ufw enable
# Open ports
ufw allow ssh
ufw allow https
ufw allow 5223
# Increase file descriptors limit
echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
echo 'root soft nofile unlimited' >> /etc/security/limits.conf
echo 'root hard nofile unlimited' >> /etc/security/limits.conf
# Download latest release
bin_dir="/opt/simplex-notifications/bin"
binary="$bin_dir/ntf-server"
mkdir -p $bin_dir
curl -L -o $binary https://github.com/simplex-chat/simplexmq/releases/latest/download/ntf-server-ubuntu-20_04-x86-64
chmod +x $binary
# / Add to PATH
cat > /etc/profile.d/simplex.sh << EOF
#!/bin/bash
export PATH="$PATH:$bin_dir"
EOF
# Add to PATH /
# Source and test PATH
source /etc/profile.d/simplex.sh
ntf-server --version
# Initialize server
init_opts=()
[[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
ip_address=$(curl ifconfig.me)
init_opts+=(--ip $ip_address)
[[ -n "$FQDN" ]] && init_opts+=(-n $FQDN)
ntf-server init "${init_opts[@]}"
# Server fingerprint
fingerprint=$(cat /etc/opt/simplex-notifications/fingerprint)
# Determine server address to specify in welcome script and Linode tag
if [[ -n "$FQDN" ]]; then
server_address=$FQDN
else
server_address=$ip_address
fi
# Set up welcome script
on_login_script="/opt/simplex-notifications/on_login.sh"
# / Welcome script
cat > $on_login_script << EOF
#!/bin/bash
fingerprint=\$1
server_address=\$2
cat << EOF2
********************************************************************************
SimpleX notifications server address: ntf://\$fingerprint@\$server_address
Check server status with: systemctl status ntf-server
To keep this server secure, the UFW firewall is enabled.
All ports are BLOCKED except 22 (SSH), 443 (HTTPS), 5223 (notifications server).
********************************************************************************
To stop seeing this message delete line - bash /opt/simplex-notifications/on_login.sh - from /root/.bashrc
EOF2
EOF
# Welcome script /
chmod +x $on_login_script
echo "bash $on_login_script $fingerprint $server_address" >> /root/.bashrc
# Create A record and update Linode's tags
if [[ -n "$API_TOKEN" ]]; then
if [[ -n "$FQDN" ]]; then
domain_address=$(echo $FQDN | rev | cut -d "." -f 1,2 | rev)
domain_id=$(curl -H "Authorization: Bearer $API_TOKEN" https://api.linode.com/v4/domains \
| jq --arg da "$domain_address" '.data[] | select( .domain == $da ) | .id')
if [[ -n $domain_id ]]; then
curl \
-s -H "Content-Type: application/json" \
-H "Authorization: Bearer $API_TOKEN" \
-X POST -d "{\"type\":\"A\",\"name\":\"$FQDN\",\"target\":\"$ip_address\"}" \
https://api.linode.com/v4/domains/${domain_id}/records
fi
fi
version=$(ntf-server --version | cut -d ' ' -f 3-)
curl \
-s -H "Content-Type: application/json" \
-H "Authorization: Bearer $API_TOKEN" \
-X PUT -d "{\"tags\":[\"$server_address\",\"$fingerprint\",\"$version\"]}" \
https://api.linode.com/v4/linode/instances/$LINODE_ID
fi
# / Create systemd service
cat > /etc/systemd/system/ntf-server.service << EOF
[Unit]
Description=SimpleX notifications server
[Service]
Environment="APNS_KEY_FILE=/etc/opt/simplex-notifications/AuthKey.p8"
Environment="APNS_KEY_ID=$APNS_KEY_ID"
Type=simple
ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex-notifications/ntf-server.log 2>&1"
KillSignal=SIGINT
Restart=always
RestartSec=10
LimitNOFILE=1000000
LimitNOFILESoft=1000000
[Install]
WantedBy=multi-user.target
EOF
# Create systemd service /
# Start systemd service
chmod 644 /etc/systemd/system/ntf-server.service
sudo systemctl enable ntf-server
# ! APNS key file and certificate have to be copied manually
# sudo systemctl start ntf-server
# Reboot Linode to apply upgrades
# sudo reboot
@@ -1,4 +1,10 @@
# SMP server image for DigitalOcean
# Server image for DigitalOcean
The current image used for 1-click deployment on DigitalOcean does not contain the source or binary of SMP Server - it downloads the compiled binary of the latest release (rather than a particular release) from GitHub.
The upside is that the new image does not have to be created and approved by DigitalOcean every time when the new release is created.
The downside is that while the release is being prepared in CI, when the release object is already created in GitHub but the server binary is not attached yet, the attempt to install the server would fail - it can last anything from several to 20 minutes, depending on whether the cached dependencies were used or everything was recompiled. Currently, when there is a small number of users, it is not a big problem, but we should consider some possible solutions in the future. Linode StackScript has the same issue.
## How to build an image
@@ -16,8 +22,3 @@ brew install hashicorp/tap/packer
cd ./scripts/smp-server-digitalocean-droplet
DIGITALOCEAN_TOKEN=$YOUR_TOKEN packer build -on-error=ask -color=false ./marketplace-image.json
```
**TODO** (see Linode script)
- Increase file descriptors limit
- Configure Restart for systemd service
@@ -1,51 +0,0 @@
#!/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
@@ -1,16 +1,17 @@
#!/bin/bash
# receives pubkey_hash file location as the first parameter
fingerprint=$1
server_address=$2
ip_address=$(hostname -I | awk '{print$1}')
hash=$(cat $1)
cat <<EOF
********************************************************************************
SMP server address: smp://$fingerprint@$server_address
SMP server address: $ip_address#$hash
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), 443 (HTTPS), 5223 (SMP server).
All ports are BLOCKED except 22 (SSH), 80 (HTTP), 5223 (SMP server).
********************************************************************************
To stop seeing this message delete line - bash /opt/simplex/on_login.sh - from /root/.bashrc
@@ -1,12 +0,0 @@
#!/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
@@ -1,25 +1,8 @@
#!/bin/sh
# 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
# update apt
apt-get -y update
apt-get -y 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 \
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
# packages needed for smp-server init-start.sh
apt-get install -y jq
@@ -1,9 +1,9 @@
#!/bin/sh
# Add firewall
# add firewall
echo "y" | ufw enable
# Open ports
# open ports
ufw allow ssh
ufw allow https
ufw allow http
ufw allow 5223
@@ -1,23 +1,57 @@
#!/bin/bash
chmod +x /opt/simplex/server_bootstrap.sh
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
# / Create systemd service for server bootstrap script
cat > /etc/systemd/system/server-bootstrap.service << EOF
echo "downloading the latest SMP server release"
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 -
release_version=$(jq '.tag_name' release.json | tr -d \")
echo "downloaded SMP server $release_version"
rm release.json
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
[Unit]
Description=Server bootstrap script that downloads and initializes SMP server from the latest release
Description=SMP server systemd service
[Service]
Type=oneshot
ExecStart=/opt/simplex/server_bootstrap.sh
Type=simple
ExecStart=/bin/sh -c "$bin_dir/smp-server start"
[Install]
WantedBy=multi-user.target
EOF
# Create systemd service for server bootstrap script /
EOT
chmod 644 /etc/systemd/system/smp-server.service
# 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
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
+70 -120
View File
@@ -1,175 +1,125 @@
#!/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="" />
# <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
# 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
# https://superuser.com/questions/1638779/automatic-yess-to-linux-update-upgrade
# https://superuser.com/questions/1412054/non-interactive-apt-upgrade
sudo DEBIAN_FRONTEND=noninteractive \
apt-get \
-o Dpkg::Options::=--force-confold \
-o Dpkg::Options::=--force-confdef \
-y --allow-downgrades --allow-remove-essential --allow-change-held-packages \
update
sudo apt-get -y update
sudo apt-get -y upgrade
sudo 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
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
# add firewall
echo "y" | ufw enable
# Open ports
# open ports
ufw allow ssh
ufw allow https
ufw allow http
ufw allow 5223
# Increase file descriptors limit
echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
echo 'root soft nofile unlimited' >> /etc/security/limits.conf
echo 'root hard nofile unlimited' >> /etc/security/limits.conf
# Download latest release
bin_dir="/opt/simplex/bin"
binary="$bin_dir/smp-server"
conf_dir="/etc/opt/simplex"
var_dir="/var/opt/simplex"
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
mkdir -p $conf_dir
mkdir -p $var_dir
# / Add to PATH
cat > /etc/profile.d/simplex.sh << EOF
# 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
#!/bin/bash
export PATH="$PATH:$bin_dir"
EOF
# Add to PATH /
# Source and test PATH
EOT
source /etc/profile.d/simplex.sh
smp-server --version
# Initialize server
# initialize SMP server
init_opts=()
[[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
ip_address=$(curl ifconfig.me)
init_opts+=(--ip $ip_address)
[[ -n "$FQDN" ]] && init_opts+=(-n $FQDN)
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 [[ -n "$FQDN" ]]; then
server_address=$FQDN
else
server_address=$ip_address
fi
# Set up welcome script
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
on_login_script="/opt/simplex/on_login.sh"
# / Welcome script
cat > $on_login_script << EOF
cat <<EOT >> $on_login_script
#!/bin/bash
# receives pubkey_hash file location as the first parameter
fingerprint=\$1
server_address=\$2
ip_address=\$(hostname -I | awk '{print\$1}')
hash=\$(cat \$1)
cat << EOF2
cat <<EOF
********************************************************************************
SMP server address: smp://\$fingerprint@\$server_address
SMP server address: \$ip_address#\$hash
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), 443 (HTTPS), 5223 (SMP server).
All ports are BLOCKED except 22 (SSH), 80 (HTTP), 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 $fingerprint $server_address" >> /root/.bashrc
echo "bash $on_login_script $hash_file" >> /root/.bashrc
# Create A record and update Linode's tags
if [[ -n "$API_TOKEN" ]]; then
if [[ -n "$FQDN" ]]; then
domain_address=$(echo $FQDN | rev | cut -d "." -f 1,2 | rev)
domain_id=$(curl -H "Authorization: Bearer $API_TOKEN" https://api.linode.com/v4/domains \
| jq --arg da "$domain_address" '.data[] | select( .domain == $da ) | .id')
if [[ -n $domain_id ]]; then
curl \
-s -H "Content-Type: application/json" \
-H "Authorization: Bearer $API_TOKEN" \
-X POST -d "{\"type\":\"A\",\"name\":\"$FQDN\",\"target\":\"$ip_address\"}" \
https://api.linode.com/v4/domains/${domain_id}/records
fi
fi
# 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
version=$(smp-server --version | cut -d ' ' -f 3-)
hash=$(cat $hash_file)
release_version=$(jq '.tag_name' release.json | tr -d \")
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
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
fi
# / Create systemd service
cat > /etc/systemd/system/smp-server.service << EOF
# create, enable and start SMP server systemd service
cat <<EOT >> /etc/systemd/system/smp-server.service
[Unit]
Description=SMP server
Description=SMP server systemd service
[Service]
Type=simple
ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
KillSignal=SIGINT
TimeoutStopSec=infinity
Restart=always
RestartSec=10
LimitNOFILE=1000000
LimitNOFILESoft=1000000
ExecStart=/bin/sh -c "$bin_dir/smp-server start"
[Install]
WantedBy=multi-user.target
EOF
# Create systemd service /
# Start systemd service
EOT
chmod 644 /etc/systemd/system/smp-server.service
sudo systemctl enable smp-server
sudo systemctl start smp-server
# Reboot Linode to apply upgrades
sudo reboot
# cleanup
rm release.json
-37
View File
@@ -1,37 +0,0 @@
1. Install `tor` following [official guide](https://community.torproject.org/onion-services/setup/install/).
2. Modify `/etc/tor/torrc` configuration file:
```sh
...
# Disable anonymous mode for better connectivity
## Needed for HiddenServiceNonAnonymousMode
SOCKSPort 0
## Needed for HiddenServiceSingleHopMode
HiddenServiceNonAnonymousMode 1
## Flag to disable anonymous mode
## This option reduces the latency of server connection, but it makes server itself not anonymous,
## it only protects the anonymity of the users connecting to the server.
## In case your server address has both public and onion hostnames it is not anonymous anyway,
## so this is what you want.
HiddenServiceSingleHopMode 1
# Specify folder for smp-tor
## Folder for keys, address, etc.
HiddenServiceDir /var/lib/tor/simplex-smp/
## Map smp port (5223) to tor
HiddenServicePort 5223 localhost:5223
...
```
3. Restart `tor` system service:
```
sudo systemctl restart tor
```
4. Onion address can be obtained from following file:
```sh
sudo cat /var/lib/tor/simplex-smp/hostname
```
-12
View File
@@ -1,12 +0,0 @@
#!/bin/bash
# systemd has to be configured to use SIGINT to save and restore undelivered messages after restart.
# Add this to [Service] section:
# KillSignal=SIGINT
curl -L -o /opt/simplex/bin/smp-server-new https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64
systemctl stop smp-server
cp /var/opt/simplex/smp-server-store.log /var/opt/simplex/smp-server-store.log.bak
mv /opt/simplex/bin/smp-server /opt/simplex/bin/smp-server-old
mv /opt/simplex/bin/smp-server-new /opt/simplex/bin/smp-server
chmod +x /opt/simplex/bin/smp-server
systemctl start smp-server
+45 -207
View File
@@ -4,8 +4,8 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
name: simplexmq
version: 3.3.0
name: simplexmq-v0
version: 0.5.3
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -19,323 +19,183 @@ category: Chat, Network, Web, System, Cryptography
homepage: https://github.com/simplex-chat/simplexmq#readme
author: simplex.chat
maintainer: chat@simplex.chat
copyright: 2020-2022 simplex.chat
copyright: 2020 simplex.chat
license: AGPL-3
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
CHANGELOG.md
flag swift
description: Enable swift JSON format
manual: True
default: False
migrations/20210101_initial.sql
migrations/20210624_confirmations.sql
migrations/20210809_snd_messages.sql
migrations/20211202_connection_mode.sql
migrations/README.md
library
exposed-modules:
Simplex.Messaging.Agent
Simplex.Messaging.Agent.Client
Simplex.Messaging.Agent.Env.SQLite
Simplex.Messaging.Agent.NtfSubSupervisor
Simplex.Messaging.Agent.ExceptT
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.M20220608_v2
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
Simplex.Messaging.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.Stats
Simplex.Messaging.Notifications.Server.Store
Simplex.Messaging.Notifications.Server.StoreLog
Simplex.Messaging.Notifications.Transport
Simplex.Messaging.Notifications.Types
Simplex.Messaging.Parsers
Simplex.Messaging.Protocol
Simplex.Messaging.Server
Simplex.Messaging.Server.CLI
Simplex.Messaging.Server.Env.STM
Simplex.Messaging.Server.Expiration
Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.STM
Simplex.Messaging.Server.QueueStore
Simplex.Messaging.Server.QueueStore.STM
Simplex.Messaging.Server.Stats
Simplex.Messaging.Server.StoreLog
Simplex.Messaging.TMap
Simplex.Messaging.TMap2
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
Paths_simplexmq_v0
hs-source-dirs:
src
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.14.*
, base >=4.14 && <5
, attoparsec ==0.13.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, direct-sqlite ==2.3.*
, directory ==1.3.*
, file-embed >=0.0.14.0 && <=0.0.15.0
, 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.4
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, network ==3.1.*
, network-transport ==0.5.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, 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.14 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
, generic-random >=1.3 && <1.5
, http-types ==0.12.*
, http2 ==3.0.*
, ini ==0.4.*
, iso8601-time ==0.1.*
, memory ==0.15.*
, mtl ==2.2.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.4
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, websockets ==0.12.*
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
executable smp-agent
main-is: Main.hs
other-modules:
Paths_simplexmq
Paths_simplexmq_v0
hs-source-dirs:
apps/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.14.*
, base >=4.14 && <5
, attoparsec ==0.13.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, direct-sqlite ==2.3.*
, directory ==1.3.*
, file-embed >=0.0.14.0 && <=0.0.15.0
, 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.4
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, network ==3.1.*
, network-transport ==0.5.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, simplexmq-v0
, 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-server
main-is: Main.hs
other-modules:
Paths_simplexmq
Paths_simplexmq_v0
hs-source-dirs:
apps/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.14.*
, base >=4.14 && <5
, attoparsec ==0.13.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, direct-sqlite ==2.3.*
, directory ==1.3.*
, file-embed >=0.0.14.0 && <=0.0.15.0
, 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.4
, network ==3.1.*
, network-transport ==0.5.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, simplexmq-v0
, 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
test-suite smp-server-test
@@ -344,78 +204,56 @@ test-suite smp-server-test
other-modules:
AgentTests
AgentTests.ConnectionRequestTests
AgentTests.DoubleRatchetTests
AgentTests.FunctionalAPITests
AgentTests.NotificationTests
AgentTests.SchemaDump
AgentTests.SQLiteTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
CoreTests.VersionRangeTests
NtfClient
NtfServerTests
ProtocolErrorTests
ServerTests
SMPAgentClient
SMPClient
Paths_simplexmq
Paths_simplexmq_v0
hs-source-dirs:
tests
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
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.14.*
, base >=4.14 && <5
, attoparsec ==0.13.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, direct-sqlite ==2.3.*
, directory ==1.3.*
, file-embed >=0.0.14.0 && <=0.0.15.0
, 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.2.7 && <3.2
, network-transport ==0.5.4
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, network ==3.1.*
, network-transport ==0.5.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, simplexmq-v0
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, timeit ==2.0.*
, tls >=1.6.0 && <1.7
, 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
File diff suppressed because it is too large Load Diff
File diff suppressed because it is too large Load Diff
+40 -140
View File
@@ -1,145 +1,63 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
module Simplex.Messaging.Agent.Env.SQLite
( AgentMonad,
AgentConfig (..),
AgentDatabase (..),
databaseFile,
InitialAgentServers (..),
NetworkConfig (..),
defaultAgentConfig,
defaultReconnectInterval,
Env (..),
newSMPAgentEnv,
createAgentStore,
NtfSupervisor (..),
NtfSupervisorCommand (..),
)
where
module Simplex.Messaging.Agent.Env.SQLite where
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Data.Word (Word16)
import Network.Socket
import Numeric.Natural
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Protocol (SMPServer)
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport.Client (defaultSMPPort)
import Simplex.Messaging.Version
import System.Random (StdGen, newStdGen)
import UnliftIO (Async)
import UnliftIO.STM
-- | Agent monad with MonadReader Env and MonadError AgentErrorType
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
data InitialAgentServers = InitialAgentServers
{ smp :: NonEmpty SMPServer,
ntf :: [NtfServer],
netCfg :: NetworkConfig
}
data AgentDatabase
= AgentDB SQLiteStore
| AgentDBFile {dbFile :: FilePath, dbKey :: String}
databaseFile :: AgentDatabase -> FilePath
databaseFile = \case
AgentDB SQLiteStore {dbFilePath} -> dbFilePath
AgentDBFile {dbFile} -> dbFile
data AgentConfig = AgentConfig
{ tcpPort :: ServiceName,
cmdSignAlg :: C.SignAlg,
smpServers :: NonEmpty SMPServer,
rsaKeySize :: Int,
connIdBytes :: Int,
tbqSize :: Natural,
database :: AgentDatabase,
yesToMigrations :: Bool,
smpCfg :: ProtocolClientConfig,
ntfCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
messageRetryInterval :: RetryInterval,
messageTimeout :: NominalDiffTime,
helloTimeout :: NominalDiffTime,
ntfCron :: Word16,
ntfWorkerDelay :: Int,
ntfSMPWorkerDelay :: Int,
ntfSubCheckInterval :: NominalDiffTime,
ntfMaxMessages :: Int,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
smpAgentVRange :: VersionRange,
smpClientVRange :: VersionRange
dbFile :: FilePath,
dbPoolSize :: Int,
smpCfg :: SMPClientConfig,
retryInterval :: RetryInterval,
reconnectInterval :: RetryInterval
}
defaultReconnectInterval :: RetryInterval
defaultReconnectInterval =
RetryInterval
{ initialInterval = 2_000000,
increaseAfter = 10_000000,
maxInterval = 180_000000
}
defaultMessageRetryInterval :: RetryInterval
defaultMessageRetryInterval =
RetryInterval
{ initialInterval = 1_000000,
increaseAfter = 10_000000,
maxInterval = 60_000000
}
minute :: Int
minute = 60_000_000
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
{ tcpPort = "5224",
cmdSignAlg = C.SignAlg C.SEd448,
smpServers = undefined,
rsaKeySize = 2048 `div` 8,
connIdBytes = 12,
tbqSize = 64,
database = AgentDBFile {dbFile = "smp-agent.db", dbKey = ""},
yesToMigrations = False,
smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
reconnectInterval = defaultReconnectInterval,
messageRetryInterval = defaultMessageRetryInterval,
messageTimeout = 2 * nominalDay,
helloTimeout = 2 * nominalDay,
ntfCron = 20, -- minutes
ntfWorkerDelay = 100000, -- microseconds
ntfSMPWorkerDelay = 500000, -- microseconds
ntfSubCheckInterval = nominalDay,
ntfMaxMessages = 4,
-- 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",
smpAgentVRange = supportedSMPAgentVRange,
smpClientVRange = supportedSMPClientVRange
tbqSize = 16,
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
}
}
data Env = Env
@@ -147,38 +65,20 @@ data Env = Env
store :: SQLiteStore,
idsDrg :: TVar ChaChaDRG,
clientCounter :: TVar Int,
randomServer :: TVar StdGen,
ntfSupervisor :: NtfSupervisor
reservedMsgSize :: Int,
randomServer :: TVar StdGen
}
newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
newSMPAgentEnv config@AgentConfig {database, yesToMigrations} = do
newSMPAgentEnv cfg = do
idsDrg <- newTVarIO =<< drgNew
store <- case database of
AgentDB st -> pure st
AgentDBFile {dbFile, dbKey} -> liftIO $ createAgentStore dbFile dbKey yesToMigrations
store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
clientCounter <- newTVarIO 0
randomServer <- newTVarIO =<< liftIO newStdGen
ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
data NtfSupervisor = NtfSupervisor
{ ntfTkn :: TVar (Maybe NtfToken),
ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
}
data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
deriving (Show)
newNtfSubSupervisor :: Natural -> STM NtfSupervisor
newNtfSubSupervisor qSize = do
ntfTkn <- newTVar Nothing
ntfSubQ <- newTBQueue qSize
ntfWorkers <- TM.empty
ntfSMPWorkers <- TM.empty
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
return Env {config = cfg, store, idsDrg, clientCounter, 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)
+22
View File
@@ -0,0 +1,22 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Agent.ExceptT where
import Control.Monad.Except
import Control.Monad.IO.Unlift
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)
@@ -1,360 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Agent.NtfSubSupervisor
( runNtfSupervisor,
nsUpdateToken,
nsRemoveNtfToken,
sendNtfSubCommand,
instantNotifications,
closeNtfSupervisor,
getNtfServer,
)
where
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple (logError, logInfo)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Data.Bifunctor (first)
import Data.Fixed (Fixed (MkFixed), Pico)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
import qualified Simplex.Messaging.Agent.Protocol as AP
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (tshow, unlessM)
import System.Random (randomR)
import UnliftIO (async)
import UnliftIO.Concurrent (forkIO, threadDelay)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
runNtfSupervisor c = do
ns <- asks ntfSupervisor
forever $ do
cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
handleError connId . agentOperationBracket c AONtfNetwork waitUntilActive $
runExceptT (processNtfSub c cmd) >>= \case
Left e -> notifyErr connId e
Right _ -> return ()
where
handleError :: ConnId -> m () -> m ()
handleError connId = E.handle $ \(e :: E.SomeException) -> do
logError $ "runNtfSupervisor error " <> tshow e
notifyErr connId e
notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
processNtfSub c (connId, cmd) = do
logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
case cmd of
NSCCreate -> do
(a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
a <- liftIO $ getNtfSubscription db connId
q <- ExceptT $ getRcvQueue db connId
pure (a, q)
logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
case a of
Nothing -> do
withNtfServer c $ \ntfServer -> do
case clientNtfCreds of
Just ClientNtfCreds {notifierId} -> do
let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
ts <- liftIO getCurrentTime
withStore' c $ \db -> createNtfSubscription db newSub (NtfSubNTFAction NSACreate) ts
addNtfNTFWorker ntfServer
Nothing -> do
let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
ts <- liftIO getCurrentTime
withStore' c $ \db -> createNtfSubscription db newSub (NtfSubSMPAction NSASmpKey) ts
addNtfSMPWorker smpServer
(Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer}, action_)) -> do
case action_ of
-- action was set to NULL after worker internal error
Nothing -> resetSubscription
Just (action, _)
-- subscription was marked for deletion / is being deleted
| isDeleteNtfSubAction action -> do
if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
then resetSubscription
else withNtfServer c $ \ntfServer -> do
ts <- liftIO getCurrentTime
withStore' c $ \db ->
supervisorUpdateNtfSubscription db sub {ntfServer} (NtfSubNTFAction NSACreate) ts
addNtfNTFWorker ntfServer
| otherwise -> case action of
NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
NtfSubSMPAction _ -> addNtfSMPWorker smpServer
where
resetSubscription :: m ()
resetSubscription =
withNtfServer c $ \ntfServer -> do
ts <- liftIO getCurrentTime
withStore' c $ \db ->
supervisorUpdateNtfSubscription db sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
addNtfSMPWorker smpServer
NSCDelete -> do
sub_ <- withStore' c $ \db -> do
ts <- liftIO getCurrentTime
supervisorUpdateNtfSubAction db connId (NtfSubNTFAction NSADelete) ts
getNtfSubscription db connId
logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
case sub_ of
(Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
_ -> pure () -- err "NSCDelete - no subscription"
NSCSmpDelete -> do
withStore' c (`getRcvQueue` connId) >>= \case
Right rq@RcvQueue {server = smpServer} -> do
logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
ts <- liftIO getCurrentTime
withStore' c $ \db -> supervisorUpdateNtfSubAction db connId (NtfSubSMPAction NSASmpDelete) ts
addNtfSMPWorker smpServer
_ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
NSCNtfWorker ntfServer ->
addNtfNTFWorker ntfServer
NSCNtfSMPWorker smpServer ->
addNtfSMPWorker smpServer
where
addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
addWorker ::
(NtfSupervisor -> TMap (ProtocolServer s) (TMVar (), Async ())) ->
(AgentClient -> ProtocolServer s -> TMVar () -> m ()) ->
ProtocolServer s ->
m ()
addWorker wsSel runWorker srv = do
ws <- asks $ wsSel . ntfSupervisor
atomically (TM.lookup srv ws) >>= \case
Nothing -> do
doWork <- newTMVarIO ()
worker <- async $ runWorker c srv doWork `E.finally` atomically (TM.delete srv ws)
atomically $ TM.insert srv (doWork, worker) ws
Just (doWork, _) ->
void . atomically $ tryPutTMVar doWork ()
withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
withNtfServer c action = getNtfServer c >>= mapM_ action
runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
runNtfWorker c srv doWork = do
delay <- asks $ ntfWorkerDelay . config
forever $ do
void . atomically $ readTMVar doWork
agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
threadDelay delay
where
runNtfOperation :: m ()
runNtfOperation = do
nextSub_ <- withStore' c (`getNextNtfSubNTFAction` srv)
logInfo $ "runNtfWorker, nextSub_ " <> tshow nextSub_
case nextSub_ of
Nothing -> noWorkToDo
Just a@(NtfSubscription {connId}, _, _) -> do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop ->
processAction a
`catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
processAction :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
processAction (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
ts <- liftIO getCurrentTime
unlessM (rescheduleAction doWork ts actionTs) $
case action of
NSACreate ->
getNtfToken >>= \case
Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
RcvQueue {clientNtfCreds} <- withStore c (`getRcvQueue` connId)
case clientNtfCreds of
Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
-- TODO smaller retry until Active, less frequently (daily?) once Active
let actionTs' = addUTCTime 30 ts
withStore' c $ \db ->
updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
_ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
_ -> workerInternalError c connId "NSACreate - no active token"
NSACheck ->
getNtfToken >>= \case
Just tkn ->
case ntfSubId of
Just nSubId ->
agentNtfCheckSubscription c nSubId tkn >>= \case
NSAuth -> do
getNtfServer c >>= \case
Just ntfServer -> do
withStore' c $ \db ->
updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
_ -> workerInternalError c connId "NSACheck - failed to reset subscription, notification server not configured"
status -> updateSubNextCheck ts status
Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
_ -> workerInternalError c connId "NSACheck - no active token"
NSADelete -> case ntfSubId of
Just nSubId ->
(getNtfToken >>= \tkn -> forM_ tkn $ agentNtfDeleteSubscription c nSubId)
`E.finally` carryOnWithDeletion
Nothing -> carryOnWithDeletion
where
carryOnWithDeletion :: m ()
carryOnWithDeletion = do
withStore' c $ \db ->
updateNtfSubscription db sub {ntfSubId = Nothing, ntfSubStatus = NASOff} (NtfSubSMPAction NSASmpDelete) ts
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
where
updateSubNextCheck ts toStatus = do
checkInterval <- asks $ ntfSubCheckInterval . config
let nextCheckTs = addUTCTime checkInterval ts
updateSub (NASCreated toStatus) (NtfSubNTFAction NSACheck) nextCheckTs
updateSub toStatus toAction actionTs' =
withStore' c $ \db ->
updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> TMVar () -> m ()
runNtfSMPWorker c srv doWork = do
delay <- asks $ ntfSMPWorkerDelay . config
forever $ do
void . atomically $ readTMVar doWork
agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
threadDelay delay
where
runNtfSMPOperation = do
nextSub_ <- withStore' c (`getNextNtfSubSMPAction` srv)
logInfo $ "runNtfSMPWorker, nextSub_ " <> tshow nextSub_
case nextSub_ of
Nothing -> noWorkToDo
Just a@(NtfSubscription {connId}, _, _) -> do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop ->
processAction a
`catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
processAction :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
processAction (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
ts <- liftIO getCurrentTime
unlessM (rescheduleAction doWork ts actionTs) $
case smpAction of
NSASmpKey ->
getNtfToken >>= \case
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
rq <- withStore c (`getRcvQueue` connId)
C.SignAlg a <- asks (cmdSignAlg . config)
(ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
(notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
withStore' c $ \db -> do
setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NtfSubNTFAction NSACreate) ts
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
_ -> workerInternalError c connId "NSASmpKey - no active token"
NSASmpDelete -> do
rq_ <- withStore' c $ \db -> do
setRcvQueueNtfCreds db connId Nothing
getRcvQueue db connId
forM_ rq_ $ \rq -> disableQueueNotifications c rq
withStore' c $ \db -> deleteNtfSubscription db connId
rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
rescheduleAction doWork ts actionTs
| actionTs <= ts = pure False
| otherwise = do
void . atomically $ tryTakeTMVar doWork
void . forkIO $ do
threadDelay $ diffInMicros actionTs ts
void . atomically $ tryPutTMVar doWork ()
pure True
fromPico :: Pico -> Integer
fromPico (MkFixed i) = i
diffInMicros :: UTCTime -> UTCTime -> Int
diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
retryOnError c name loop done e = do
logError $ name <> " error: " <> tshow e
case e of
BROKER NETWORK -> retryLoop
BROKER TIMEOUT -> retryLoop
_ -> done e
where
retryLoop = do
atomically $ endAgentOperation c AONtfNetwork
atomically $ throwWhenInactive c
atomically $ beginAgentOperation c AONtfNetwork
loop
workerInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
workerInternalError c connId internalErrStr = do
withStore' c $ \db -> setNullNtfSubscriptionAction db connId
notifyInternalError c connId internalErrStr
notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
getNtfToken :: AgentMonad m => m (Maybe NtfToken)
getNtfToken = do
tkn <- asks $ ntfTkn . ntfSupervisor
readTVarIO tkn
nsUpdateToken :: NtfSupervisor -> NtfToken -> STM ()
nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
nsRemoveNtfToken :: NtfSupervisor -> STM ()
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
sendNtfSubCommand ns cmd = do
tkn <- readTVar (ntfTkn ns)
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
instantNotifications :: Maybe NtfToken -> Bool
instantNotifications = \case
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
_ -> False
closeNtfSupervisor :: NtfSupervisor -> IO ()
closeNtfSupervisor ns = do
cancelNtfWorkers_ $ ntfWorkers ns
cancelNtfWorkers_ $ ntfSMPWorkers ns
cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
cancelNtfWorkers_ wsVar = do
ws <- atomically $ stateTVar wsVar (,M.empty)
forM_ ws $ uninterruptibleCancel . snd
getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
getNtfServer c = do
ntfServers <- readTVarIO $ ntfServers c
case ntfServers of
[] -> pure Nothing
[srv] -> pure $ Just srv
servers -> do
gen <- asks randomServer
atomically . stateTVar gen $
first (Just . (servers !!)) . randomR (0, length servers - 1)
File diff suppressed because it is too large Load Diff
@@ -1,36 +0,0 @@
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
queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
queryParam_ name (QSP _ q) =
case find ((== name) . fst) q of
Just (_, p) -> either fail pure $ parseAll strP p
_ -> pure Nothing
-81
View File
@@ -1,81 +0,0 @@
{-# 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]
+144 -199
View File
@@ -3,102 +3,101 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
module Simplex.Messaging.Agent.Store where
import Control.Concurrent.STM (TVar)
import Control.Exception (Exception)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Crypto.Random (ChaChaDRG)
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Kind (Type)
import Data.Time (UTCTime)
import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
( MsgBody,
MsgFlags,
MsgId,
NotifierId,
NtfPrivateSignKey,
NtfPublicVerifyKey,
RcvDhSecret,
RcvNtfDhSecret,
RcvPrivateSignKey,
SndPrivateSignKey,
RecipientPrivateKey,
SenderPrivateKey,
SenderPublicKey,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version
-- * Store management
-- | Store class type. Defines store access methods for implementations.
class Monad m => MonadAgentStore s m where
-- Queue and Connection management
createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
getConn :: s -> ConnId -> m SomeConn
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 ()
setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
updateSignKey :: s -> SndQueue -> SignatureKey -> m ()
-- Confirmations
createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
removeConfirmations :: s -> ConnId -> m ()
-- Invitations - sent via Contact connections
createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
getInvitation :: s -> InvitationId -> m Invitation
acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()
deleteInvitation :: s -> ConnId -> InvitationId -> m ()
-- Msg management
updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
createSndMsg :: s -> ConnId -> SndMsgData -> m ()
updateSndMsgStatus :: s -> ConnId -> InternalId -> SndMsgStatus -> m ()
getPendingMsgData :: s -> ConnId -> InternalId -> m MsgBody
getPendingMsgs :: s -> ConnId -> m [InternalId]
getMsg :: s -> ConnId -> InternalId -> m Msg
checkRcvMsg :: s -> ConnId -> InternalId -> m ()
updateRcvMsgAck :: s -> ConnId -> InternalId -> 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,
-- | 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
rcvPrivateKey :: RecipientPrivateKey,
sndId :: Maybe SMP.SenderId,
-- | queue status
status :: QueueStatus,
-- | SMP client version
smpClientVersion :: Version,
-- | credentials used in context of notifications
clientNtfCreds :: Maybe ClientNtfCreds
}
deriving (Eq, Show)
data ClientNtfCreds = ClientNtfCreds
{ -- | key pair to be used by the notification server to sign transmissions
ntfPublicKey :: NtfPublicVerifyKey,
ntfPrivateKey :: NtfPrivateSignKey,
-- | queue ID to be used by the notification server for NSUB command
notifierId :: NotifierId,
-- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
rcvNtfDhSecret :: RcvNtfDhSecret
decryptKey :: DecryptionKey,
verifyKey :: Maybe VerificationKey,
status :: QueueStatus
}
deriving (Eq, Show)
-- | 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,
-- | 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,
-- | SMP client version
smpClientVersion :: Version
sndPrivateKey :: SenderPrivateKey,
encryptKey :: EncryptionKey,
signKey :: SignatureKey,
status :: QueueStatus
}
deriving (Eq, Show)
-- * Connection types
-- | Type of a connection.
data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
-- | Connection of a specific type.
--
@@ -111,7 +110,6 @@ data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
-- - DuplexConnection is a connection that has both receive and send queues set up,
-- typically created by upgrading a receive or a send connection with a missing queue.
data Connection (d :: ConnType) where
NewConnection :: ConnData -> Connection CNew
RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
SndConnection :: ConnData -> SndQueue -> Connection CSnd
DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
@@ -122,14 +120,12 @@ deriving instance Eq (Connection d)
deriving instance Show (Connection d)
data SConnType :: ConnType -> Type where
SCNew :: SConnType CNew
SCRcv :: SConnType CRcv
SCSnd :: SConnType CSnd
SCDuplex :: SConnType CDuplex
SCContact :: SConnType CContact
connType :: SConnType c -> ConnType
connType SCNew = CNew
connType SCRcv = CRcv
connType SCSnd = CSnd
connType SCDuplex = CDuplex
@@ -157,117 +153,22 @@ instance Eq SomeConn where
deriving instance Show SomeConn
data ConnData = ConnData
{ connId :: ConnId,
connAgentVersion :: Version,
enableNtfs :: Bool,
duplexHandshake :: Maybe Bool -- added in agent protocol v2
}
newtype ConnData = ConnData {connId :: ConnId}
deriving (Eq, Show)
data AgentCmdType = ACClient | ACInternal
instance StrEncoding AgentCmdType where
strEncode = \case
ACClient -> "CLIENT"
ACInternal -> "INTERNAL"
strP =
A.takeTill (== ' ') >>= \case
"CLIENT" -> pure ACClient
"INTERNAL" -> pure ACInternal
_ -> fail "bad AgentCmdType"
data AgentCommand
= AClientCommand (ACommand 'Client)
| AInternalCommand InternalCommand
instance StrEncoding AgentCommand where
strEncode = \case
AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
AInternalCommand cmd -> strEncode (ACInternal, cmd)
strP =
strP_ >>= \case
ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
ACInternal -> AInternalCommand <$> strP
data AgentCommandTag
= AClientCommandTag (ACommandTag 'Client)
| AInternalCommandTag InternalCommandTag
instance StrEncoding AgentCommandTag where
strEncode = \case
AClientCommandTag t -> strEncode (ACClient, t)
AInternalCommandTag t -> strEncode (ACInternal, t)
strP =
strP_ >>= \case
ACClient -> AClientCommandTag <$> strP
ACInternal -> AInternalCommandTag <$> strP
data InternalCommand
= ICAck SMP.RecipientId MsgId
| ICAckDel SMP.RecipientId MsgId InternalId
| ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
| ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
data InternalCommandTag
= ICAck_
| ICAckDel_
| ICAllowSecure_
| ICDuplexSecure_
deriving (Show)
instance StrEncoding InternalCommand where
strEncode = \case
ICAck rId srvMsgId -> strEncode (ICAck_, rId, srvMsgId)
ICAckDel rId srvMsgId mId -> strEncode (ICAckDel_, rId, srvMsgId, mId)
ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
strP =
strP_ >>= \case
ICAck_ -> ICAck <$> strP_ <*> strP
ICAckDel_ -> ICAckDel <$> strP_ <*> strP_ <*> strP
ICAllowSecure_ -> ICAllowSecure <$> strP_ <*> strP
ICDuplexSecure_ -> ICDuplexSecure <$> strP_ <*> strP
instance StrEncoding InternalCommandTag where
strEncode = \case
ICAck_ -> "ACK"
ICAckDel_ -> "ACK_DEL"
ICAllowSecure_ -> "ALLOW_SECURE"
ICDuplexSecure_ -> "DUPLEX_SECURE"
strP =
A.takeTill (== ' ') >>= \case
"ACK" -> pure ICAck_
"ACK_DEL" -> pure ICAckDel_
"ALLOW_SECURE" -> pure ICAllowSecure_
"DUPLEX_SECURE" -> pure ICDuplexSecure_
_ -> fail "bad InternalCommandTag"
agentCommandTag :: AgentCommand -> AgentCommandTag
agentCommandTag = \case
AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
internalCmdTag :: InternalCommand -> InternalCommandTag
internalCmdTag = \case
ICAck {} -> ICAck_
ICAckDel {} -> ICAckDel_
ICAllowSecure {} -> ICAllowSecure_
ICDuplexSecure {} -> ICDuplexSecure_
-- * Confirmation types
data NewConfirmation = NewConfirmation
{ connId :: ConnId,
senderConf :: SMPConfirmation,
ratchetState :: RatchetX448
senderKey :: SenderPublicKey,
senderConnInfo :: ConnInfo
}
data AcceptedConfirmation = AcceptedConfirmation
{ confirmationId :: ConfirmationId,
connId :: ConnId,
senderConf :: SMPConfirmation,
ratchetState :: RatchetX448,
senderKey :: SenderPublicKey,
senderConnInfo :: ConnInfo,
ownConnInfo :: ConnInfo
}
@@ -275,14 +176,14 @@ data AcceptedConfirmation = AcceptedConfirmation
data NewInvitation = NewInvitation
{ contactConnId :: ConnId,
connReq :: ConnectionRequestUri 'CMInvitation,
connReq :: ConnectionRequest 'CMInvitation,
recipientConnInfo :: ConnInfo
}
data Invitation = Invitation
{ invitationId :: InvitationId,
contactConnId :: ConnId,
connReq :: ConnectionRequestUri 'CMInvitation,
connReq :: ConnectionRequest 'CMInvitation,
recipientConnInfo :: ConnInfo,
ownConnInfo :: Maybe ConnInfo,
accepted :: Bool
@@ -299,45 +200,70 @@ type PrevRcvMsgHash = MsgHash
-- | Corresponds to `last_snd_msg_hash` in `connections` table
type PrevSndMsgHash = MsgHash
-- * Message data containers
-- ? 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,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
internalRcvId :: InternalRcvId,
internalHash :: MsgHash,
externalPrevSndHash :: MsgHash
}
data RcvMsg = RcvMsg
{ internalId :: InternalId,
msgMeta :: MsgMeta,
msgBody :: MsgBody,
userAck :: Bool
}
data SndMsgData = SndMsgData
{ internalId :: InternalId,
internalSndId :: InternalSndId,
internalTs :: InternalTs,
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
internalHash :: MsgHash,
prevMsgHash :: MsgHash
previousMsgHash :: MsgHash
}
data PendingMsgData = PendingMsgData
{ msgId :: InternalId,
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
internalTs :: InternalTs
data PendingMsg = PendingMsg
{ connId :: ConnId,
msgId :: InternalId
}
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)
@@ -349,11 +275,44 @@ 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
{ connId :: ConnId,
{ connAlias :: 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)
@@ -369,25 +328,19 @@ data MsgBase = MsgBase
newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show)
instance StrEncoding InternalId where
strEncode = strEncode . unId
strP = InternalId <$> strP
type InternalTs = UTCTime
type AsyncCmdId = Int64
-- * Store errors
-- | Agent store error.
data StoreError
= -- | IO exceptions in store actions.
SEInternal ByteString
| -- | Failed to generate unique random ID
| -- | failed to generate unique random ID
SEUniqueID
| -- | Connection not found (or both queues absent).
| -- | Connection alias not found (or both queues absent).
SEConnNotFound
| -- | Connection already used.
| -- | Connection alias 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.
@@ -398,18 +351,10 @@ data StoreError
SEInvitationNotFound
| -- | Message not found
SEMsgNotFound
| -- | Command not found
SECmdNotFound
| -- | Currently not used. The intention was to pass current expected queue status in methods,
-- as we always know what it should be at any stage of the protocol,
-- and in case it does not match use this error.
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
| -- | Used to wrap agent errors inside store operations to avoid race conditions
SEAgentError AgentErrorType
deriving (Eq, Show, Exception)
File diff suppressed because it is too large Load Diff
@@ -1,6 +1,5 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -16,49 +15,30 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
)
where
import Control.Monad (forM_, when)
import Data.List (intercalate, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Control.Monad (forM_)
import Data.FileEmbed (embedDir, makeRelativeToProject)
import Data.Function (on)
import Data.List (intercalate, sortBy)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (Connection, Only (..), Query (..))
import Database.SQLite.Simple (Connection, Only (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport.Client (TransportHost)
import System.FilePath (takeBaseName, takeExtension)
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial),
("20220301_snd_queue_keys", m20220301_snd_queue_keys),
("20220322_notifications", m20220322_notifications),
("20220607_v2", m20220608_v2),
("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
("m20220811_onion_hosts", m20220811_onion_hosts),
("m20220817_connection_ntfs", m20220817_connection_ntfs),
("m20220905_commands", m20220905_commands)
]
-- | The list of migrations in ascending order by date
app :: [Migration]
app = sortOn name $ map migration schemaMigrations
app =
sortBy (compare `on` name) . map migration . filter sqlFile $
$(makeRelativeToProject "migrations" >>= embedDir)
where
migration (name, query) = Migration {name = name, up = fromQuery query}
sqlFile (file, _) = takeExtension file == ".sql"
migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
get :: Connection -> [Migration] -> IO (Either String [Migration])
get conn migrations =
@@ -66,16 +46,11 @@ get conn migrations =
<$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
run :: Connection -> [Migration] -> IO ()
run conn ms = forM_ ms $ \Migration {name, up} -> do
when (name == "m20220811_onion_hosts") updateServers
DB.withImmediateTransaction conn $ insert name >> execSQL up
run conn ms = DB.withImmediateTransaction conn . forM_ ms $
\Migration {name, up} -> insert name >> execSQL up
where
insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
execSQL = SQLite3.exec $ DB.connectionHandle conn
updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
DB.withImmediateTransaction conn $
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
initialize :: Connection -> IO ()
initialize conn =
@@ -1,148 +0,0 @@
{-# 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
);
|]
@@ -1,13 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220301_snd_queue_keys :: Query
m20220301_snd_queue_keys =
[sql|
ALTER TABLE snd_queues ADD COLUMN snd_public_key BLOB;
ALTER TABLE snd_queues ADD COLUMN e2e_pub_key BLOB;
|]
@@ -1,39 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220322_notifications :: Query
m20220322_notifications =
[sql|
CREATE TABLE ntf_servers (
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_key_hash BLOB NOT NULL,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')),
PRIMARY KEY (ntf_host, ntf_port)
) WITHOUT ROWID;
CREATE TABLE ntf_tokens (
provider TEXT NOT NULL, -- apns
device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
tkn_id BLOB, -- token ID assigned by notifications server
tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands (used by server, for repeat registraions)
tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key (for repeat registraions)
tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key (for repeat registraions)
tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
tkn_status TEXT NOT NULL,
tkn_action BLOB,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')), -- this is to check token status periodically to know when it was last checked
PRIMARY KEY (provider, device_token, ntf_host, ntf_port),
FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
|]
@@ -1,50 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220608_v2 :: Query
m20220608_v2 =
[sql|
ALTER TABLE messages ADD COLUMN msg_flags TEXT NULL;
ALTER TABLE conn_confirmations ADD COLUMN smp_reply_queues BLOB NULL;
ALTER TABLE connections ADD COLUMN duplex_handshake INTEGER NULL DEFAULT 0;
ALTER TABLE rcv_messages ADD COLUMN user_ack INTEGER NULL DEFAULT 0;
ALTER TABLE rcv_queues ADD COLUMN ntf_public_key BLOB;
ALTER TABLE rcv_queues ADD COLUMN ntf_private_key BLOB;
ALTER TABLE rcv_queues ADD COLUMN ntf_id BLOB;
ALTER TABLE rcv_queues ADD COLUMN rcv_ntf_dh_secret BLOB;
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues (host, port, ntf_id);
CREATE TABLE ntf_subscriptions (
conn_id BLOB NOT NULL,
smp_host TEXT NULL,
smp_port TEXT NULL,
smp_ntf_id BLOB,
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_sub_id BLOB,
ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can (should) be not null in same record
ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command (state still should be updated)
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')),
PRIMARY KEY (conn_id),
FOREIGN KEY (smp_host, smp_port) REFERENCES servers (host, port)
ON DELETE SET NULL ON UPDATE CASCADE,
FOREIGN KEY (ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
|]
@@ -1,14 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220625_v2_ntf_mode :: Query
m20220625_v2_ntf_mode =
[sql|
ALTER TABLE ntf_tokens ADD COLUMN ntf_mode TEXT NULL;
DELETE FROM ntf_tokens;
|]
@@ -1,16 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220811_onion_hosts :: Query
m20220811_onion_hosts =
[sql|
ALTER TABLE conn_confirmations ADD COLUMN smp_client_version INTEGER;
UPDATE ntf_servers
SET ntf_host = 'ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion'
WHERE ntf_host = 'ntf2.simplex.im';
|]
@@ -1,12 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220817_connection_ntfs :: Query
m20220817_connection_ntfs =
[sql|
ALTER TABLE connections ADD COLUMN enable_ntfs INTEGER;
|]
@@ -1,23 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220905_commands :: Query
m20220905_commands =
[sql|
CREATE TABLE commands (
command_id INTEGER PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
host TEXT,
port TEXT,
corr_id BLOB NOT NULL,
command_tag BLOB NOT NULL,
command BLOB NOT NULL,
agent_version INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY (host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE
);
|]
@@ -1,208 +0,0 @@
CREATE TABLE migrations(
name TEXT NOT NULL,
ts TEXT NOT NULL,
PRIMARY KEY(name)
);
CREATE TABLE servers(
host TEXT NOT NULL,
port TEXT NOT NULL,
key_hash BLOB NOT NULL,
PRIMARY KEY(host, port)
) WITHOUT ROWID;
CREATE TABLE connections(
conn_id BLOB NOT NULL PRIMARY KEY,
conn_mode TEXT NOT NULL,
last_internal_msg_id INTEGER NOT NULL DEFAULT 0,
last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,
last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,
last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,
last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',
last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
smp_agent_version INTEGER NOT NULL DEFAULT 1
,
duplex_handshake INTEGER NULL DEFAULT 0,
enable_ntfs INTEGER
) WITHOUT ROWID;
CREATE TABLE rcv_queues(
host TEXT NOT NULL,
port TEXT NOT NULL,
rcv_id BLOB NOT NULL,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
rcv_private_key BLOB NOT NULL,
rcv_dh_secret BLOB NOT NULL,
e2e_priv_key BLOB NOT NULL,
e2e_dh_secret BLOB,
snd_id BLOB NOT NULL,
snd_key BLOB,
status TEXT NOT NULL,
smp_server_version INTEGER NOT NULL DEFAULT 1,
smp_client_version INTEGER,
ntf_public_key BLOB,
ntf_private_key BLOB,
ntf_id BLOB,
rcv_ntf_dh_secret BLOB,
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'',
msg_flags TEXT NULL,
PRIMARY KEY(conn_id, internal_id),
FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
FOREIGN KEY(conn_id, internal_snd_id) REFERENCES snd_messages
ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
) WITHOUT ROWID;
CREATE TABLE rcv_messages(
conn_id BLOB NOT NULL,
internal_rcv_id INTEGER NOT NULL,
internal_id INTEGER NOT NULL,
external_snd_id INTEGER NOT NULL,
broker_id BLOB NOT NULL,
broker_ts TEXT NOT NULL,
internal_hash BLOB NOT NULL,
external_prev_snd_hash BLOB NOT NULL,
integrity BLOB NOT NULL,
user_ack INTEGER NULL DEFAULT 0,
PRIMARY KEY(conn_id, internal_rcv_id),
FOREIGN KEY(conn_id, internal_id) REFERENCES messages
ON DELETE CASCADE
) WITHOUT ROWID;
CREATE TABLE snd_messages(
conn_id BLOB NOT NULL,
internal_snd_id INTEGER NOT NULL,
internal_id INTEGER NOT NULL,
internal_hash BLOB NOT NULL,
previous_msg_hash BLOB NOT NULL DEFAULT x'',
PRIMARY KEY(conn_id, internal_snd_id),
FOREIGN KEY(conn_id, internal_id) REFERENCES messages
ON DELETE CASCADE
) WITHOUT ROWID;
CREATE TABLE conn_confirmations(
confirmation_id BLOB NOT NULL PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
ratchet_state BLOB NOT NULL,
sender_conn_info BLOB NOT NULL,
accepted INTEGER NOT NULL,
own_conn_info BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
,
smp_reply_queues BLOB NULL,
smp_client_version INTEGER
) WITHOUT ROWID;
CREATE TABLE conn_invitations(
invitation_id BLOB NOT NULL PRIMARY KEY,
contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
cr_invitation BLOB NOT NULL,
recipient_conn_info BLOB NOT NULL,
accepted INTEGER NOT NULL DEFAULT 0,
own_conn_info BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
) WITHOUT ROWID;
CREATE TABLE ratchets(
conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections
ON DELETE CASCADE,
-- x3dh keys are not saved on the sending side(the side accepting the connection)
x3dh_priv_key_1 BLOB,
x3dh_priv_key_2 BLOB,
-- ratchet is initially empty on the receiving side(the side offering the connection)
ratchet_state BLOB,
e2e_version INTEGER NOT NULL DEFAULT 1
) WITHOUT ROWID;
CREATE TABLE skipped_messages(
skipped_message_id INTEGER PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES ratchets
ON DELETE CASCADE,
header_key BLOB NOT NULL,
msg_n INTEGER NOT NULL,
msg_key BLOB NOT NULL
);
CREATE TABLE ntf_servers(
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_key_hash BLOB NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
PRIMARY KEY(ntf_host, ntf_port)
) WITHOUT ROWID;
CREATE TABLE ntf_tokens(
provider TEXT NOT NULL, -- apns
device_token TEXT NOT NULL, -- ! this field is mislabeled and is actually saved as binary
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
tkn_id BLOB, -- token ID assigned by notifications server
tkn_pub_key BLOB NOT NULL, -- client's public key to verify token commands(used by server, for repeat registraions)
tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands
tkn_pub_dh_key BLOB NOT NULL, -- client's public DH key(for repeat registraions)
tkn_priv_dh_key BLOB NOT NULL, -- client's private DH key(for repeat registraions)
tkn_dh_secret BLOB, -- DH secret for e2e encryption of notifications
tkn_status TEXT NOT NULL,
tkn_action BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
ntf_mode TEXT NULL, -- this is to check token status periodically to know when it was last checked
PRIMARY KEY(provider, device_token, ntf_host, ntf_port),
FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
CREATE TABLE ntf_subscriptions(
conn_id BLOB NOT NULL,
smp_host TEXT NULL,
smp_port TEXT NULL,
smp_ntf_id BLOB,
ntf_host TEXT NOT NULL,
ntf_port TEXT NOT NULL,
ntf_sub_id BLOB,
ntf_sub_status TEXT NOT NULL, -- see NtfAgentSubStatus
ntf_sub_action TEXT, -- if there is an action required on this subscription: NtfSubNTFAction
ntf_sub_smp_action TEXT, -- action with SMP server: NtfSubSMPAction; only one of this and ntf_sub_action can(should) be not null in same record
ntf_sub_action_ts TEXT, -- the earliest time for the action, e.g. checks can be scheduled every X hours
updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
PRIMARY KEY(conn_id),
FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
ON DELETE SET NULL ON UPDATE CASCADE,
FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
ON DELETE RESTRICT ON UPDATE CASCADE
) WITHOUT ROWID;
CREATE TABLE commands(
command_id INTEGER PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
host TEXT,
port TEXT,
corr_id BLOB NOT NULL,
command_tag BLOB NOT NULL,
command BLOB NOT NULL,
agent_version INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE
);
+177 -360
View File
@@ -1,13 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -26,36 +23,25 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Client
( -- * Connect (disconnect) client to (from) SMP server
ProtocolClient (thVersion, sessionId, transportHost),
SMPClient,
getProtocolClient,
closeProtocolClient,
SMPClient (blockSize),
getSMPClient,
closeSMPClient,
-- * SMP protocol command functions
createSMPQueue,
subscribeSMPQueue,
subscribeSMPQueues,
getSMPMessage,
subscribeSMPQueueNotifications,
secureSMPQueue,
enableSMPQueueNotifications,
disableSMPQueueNotifications,
enableSMPQueuesNtfs,
disableSMPQueuesNtfs,
sendSMPMessage,
ackSMPMessage,
suspendSMPQueue,
deleteSMPQueue,
sendProtocolCommand,
sendSMPCommand,
-- * Supporting types and client configuration
ProtocolClientError (..),
ProtocolClientConfig (..),
NetworkConfig (..),
defaultClientConfig,
defaultNetworkConfig,
chooseTransportHost,
ServerTransmission,
SMPClientError (..),
SMPClientConfig (..),
smpDefaultConfig,
SMPServerTransmission,
)
where
@@ -64,183 +50,104 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (rights)
import Data.Functor (($>))
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Network.Socket (ServiceName)
import Numeric.Natural
import Simplex.Messaging.Agent.Protocol (SMPServer (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
import Simplex.Messaging.Version
import System.Timeout (timeout)
-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- The only exported selector is blockSize that is negotiated
-- with the server during the TCP transport handshake.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient msg = ProtocolClient
data SMPClient = SMPClient
{ action :: Async (),
connected :: TVar Bool,
sessionId :: SessionId,
thVersion :: Version,
protocolServer :: ProtoServer msg,
transportHost :: TransportHost,
smpServer :: SMPServer,
tcpTimeout :: Int,
clientCorrId :: TVar Natural,
sentCommands :: TMap CorrId (Request msg),
sndQ :: TBQueue (NonEmpty SentRawTransmission),
rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
msgQ :: Maybe (TBQueue (ServerTransmission msg))
sentCommands :: TVar (Map CorrId Request),
sndQ :: TBQueue SignedRawTransmission,
rcvQ :: TBQueue SignedTransmissionOrError,
msgQ :: TBQueue SMPServerTransmission,
blockSize :: Int
}
type SMPClient = ProtocolClient SMP.BrokerMsg
-- | Type for client command data
type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker)
data HostMode
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
HMOnionViaSocks
| -- | prefer (or require) onion hosts
HMOnion
| -- | prefer (or require) public hosts
HMPublic
deriving (Eq, Show, Generic)
instance FromJSON HostMode where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
instance ToJSON HostMode where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
-- | network configuration for the client
data NetworkConfig = NetworkConfig
{ -- | use SOCKS5 proxy
socksProxy :: Maybe SocksProxy,
-- | determines critera which host is chosen from the list
hostMode :: HostMode,
-- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
requiredHostMode :: Bool,
-- | timeout for the initial client TCP/TLS connection (microseconds)
tcpConnectTimeout :: Int,
-- | timeout of protocol commands (microseconds)
tcpTimeout :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds)
smpPingInterval :: Int
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON NetworkConfig where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig =
NetworkConfig
{ socksProxy = Nothing,
hostMode = HMOnionViaSocks,
requiredHostMode = False,
tcpConnectTimeout = 7_500_000,
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPingInterval = 600_000_000 -- 10min
}
-- | protocol client configuration.
data ProtocolClientConfig = ProtocolClientConfig
-- | SMP client configuration.
data SMPClientConfig = SMPClientConfig
{ -- | size of TBQueue to use for server commands and responses
qSize :: Natural,
-- | default server port if port is not specified in ProtocolServer
-- | default SMP server port if port is not specified in SMPServer
defaultTransport :: (ServiceName, ATransport),
-- | network configuration
networkConfig :: NetworkConfig,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
-- | timeout of TCP commands (microseconds)
tcpTimeout :: Int,
-- | period for SMP ping commands (microseconds)
smpPing :: Int,
-- | 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
}
-- | Default protocol client configuration.
defaultClientConfig :: ProtocolClientConfig
defaultClientConfig =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
smpServerVRange = supportedSMPServerVRange
-- | Default SMP client configuration.
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig =
SMPClientConfig
{ qSize = 16,
defaultTransport = ("5223", transport @TCP),
tcpTimeout = 4_000_000,
smpPing = 30_000_000,
smpBlockSize = Just 8192,
smpCommandSize = 256
}
data Request msg = Request
data Request = Request
{ queueId :: QueueId,
responseVar :: TMVar (Response msg)
responseVar :: TMVar Response
}
type Response msg = Either ProtocolClientError msg
type Response = Either SMPClientError Cmd
chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
firstOrError $ case hostMode of
HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
HMOnion -> onionHost
HMPublic -> publicHost
where
firstOrError
| requiredHostMode = maybe (Left PCEIncompatibleHost) Right
| otherwise = Right . fromMaybe (L.head hosts)
isOnionHost = \case THOnionHost _ -> True; _ -> False
onionHost = find isOnionHost hosts
publicHost = find (not . isOnionHost) hosts
-- | Connects to 'ProtocolServer' using passed client configuration
-- | Connects to 'SMPServer' using passed client configuration
-- and queue for messages and notifications.
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
case chooseTransportHost networkConfig (host protocolServer) of
Right useHost ->
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlockSize} msgQ disconnected =
atomically mkSMPClient >>= runClient useTransport
where
NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> STM (ProtocolClient msg)
mkProtocolClient transportHost = do
mkSMPClient :: STM SMPClient
mkSMPClient = do
connected <- newTVar False
clientCorrId <- newTVar 0
sentCommands <- TM.empty
sentCommands <- newTVar M.empty
sndQ <- newTBQueue qSize
rcvQ <- newTBQueue qSize
return
ProtocolClient
SMPClient
{ action = undefined,
sessionId = undefined,
thVersion = undefined,
blockSize = undefined,
connected,
protocolServer,
transportHost,
smpServer,
tcpTimeout,
clientCorrId,
sentCommands,
@@ -249,108 +156,100 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
msgQ
}
runClient :: (ServiceName, ATransport) -> TransportHost -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
runClient (port', ATransport t) useHost c = do
runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
runClient (port', ATransport t) c = do
thVar <- newEmptyTMVarIO
action <-
async $
runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
`finally` atomically (putTMVar thVar $ Left PCENetworkError)
th_ <- tcpConnectTimeout `timeout` atomically (takeTMVar thVar)
pure $ case th_ of
Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
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}
Just (Left e) -> Left e
Nothing -> Left PCENetworkError
Nothing -> Left SMPNetworkError
useTransport :: (ServiceName, ATransport)
useTransport = case port protocolServer of
"" -> defaultTransport cfg
"80" -> ("80", transport @WS)
p -> (p, transport @TLS)
useTransport = case port smpServer of
Nothing -> defaultTransport cfg
Just "80" -> ("80", transport @WS)
Just p -> (p, transport @TCP)
client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
client _ c thVar h =
runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
Right th@THandle {sessionId, thVersion} -> do
runExceptT (clientHandshake h smpBlockSize $ keyHash smpServer) >>= \case
Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
Right th -> do
atomically $ do
writeTVar (connected c) True
putTMVar thVar $ Right th
let c' = c {sessionId, thVersion} :: ProtocolClient msg
-- TODO remove ping if 0 is passed (or Nothing?)
raceAny_ [send c' th, process c', receive c' th, ping c']
`finally` disconnected c'
putTMVar thVar . Right $ blockSize (th :: THandle c)
raceAny_ [send c th, process c, receive c th, ping c]
`finally` disconnected
send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
send :: Transport c => SMPClient -> THandle c -> IO ()
send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
receive :: Transport c => SMPClient -> THandle c -> IO ()
receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ
ping :: ProtocolClient msg -> IO ()
ping :: SMPClient -> IO ()
ping c = forever $ do
threadDelay smpPingInterval
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
threadDelay smpPing
runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING)
process :: ProtocolClient msg -> IO ()
process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
process :: SMPClient -> IO ()
process SMPClient {rcvQ, sentCommands} = forever $ do
(_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
if B.null $ bs corrId
then sendMsg respOrErr
then sendMsg qId respOrErr
else do
atomically (TM.lookup corrId sentCommands) >>= \case
Nothing -> sendMsg respOrErr
cs <- readTVarIO sentCommands
case M.lookup corrId cs of
Nothing -> sendMsg qId respOrErr
Just Request {queueId, responseVar} -> atomically $ do
TM.delete corrId sentCommands
modifyTVar sentCommands $ M.delete corrId
putTMVar responseVar $
if queueId == qId
then case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
else Left . PCEUnexpectedResponse $ bshow respOrErr
where
sendMsg :: Either ErrorType msg -> IO ()
sendMsg = \case
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
-- TODO send everything else to errQ and log in agent
_ -> return ()
Left e -> Left $ SMPResponseError e
Right (Cmd _ (ERR e)) -> Left $ SMPServerError e
Right r -> Right r
else Left SMPUnexpectedResponse
-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient msg -> IO ()
closeProtocolClient = uninterruptibleCancel . action
sendMsg :: QueueId -> Either ErrorType 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
-- | SMP client error type.
data ProtocolClientError
data SMPClientError
= -- | Correctly parsed SMP server ERR response.
-- This error is forwarded to the agent client as `ERR SMP err`.
PCEProtocolError ErrorType
SMPServerError ErrorType
| -- | Invalid server response that failed to parse.
-- Forwarded to the agent client as `ERR BROKER RESPONSE`.
PCEResponseError ErrorType
SMPResponseError ErrorType
| -- | Different response from what is expected to a certain SMP command,
-- e.g. server should respond `IDS` or `ERR` to `NEW` command,
-- other responses would result in this error.
-- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
PCEUnexpectedResponse ByteString
SMPUnexpectedResponse
| -- | Used for TCP connection and command response timeouts.
-- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
PCEResponseTimeout
SMPResponseTimeout
| -- | Failure to establish TCP connection.
-- Forwarded to the agent client as `ERR BROKER NETWORK`.
PCENetworkError
| -- | No host compatible with network configuration
PCEIncompatibleHost
SMPNetworkError
| -- | TCP transport handshake or some other transport error.
-- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
PCETransportError TransportError
SMPTransportError TransportError
| -- | Error when cryptographically "signing" the command.
PCESignatureError C.CryptoError
| -- | IO Error
PCEIOError IOException
SMPSignatureError C.CryptoError
deriving (Eq, Show, Exception)
-- | Create a new SMP queue.
@@ -358,184 +257,102 @@ data ProtocolClientError
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
createSMPQueue ::
SMPClient ->
RcvPrivateSignKey ->
RcvPublicVerifyKey ->
RcvPublicDhKey ->
ExceptT ProtocolClientError IO QueueIdsKeys
createSMPQueue c rpKey rKey dhKey =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
IDS qik -> pure qik
r -> throwE . PCEUnexpectedResponse $ bshow r
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
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
subscribeSMPQueue c rpKey rId =
sendSMPCommand c (Just rpKey) rId SUB >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to multiple SMP queues batching commands if supported.
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
where
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
response ((_, rId), r) = case r of
Right OK -> pure $ Right ()
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
Left e -> pure $ Left e
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
(protocolServer, thVersion, sessionId, entityId, message)
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
getSMPMessage c rpKey rId =
sendSMPCommand c (Just rpKey) rId GET >>= \case
OK -> pure Nothing
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | 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
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
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Enable notifications for the multiple queues for push notifications server.
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
where
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
response = \case
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
Right r -> Left . PCEUnexpectedResponse $ bshow r
Left e -> Left e
-- | Disable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
disableSMPQueueNotifications = okSMPCommand NDEL
-- | Disable notifications for multiple queues for push notifications server.
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
where
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
response = \case
Right OK -> Right ()
Right r -> Left . PCEUnexpectedResponse $ bshow r
Left e -> Left e
secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId
-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT ProtocolClientError IO ()
sendSMPMessage c spKey sId flags msg =
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
OK -> pure ()
r -> throwE . PCEUnexpectedResponse $ bshow r
sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage c spKey sId msg =
sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case
Cmd _ OK -> return ()
_ -> throwE SMPUnexpectedResponse
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
ackSMPMessage c rpKey rId msgId =
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE . PCEUnexpectedResponse $ bshow r
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
-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
suspendSMPQueue = okSMPCommand OFF
suspendSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF
-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
deleteSMPQueue = okSMPCommand DEL
deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
OK -> return ()
r -> throwE . PCEUnexpectedResponse $ bshow r
Cmd _ OK -> return ()
_ -> throwE SMPUnexpectedResponse
-- | Send SMP command
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
-- | Send multiple commands with batching and collect responses
sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
ts <- mapM (runExceptT . mkTransmission c) cs
mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
forConcurrently ts $ \case
Right (_, r) -> withTimeout . atomically $ takeTMVar r
Left e -> pure $ Left e
-- | 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
corrId <- lift_ getNextCorrId
t <- signTransmission $ serializeTransmission (corrId, qId, cmd)
ExceptT $ sendRecv corrId t
where
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
lift_ :: STM a -> ExceptT SMPClientError IO a
lift_ action = ExceptT $ Right <$> atomically action
-- | Send Protocol command
sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
(t, r) <- mkTransmission c (pKey, qId, cmd)
ExceptT $ sendRecv t r
where
-- two separate "atomically" needed to avoid blocking
sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
where
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands} (pKey, qId, cmd) = do
corrId <- liftIO $ atomically getNextCorrId
t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
r <- liftIO . atomically $ mkRequest corrId
pure (t, r)
where
getNextCorrId :: STM CorrId
getNextCorrId = do
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
pure . CorrId $ bshow i
signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
signTransmission t = case pKey of
Nothing -> pure (Nothing, t)
Nothing -> return ("", t)
Just pk -> do
sig <- liftError PCESignatureError $ C.sign pk t
return (Just sig, t)
mkRequest :: CorrId -> STM (TMVar (Response msg))
mkRequest corrId = do
sig <- liftError SMPSignatureError $ C.sign pk t
return (sig, t)
-- two separate "atomically" needed to avoid blocking
sendRecv :: CorrId -> SignedRawTransmission -> IO Response
sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
where
withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
send corrId t = do
r <- newEmptyTMVar
TM.insert corrId (Request qId r) sentCommands
pure r
modifyTVar sentCommands . M.insert corrId $ Request qId r
writeTBQueue sndQ t
return r
-304
View File
@@ -1,304 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Client.Agent where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import Data.Text.Encoding
import Numeric.Natural
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async, forConcurrently_)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type SMPClientVar = TMVar (Either ProtocolClientError SMPClient)
data SMPClientAgentEvent
= CAConnected SMPServer
| CADisconnected SMPServer (Set SMPSub)
| CAReconnected SMPServer
| CAResubscribed SMPServer SMPSub
| CASubError SMPServer SMPSub ProtocolClientError
data SMPSubParty = SPRecipient | SPNotifier
deriving (Eq, Ord, Show)
type SMPSub = (SMPSubParty, QueueId)
-- type SMPServerSub = (SMPServer, SMPSub)
data SMPClientAgentConfig = SMPClientAgentConfig
{ smpCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
msgQSize :: Natural,
agentQSize :: Natural
}
defaultSMPClientAgentConfig :: SMPClientAgentConfig
defaultSMPClientAgentConfig =
SMPClientAgentConfig
{ smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
reconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
},
msgQSize = 64,
agentQSize = 64
}
where
second = 1000000
data SMPClientAgent = SMPClientAgent
{ agentCfg :: SMPClientAgentConfig,
msgQ :: TBQueue (ServerTransmission BrokerMsg),
agentQ :: TBQueue SMPClientAgentEvent,
smpClients :: TMap SMPServer SMPClientVar,
srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
reconnections :: TVar [Async ()],
asyncClients :: TVar [Async ()]
}
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
withRunInIO exceptToIO =
withExceptT unInternalException . ExceptT . E.try $
withRunInIO $ \run ->
exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
msgQ <- newTBQueue msgQSize
agentQ <- newTBQueue agentQSize
smpClients <- TM.empty
srvSubs <- TM.empty
pendingSrvSubs <- TM.empty
reconnections <- newTVar []
asyncClients <- newTVar []
pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT ProtocolClientError IO SMPClient
getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
atomically getClientVar >>= either newSMPClient waitForSMPClient
where
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
newClientVar :: STM SMPClientVar
newClientVar = do
smpVar <- newEmptyTMVar
TM.insert srv smpVar smpClients
pure smpVar
waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
waitForSMPClient smpVar = do
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left PCEResponseTimeout
newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
tryConnectClient successAction retryAction =
tryE connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
successAction smp
Left e -> do
if e == PCENetworkError || e == PCEResponseTimeout
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
TM.delete srv smpClients
throwE e
tryConnectAsync :: ExceptT ProtocolClientError IO ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients ca) (a :)
connectAsync :: ExceptT ProtocolClientError IO ()
connectAsync =
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
void $ tryConnectClient (const reconnectClient) loop
connectClient :: ExceptT ProtocolClientError IO SMPClient
connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
clientDisconnected :: SMPClient -> IO ()
clientDisconnected _ = do
removeClientAndSubs >>= (`forM_` serverDown)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
where
updateSubs sVar = do
ss <- readTVar sVar
addPendingSubs sVar ss
pure ss
addPendingSubs sVar ss = do
let ps = pendingSrvSubs ca
TM.lookup srv ps >>= \case
Just v -> TM.union ss v
_ -> TM.insert srv sVar ps
serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
serverDown ss = unless (M.null ss) . void . runExceptT $ do
notify . CADisconnected srv $ M.keysSet ss
reconnectServer
reconnectServer :: ExceptT ProtocolClientError IO ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections ca) (a :)
tryReconnectClient :: ExceptT ProtocolClientError IO ()
tryReconnectClient = do
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
reconnectClient `catchE` const loop
reconnectClient :: ExceptT ProtocolClientError IO ()
reconnectClient = do
withSMP ca srv $ \smp -> do
notify $ CAReconnected srv
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
unlessM (atomically $ hasSub (srvSubs ca) srv s) $
subscribe_ smp sub `catchE` handleError s
where
subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
subscribe_ smp sub@(s, _) = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
notify $ CAResubscribed srv s
handleError :: SMPSub -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
handleError s = \case
e@PCEResponseTimeout -> throwE e
e@PCENetworkError -> throwE e
e -> do
notify $ CASubError srv s e
atomically $ removePendingSubscription ca srv s
notify :: SMPClientAgentEvent -> ExceptT ProtocolClientError IO ()
notify evt = atomically $ writeTBQueue (agentQ ca) evt
closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
closeSMPClientAgent c = liftIO $ do
closeSMPServerClients c
cancelActions $ reconnections c
cancelActions $ asyncClients c
closeSMPServerClients :: SMPClientAgent -> IO ()
closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
where
closeClient smpVar =
atomically (readTMVar smpVar) >>= \case
Right smp -> closeProtocolClient smp `catchAll_` pure ()
_ -> pure ()
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO a
withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
where
logSMPError :: ProtocolClientError -> ExceptT ProtocolClientError IO a
logSMPError e = do
liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
throwE e
subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
subscribeQueue ca srv sub = do
atomically $ addPendingSubscription ca srv sub
withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
where
subscribe_ smp = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
handleError e = do
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv $ fst sub
throwE e
showServer :: SMPServer -> ByteString
showServer ProtocolServer {host, port} =
strEncode host <> B.pack (if null port then "" else ':' : port)
smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
where
subscribe_ = case party of
SPRecipient -> subscribeSMPQueue
SPNotifier -> subscribeSMPQueueNotifications
addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSubscription ca srv sub = do
addSub_ (srvSubs ca) srv sub
removePendingSubscription ca srv $ fst sub
addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addPendingSubscription = addSub_ . pendingSrvSubs
addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSub_ subs srv (s, key) =
TM.lookup srv subs >>= \case
Just m -> TM.insert s key m
_ -> TM.singleton s key >>= \v -> TM.insert srv v subs
removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removeSubscription = removeSub_ . srvSubs
removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removePendingSubscription = removeSub_ . pendingSrvSubs
removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs
File diff suppressed because it is too large Load Diff
-489
View File
@@ -1,489 +0,0 @@
{-# 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 + 1 = Left CERatchetEarlierMessage
| rcNr == untilN + 1 = 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
-206
View File
@@ -1,206 +0,0 @@
{-# 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,
lenEncode,
)
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
{-# INLINE smpEncode #-}
smpP = A.anyChar
{-# INLINE smpP #-}
instance Encoding Bool where
smpEncode = \case
True -> "T"
False -> "F"
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
'T' -> pure True
'F' -> pure False
_ -> fail "invalid Bool"
{-# INLINE smpP #-}
instance Encoding Word16 where
smpEncode = encodeWord16
{-# INLINE smpEncode #-}
smpP = decodeWord16 <$> A.take 2
{-# INLINE smpP #-}
instance Encoding Word32 where
smpEncode = encodeWord32
{-# INLINE smpEncode #-}
smpP = decodeWord32 <$> A.take 4
{-# INLINE smpP #-}
instance Encoding Int64 where
smpEncode i = w32 (i `shiftR` 32) <> w32 i
{-# INLINE smpEncode #-}
smpP = do
l <- w32P
r <- w32P
pure $ (l `shiftL` 32) .|. r
{-# INLINE smpP #-}
w32 :: Int64 -> ByteString
w32 = smpEncode @Word32 . fromIntegral
{-# INLINE w32 #-}
w32P :: Parser Int64
w32P = fromIntegral <$> smpP @Word32
{-# INLINE w32P #-}
-- ByteStrings are assumed no longer than 255 bytes
instance Encoding ByteString where
smpEncode s = B.cons (lenEncode $ B.length s) s
{-# INLINE smpEncode #-}
smpP = A.take =<< lenP
{-# INLINE smpP #-}
lenEncode :: Int -> Char
lenEncode = w2c . fromIntegral
{-# INLINE lenEncode #-}
lenP :: Parser Int
lenP = fromIntegral . c2w <$> A.anyChar
{-# INLINE lenP #-}
instance Encoding a => Encoding (Maybe a) where
smpEncode s = maybe "0" (("1" <>) . smpEncode) s
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
'0' -> pure Nothing
'1' -> Just <$> smpP
_ -> fail "invalid Maybe tag"
{-# INLINE smpP #-}
newtype Tail = Tail {unTail :: ByteString}
instance Encoding Tail where
smpEncode = unTail
{-# INLINE smpEncode #-}
smpP = Tail <$> A.takeByteString
{-# INLINE smpP #-}
-- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix
newtype Large = Large {unLarge :: ByteString}
instance Encoding Large where
smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s
{-# INLINE smpEncode #-}
smpP = do
len <- fromIntegral <$> smpP @Word16
Large <$> A.take len
{-# INLINE smpP #-}
instance Encoding SystemTime where
smpEncode = smpEncode . systemSeconds
{-# INLINE smpEncode #-}
smpP = MkSystemTime <$> smpP <*> pure 0
{-# INLINE smpP #-}
-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
smpEncodeList :: Encoding a => [a] -> ByteString
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
{-# INLINE smpEncode #-}
smpP = B.unpack <$> smpP
{-# INLINE 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
{-# INLINE smpEncode #-}
smpP = (,) <$> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
{-# INLINE smpEncode #-}
smpP = (,,) <$> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d
{-# INLINE smpEncode #-}
smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
{-# INLINE smpEncode #-}
smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
{-# INLINE smpEncode #-}
smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
smpEncode (a, b, c, d, e, f, g) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g
{-# INLINE smpEncode #-}
smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
{-# INLINE smpEncode #-}
smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
-181
View File
@@ -1,181 +0,0 @@
{-# 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.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime (..))
import Data.Time.Format.ISO8601
import Data.Word (Word16)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util ((<$?>))
class TextEncoding a where
textEncode :: a -> Text
textDecode :: Text -> Maybe a
-- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols
class StrEncoding a where
{-# MINIMAL strEncode, (strDecode | strP) #-}
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
{-# INLINE strEncode #-}
strP = optional strP
{-# INLINE strP #-}
instance StrEncoding Word16 where
strEncode = B.pack . show
{-# INLINE strEncode #-}
strP = A.decimal
{-# INLINE strP #-}
instance StrEncoding Char where
strEncode = smpEncode
{-# INLINE strEncode #-}
strP = strP
{-# INLINE strP #-}
instance StrEncoding Bool where
strEncode = smpEncode
{-# INLINE strEncode #-}
strP = smpP
{-# INLINE strP #-}
instance StrEncoding Int where
strEncode = B.pack . show
{-# INLINE strEncode #-}
strP = A.decimal
{-# INLINE strP #-}
instance StrEncoding Int64 where
strEncode = B.pack . show
{-# INLINE strEncode #-}
strP = A.decimal
{-# INLINE strP #-}
instance StrEncoding SystemTime where
strEncode = strEncode . systemSeconds
strP = MkSystemTime <$> strP <*> pure 0
instance StrEncoding UTCTime where
strEncode = B.pack . iso8601Show
strP = maybe (Left "bad UTCTime") Right . iso8601ParseM . B.unpack <$?> A.takeTill (\c -> c == ' ' || c == '\n')
-- lists encode/parse as comma-separated strings
strEncodeList :: StrEncoding a => [a] -> ByteString
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 ','
instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
strEncode = strEncodeList . S.toList
strP = S.fromList <$> listItem `A.sepBy'` A.char ','
listItem :: StrEncoding a => Parser a
listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
strEncode (a, b) = B.unwords [strEncode a, strEncode b]
{-# INLINE strEncode #-}
strP = (,) <$> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c) => StrEncoding (a, b, c) where
strEncode (a, b, c) = B.unwords [strEncode a, strEncode b, strEncode c]
{-# INLINE strEncode #-}
strP = (,,) <$> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d) => StrEncoding (a, b, c, d) where
strEncode (a, b, c, d) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d]
{-# INLINE strEncode #-}
strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e) => StrEncoding (a, b, c, d, e) where
strEncode (a, b, c, d, e) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e]
{-# INLINE strEncode #-}
strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
strP_ :: StrEncoding a => Parser a
strP_ = strP <* A.space
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
@@ -1,64 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Notifications.Client where
import Control.Monad.Except
import Control.Monad.Trans.Except
import Data.Word (Word16)
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Util (bshow)
type NtfClient = ProtocolClient NtfResponse
ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c pKey newTkn =
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
NRTknId tknId dhKey -> pure (tknId, dhKey)
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
ntfCheckToken c pKey tknId =
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
NRTkn stat -> pure stat
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT ProtocolClientError IO ()
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
ntfDeleteToken = okNtfCommand TDEL
ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO NtfSubscriptionId
ntfCreateSubscription c pKey newSub =
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
NRSubId subId -> pure subId
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
ntfCheckSubscription c pKey subId =
sendNtfCommand c (Just pKey) subId SCHK >>= \case
NRSub stat -> pure stat
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
ntfDeleteSubscription = okNtfCommand SDEL
-- | Send notification server command
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
okNtfCommand cmd c pKey entId =
sendNtfCommand c (Just pKey) entId cmd >>= \case
NROk -> return ()
r -> throwE . PCEUnexpectedResponse $ bshow r
@@ -1,507 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Simplex.Messaging.Notifications.Protocol where
import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Kind
import Data.Maybe (isNothing)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Type.Equality
import Data.Word (Word16)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
import Simplex.Messaging.Parsers (fromTextField_)
import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
data NtfEntity = Token | Subscription
deriving (Show)
data SNtfEntity :: NtfEntity -> Type where
SToken :: SNtfEntity 'Token
SSubscription :: SNtfEntity 'Subscription
instance TestEquality SNtfEntity where
testEquality SToken SToken = Just Refl
testEquality SSubscription SSubscription = Just Refl
testEquality _ _ = Nothing
deriving instance Show (SNtfEntity e)
class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e
instance NtfEntityI 'Token where sNtfEntity = SToken
instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
data NtfCommandTag (e :: NtfEntity) where
TNEW_ :: NtfCommandTag 'Token
TVFY_ :: NtfCommandTag 'Token
TCHK_ :: NtfCommandTag 'Token
TRPL_ :: NtfCommandTag 'Token
TDEL_ :: NtfCommandTag 'Token
TCRN_ :: NtfCommandTag 'Token
SNEW_ :: NtfCommandTag 'Subscription
SCHK_ :: NtfCommandTag 'Subscription
SDEL_ :: NtfCommandTag 'Subscription
PING_ :: NtfCommandTag 'Subscription
deriving instance Show (NtfCommandTag e)
data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)
instance NtfEntityI e => Encoding (NtfCommandTag e) where
smpEncode = \case
TNEW_ -> "TNEW"
TVFY_ -> "TVFY"
TCHK_ -> "TCHK"
TRPL_ -> "TRPL"
TDEL_ -> "TDEL"
TCRN_ -> "TCRN"
SNEW_ -> "SNEW"
SCHK_ -> "SCHK"
SDEL_ -> "SDEL"
PING_ -> "PING"
smpP = messageTagP
instance Encoding NtfCmdTag where
smpEncode (NCT _ t) = smpEncode t
smpP = messageTagP
instance ProtocolMsgTag NtfCmdTag where
decodeTag = \case
"TNEW" -> Just $ NCT SToken TNEW_
"TVFY" -> Just $ NCT SToken TVFY_
"TCHK" -> Just $ NCT SToken TCHK_
"TRPL" -> Just $ NCT SToken TRPL_
"TDEL" -> Just $ NCT SToken TDEL_
"TCRN" -> Just $ NCT SToken TCRN_
"SNEW" -> Just $ NCT SSubscription SNEW_
"SCHK" -> Just $ NCT SSubscription SCHK_
"SDEL" -> Just $ NCT SSubscription SDEL_
"PING" -> Just $ NCT SSubscription PING_
_ -> Nothing
instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
newtype NtfRegCode = NtfRegCode ByteString
deriving (Eq, Show)
instance Encoding NtfRegCode where
smpEncode (NtfRegCode code) = smpEncode code
smpP = NtfRegCode <$> smpP
instance StrEncoding NtfRegCode where
strEncode (NtfRegCode m) = strEncode m
strDecode s = NtfRegCode <$> strDecode s
strP = NtfRegCode <$> strP
instance FromJSON NtfRegCode where
parseJSON = strParseJSON "NtfRegCode"
instance ToJSON NtfRegCode where
toJSON = strToJSON
toEncoding = strToJEncoding
data NewNtfEntity (e :: NtfEntity) where
NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription
deriving instance Show (NewNtfEntity e)
data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
deriving instance Show ANewNtfEntity
instance NtfEntityI e => Encoding (NewNtfEntity e) where
smpEncode = \case
NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
NewNtfSub tknId smpQueue notifierKey -> smpEncode ('S', tknId, smpQueue, notifierKey)
smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
instance Encoding ANewNtfEntity where
smpEncode (ANE _ e) = smpEncode e
smpP =
A.anyChar >>= \case
'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP <*> smpP)
_ -> fail "bad ANewNtfEntity"
instance Protocol NtfResponse where
type ProtoCommand NtfResponse = NtfCmd
type ProtoType NtfResponse = 'PNTF
protocolClientHandshake = ntfClientHandshake
protocolPing = NtfCmd SSubscription PING
protocolError = \case
NRErr e -> Just e
_ -> Nothing
data NtfCommand (e :: NtfEntity) where
-- | register new device token for notifications
TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
-- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
TVFY :: NtfRegCode -> NtfCommand 'Token
-- | check token status
TCHK :: NtfCommand 'Token
-- | replace device token (while keeping all existing subscriptions)
TRPL :: DeviceToken -> NtfCommand 'Token
-- | delete token - all subscriptions will be removed and no more notifications will be sent
TDEL :: NtfCommand 'Token
-- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
TCRN :: Word16 -> NtfCommand 'Token
-- | create SMP subscription
SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
-- | check SMP subscription status (response is SUB)
SCHK :: NtfCommand 'Subscription
-- | delete SMP subscription
SDEL :: NtfCommand 'Subscription
-- | keep-alive command
PING :: NtfCommand 'Subscription
deriving instance Show (NtfCommand e)
data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
deriving instance Show NtfCmd
instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
type Tag (NtfCommand e) = NtfCommandTag e
encodeProtocol _v = \case
TNEW newTkn -> e (TNEW_, ' ', newTkn)
TVFY code -> e (TVFY_, ' ', code)
TCHK -> e TCHK_
TRPL tkn -> e (TRPL_, ' ', tkn)
TDEL -> e TDEL_
TCRN int -> e (TCRN_, ' ', int)
SNEW newSub -> e (SNEW_, ' ', newSub)
SCHK -> e SCHK_
SDEL -> e SDEL_
PING -> e PING_
where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
checkCredentials (sig, _, entityId, _) cmd = case cmd of
-- TNEW and SNEW must have signature but NOT token/subscription IDs
TNEW {} -> sigNoEntity
SNEW {} -> sigNoEntity
PING
| isNothing sig && B.null entityId -> Right cmd
| otherwise -> Left $ CMD HAS_AUTH
-- other client commands must have both signature and entity ID
_
| isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
where
sigNoEntity
| isNothing sig = Left $ CMD NO_AUTH
| not (B.null entityId) = Left $ CMD HAS_AUTH
| otherwise = Right cmd
instance ProtocolEncoding NtfCmd where
type Tag NtfCmd = NtfCmdTag
encodeProtocol _v (NtfCmd _ c) = encodeProtocol _v c
protocolP _v = \case
NCT SToken tag ->
NtfCmd SToken <$> case tag of
TNEW_ -> TNEW <$> _smpP
TVFY_ -> TVFY <$> _smpP
TCHK_ -> pure TCHK
TRPL_ -> TRPL <$> _smpP
TDEL_ -> pure TDEL
TCRN_ -> TCRN <$> _smpP
NCT SSubscription tag ->
NtfCmd SSubscription <$> case tag of
SNEW_ -> SNEW <$> _smpP
SCHK_ -> pure SCHK
SDEL_ -> pure SDEL
PING_ -> pure PING
checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
data NtfResponseTag
= NRTknId_
| NRSubId_
| NROk_
| NRErr_
| NRTkn_
| NRSub_
| NRPong_
deriving (Show)
instance Encoding NtfResponseTag where
smpEncode = \case
NRTknId_ -> "IDTKN" -- it should be "TID", "SID"
NRSubId_ -> "IDSUB"
NROk_ -> "OK"
NRErr_ -> "ERR"
NRTkn_ -> "TKN"
NRSub_ -> "SUB"
NRPong_ -> "PONG"
smpP = messageTagP
instance ProtocolMsgTag NtfResponseTag where
decodeTag = \case
"IDTKN" -> Just NRTknId_
"IDSUB" -> Just NRSubId_
"OK" -> Just NROk_
"ERR" -> Just NRErr_
"TKN" -> Just NRTkn_
"SUB" -> Just NRSub_
"PONG" -> Just NRPong_
_ -> Nothing
data NtfResponse
= NRTknId NtfEntityId C.PublicKeyX25519
| NRSubId NtfEntityId
| NROk
| NRErr ErrorType
| NRTkn NtfTknStatus
| NRSub NtfSubStatus
| NRPong
deriving (Show)
instance ProtocolEncoding NtfResponse where
type Tag NtfResponse = NtfResponseTag
encodeProtocol _v = \case
NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
NRSubId entId -> e (NRSubId_, ' ', entId)
NROk -> e NROk_
NRErr err -> e (NRErr_, ' ', err)
NRTkn stat -> e (NRTkn_, ' ', stat)
NRSub stat -> e (NRSub_, ' ', stat)
NRPong -> e NRPong_
where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP _v = \case
NRTknId_ -> NRTknId <$> _smpP <*> smpP
NRSubId_ -> NRSubId <$> _smpP
NROk_ -> pure NROk
NRErr_ -> NRErr <$> _smpP
NRTkn_ -> NRTkn <$> _smpP
NRSub_ -> NRSub <$> _smpP
NRPong_ -> pure NRPong
checkCredentials (_, _, entId, _) cmd = case cmd of
-- IDTKN response must not have queue ID
NRTknId {} -> noEntity
-- IDSUB response must not have queue ID
NRSubId {} -> noEntity
-- ERR response does not always have entity ID
NRErr _ -> Right cmd
-- PONG response must not have queue ID
NRPong -> noEntity
-- other server responses must have entity ID
_
| B.null entId -> Left $ CMD NO_ENTITY
| otherwise -> Right cmd
where
noEntity
| B.null entId = Right cmd
| otherwise = Left $ CMD HAS_AUTH
data SMPQueueNtf = SMPQueueNtf
{ smpServer :: SMPServer,
notifierId :: NotifierId
}
deriving (Eq, Ord, Show)
instance Encoding SMPQueueNtf where
smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
smpP = do
smpServer <- updateSMPServerHosts <$> smpP
notifierId <- smpP
pure SMPQueueNtf {smpServer, notifierId}
instance StrEncoding SMPQueueNtf where
strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
strP = do
smpServer <- updateSMPServerHosts <$> strP
notifierId <- A.char '/' *> strP
pure SMPQueueNtf {smpServer, notifierId}
data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
deriving (Eq, Ord, Show)
instance Encoding PushProvider where
smpEncode = \case
PPApnsDev -> "AD"
PPApnsProd -> "AP"
PPApnsTest -> "AT"
smpP =
A.take 2 >>= \case
"AD" -> pure PPApnsDev
"AP" -> pure PPApnsProd
"AT" -> pure PPApnsTest
_ -> fail "bad PushProvider"
instance StrEncoding PushProvider where
strEncode = \case
PPApnsDev -> "apns_dev"
PPApnsProd -> "apns_prod"
PPApnsTest -> "apns_test"
strP =
A.takeTill (== ' ') >>= \case
"apns_dev" -> pure PPApnsDev
"apns_prod" -> pure PPApnsProd
"apns_test" -> pure PPApnsTest
_ -> fail "bad PushProvider"
instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
data DeviceToken = DeviceToken PushProvider ByteString
deriving (Eq, Ord, Show)
instance Encoding DeviceToken where
smpEncode (DeviceToken p t) = smpEncode (p, t)
smpP = DeviceToken <$> smpP <*> smpP
instance StrEncoding DeviceToken where
strEncode (DeviceToken p t) = strEncode p <> " " <> t
strP = DeviceToken <$> strP <* A.space <*> hexStringP
where
hexStringP =
A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
if even (B.length s) then pure s else fail "odd number of hex characters"
instance ToJSON DeviceToken where
toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
type NtfEntityId = ByteString
type NtfSubscriptionId = NtfEntityId
type NtfTokenId = NtfEntityId
data NtfSubStatus
= -- | state after SNEW
NSNew
| -- | pending connection/subscription to SMP server
NSPending
| -- | connected and subscribed to SMP server
NSActive
| -- | disconnected/unsubscribed from SMP server
NSInactive
| -- | END received
NSEnd
| -- | SMP AUTH error
NSAuth
| -- | SMP error other than AUTH
NSErr ByteString
deriving (Eq, Show)
ntfShouldSubscribe :: NtfSubStatus -> Bool
ntfShouldSubscribe = \case
NSNew -> True
NSPending -> True
NSActive -> True
NSInactive -> True
NSEnd -> False
NSAuth -> False
NSErr _ -> False
instance Encoding NtfSubStatus where
smpEncode = \case
NSNew -> "NEW"
NSPending -> "PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
NSActive -> "ACTIVE"
NSInactive -> "INACTIVE"
NSEnd -> "END"
NSAuth -> "AUTH"
NSErr err -> "ERR " <> err
smpP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NSNew
"PENDING" -> pure NSPending
"ACTIVE" -> pure NSActive
"INACTIVE" -> pure NSInactive
"END" -> pure NSEnd
"AUTH" -> pure NSAuth
"ERR" -> NSErr <$> (A.space *> A.takeByteString)
_ -> fail "bad NtfSubStatus"
instance StrEncoding NtfSubStatus where
strEncode = smpEncode
strP = smpP
data NtfTknStatus
= -- | Token created in DB
NTNew
| -- | state after registration (TNEW)
NTRegistered
| -- | if initial notification failed (push provider error) or verification failed
NTInvalid
| -- | Token confirmed via notification (accepted by push provider or verification code received by client)
NTConfirmed
| -- | after successful verification (TVFY)
NTActive
| -- | after it is no longer valid (push provider error)
NTExpired
deriving (Eq, Show)
instance Encoding NtfTknStatus where
smpEncode = \case
NTNew -> "NEW"
NTRegistered -> "REGISTERED"
NTInvalid -> "INVALID"
NTConfirmed -> "CONFIRMED"
NTActive -> "ACTIVE"
NTExpired -> "EXPIRED"
smpP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NTNew
"REGISTERED" -> pure NTRegistered
"INVALID" -> pure NTInvalid
"CONFIRMED" -> pure NTConfirmed
"ACTIVE" -> pure NTActive
"EXPIRED" -> pure NTExpired
_ -> fail "bad NtfTknStatus"
instance StrEncoding NtfTknStatus where
strEncode = smpEncode
strP = smpP
instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
instance ToJSON NtfTknStatus where
toEncoding = JE.text . decodeLatin1 . smpEncode
toJSON = J.String . decodeLatin1 . smpEncode
checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
Just Refl -> Right c
Nothing -> Left "bad command party"
checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
checkEntity' c = case testEquality (sNtfEntity @p) (sNtfEntity @p') of
Just Refl -> Just c
_ -> Nothing
@@ -1,579 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Notifications.Server where
import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.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.Functor (($>))
import Data.List (intercalate)
import Data.Map.Strict (Map)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Network.Socket (ServiceName)
import Simplex.Messaging.Client (ProtocolClientError (..))
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Env
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
import Simplex.Messaging.Notifications.Server.Stats
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Notifications.Server.StoreLog
import Simplex.Messaging.Notifications.Transport
import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import Simplex.Messaging.Server.Stats
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
import Simplex.Messaging.Transport.Server (runTransportServer)
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
import System.Mem.Weak (deRefWeak)
import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.STM
runNtfServer :: (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 cfg@NtfServerConfig {transports} started = do
restoreServerStats
s <- asks subscriber
ps <- asks pushServer
subs <- readTVarIO =<< asks (subscriptions . store)
void . forkIO $ resubscribe s subs
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
where
runServer :: (ServiceName, ATransport) -> m ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams (runClient t)
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
Right th -> runNtfClientTransport th
Left _ -> pure ()
stopServer :: m ()
stopServer = do
withNtfLog closeStoreLog
saveServerStats
asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
serverStatsThread_ :: NtfServerConfig -> [m ()]
serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
[logServerStats logStatsStartTime interval serverStatsLogFile]
serverStatsThread_ _ = []
logServerStats :: Int -> Int -> FilePath -> m ()
logServerStats startAt logInterval statsFilePath = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
let interval = 1000000 * logInterval
withFile statsFilePath AppendMode $ \h -> liftIO $ do
hSetBuffering h LineBuffering
forever $ do
ts <- getCurrentTime
fromTime' <- atomically $ swapTVar fromTime ts
tknCreated' <- atomically $ swapTVar tknCreated 0
tknVerified' <- atomically $ swapTVar tknVerified 0
tknDeleted' <- atomically $ swapTVar tknDeleted 0
subCreated' <- atomically $ swapTVar subCreated 0
subDeleted' <- atomically $ swapTVar subDeleted 0
ntfReceived' <- atomically $ swapTVar ntfReceived 0
ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
tkn <- atomically $ periodStatCounts activeTokens ts
sub <- atomically $ periodStatCounts activeSubs ts
hPutStrLn h $
intercalate
","
[ iso8601Show $ utctDay fromTime',
show tknCreated',
show tknVerified',
show tknDeleted',
show subCreated',
show subDeleted',
show ntfReceived',
show ntfDelivered',
dayCount tkn,
weekCount tkn,
monthCount tkn,
dayCount sub,
weekCount sub,
monthCount sub
]
threadDelay interval
resubscribe :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> m ()
resubscribe NtfSubscriber {newSubQ} subs = do
d <- asks $ resubscribeDelay . config
forM_ subs $ \sub@NtfSubData {} ->
whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
atomically $ writeTBQueue newSubQ $ NtfSub sub
threadDelay d
liftIO $ logInfo "SMP connections resubscribed"
ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
raceAny_ [subscribe, receiveSMP, receiveAgent]
where
subscribe :: m ()
subscribe =
forever $
atomically (readTBQueue newSubQ) >>= \case
sub@(NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer}}) -> do
SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
atomically $ writeTQueue subscriberSubQ sub
getSMPSubscriber :: SMPServer -> m SMPSubscriber
getSMPSubscriber smpServer =
atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
where
createSMPSubscriber = do
sub@SMPSubscriber {subThreadId} <- atomically newSMPSubscriber
atomically $ TM.insert smpServer sub smpSubscribers
tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub)
atomically . writeTVar subThreadId $ Just tId
pure sub
runSMPSubscriber :: SMPSubscriber -> m ()
runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
forever $
atomically (peekTQueue subscriberSubQ)
>>= \(NtfSub NtfSubData {smpQueue, notifierKey}) -> do
updateSubStatus smpQueue NSPending
let SMPQueueNtf {smpServer, notifierId} = smpQueue
liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
Right _ -> do
updateSubStatus smpQueue NSActive
void . atomically $ readTQueue subscriberSubQ
Left err -> do
handleSubError smpQueue err
case err of
PCEResponseTimeout -> pure ()
PCENetworkError -> pure ()
_ -> void . atomically $ readTQueue subscriberSubQ
receiveSMP :: m ()
receiveSMP = forever $ do
(srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
let smpQueue = SMPQueueNtf srv ntfId
case msg of
SMP.NMSG nmsgNonce encNMsgMeta -> do
ntfTs <- liftIO getSystemTime
st <- asks store
NtfPushServer {pushQ} <- asks pushServer
stats <- asks serverStats
atomically $ updatePeriodStats (activeSubs stats) ntfId
atomically $
findNtfSubscriptionToken st smpQueue
>>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
incNtfStat ntfReceived
SMP.END -> updateSubStatus smpQueue NSEnd
_ -> pure ()
pure ()
receiveAgent =
forever $
atomically (readTBQueue agentQ) >>= \case
CAConnected _ -> pure ()
CADisconnected srv subs -> do
logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAReconnected srv ->
logInfo $ "SMP server reconnected " <> showServer' srv
CAResubscribed srv sub -> do
let ntfId = snd sub
smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSActive
CASubError srv (_, ntfId) err -> do
logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
handleSubError (SMPQueueNtf srv ntfId) err
where
showServer' = decodeLatin1 . strEncode . host
handleSubError :: SMPQueueNtf -> ProtocolClientError -> m ()
handleSubError smpQueue = \case
PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
PCEProtocolError e -> updateErr "SMP error " e
PCEIOError e -> updateErr "IOError " e
PCEResponseError e -> updateErr "ResponseError " e
PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
PCETransportError e -> updateErr "TransportError " e
PCESignatureError e -> updateErr "SignatureError " e
PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
PCEResponseTimeout -> pure ()
PCENetworkError -> pure ()
where
updateErr :: Show e => ByteString -> e -> m ()
updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
updateSubStatus smpQueue status = do
st <- asks store
atomically (findNtfSubscription st smpQueue)
>>= mapM_
( \NtfSubData {ntfSubId, subStatus} -> do
atomically $ writeTVar subStatus status
withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status
)
ntfPush :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfPushServer -> m ()
ntfPush s@NtfPushServer {pushQ} = forever $ do
(tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
status <- readTVarIO tknStatus
case (status, ntf) of
(_, PNVerification _) ->
-- TODO check token status
deliverNotification pp tkn ntf >>= \case
Right _ -> do
status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
_ -> pure ()
(NTActive, PNCheckMessages) ->
void $ deliverNotification pp tkn ntf
(NTActive, PNMessage {}) -> do
stats <- asks serverStats
atomically $ updatePeriodStats (activeTokens stats) ntfTknId
void $ deliverNotification pp tkn ntf
incNtfStat ntfDelivered
_ ->
liftIO $ logError "bad notification token status"
where
deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> m (Either PushProviderError ())
deliverNotification pp tkn@NtfTknData {ntfTknId, tknStatus} ntf = do
deliver <- liftIO $ getPushClient s pp
liftIO (runExceptT $ deliver tkn ntf) >>= \case
Right _ -> pure $ Right ()
Left e -> case e of
PPConnection _ -> retryDeliver
PPRetryLater -> retryDeliver
-- TODO alert
PPCryptoError _ -> err e
PPResponseError _ _ -> err e
PPTokenInvalid -> updateTknStatus NTInvalid >> err e
PPPermanentError -> err e
where
retryDeliver :: m (Either PushProviderError ())
retryDeliver = do
deliver <- liftIO $ newPushClient s pp
liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
updateTknStatus :: NtfTknStatus -> m ()
updateTknStatus status = do
atomically $ writeTVar tknStatus status
withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
runNtfClientTransport :: (Transport c, 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
ts <- tGet th
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
atomically . writeTVar activeAt =<< liftIO getSystemTime
logDebug "received transmission"
case cmdOrError of
Left e -> write sndQ (corrId, entId, NRErr e)
Right cmd ->
verifyNtfTransmission t cmd >>= \case
VRVerified req -> write rcvQ req
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
where
write q t = atomically $ writeTBQueue q t
send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
atomically . writeTVar activeAt =<< liftIO getSystemTime
-- instance Show a => Show (TVar a) where
-- show x = unsafePerformIO $ show <$> readTVarIO x
data VerificationResult = VRVerified NtfRequest | VRFailed
verifyNtfTransmission ::
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
verifyToken t_ (`verifiedTknCmd` c)
NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> do
s_ <- atomically $ findNtfSubscription st smpQueue
case s_ of
Nothing -> do
-- TODO move active token check here to differentiate error
t_ <- atomically $ getActiveNtfToken st tknId
verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
Just s@NtfSubData {tokenId = subTknId} ->
if subTknId == tknId
then do
-- TODO move active token check here to differentiate error
t_ <- atomically $ getActiveNtfToken st subTknId
verifyToken' t_ $ verifiedSubCmd s c
else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
NtfCmd SSubscription c -> do
s_ <- atomically $ getNtfSubscription st entId
case s_ of
Just s@NtfSubData {tokenId = subTknId} -> do
-- TODO move active token check here to differentiate error
t_ <- atomically $ getActiveNtfToken st subTknId
verifyToken' t_ $ verifiedSubCmd s c
_ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
where
verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> m VerificationResult
verifyToken t_ positiveVerificationResult =
pure $ case t_ of
Just t@NtfTknData {tknVerifyKey} ->
if verifyCmdSignature sig_ signed tknVerifyKey
then positiveVerificationResult t
else VRFailed
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
verifyToken' :: Maybe NtfTknData -> VerificationResult -> m VerificationResult
verifyToken' t_ = verifyToken t_ . const
client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
forever $
atomically (readTBQueue rcvQ)
>>= processCommand
>>= atomically . writeTBQueue sndQ
where
processCommand :: NtfRequest -> m (Transmission NtfResponse)
processCommand = \case
NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
logDebug "TNEW - new token"
st <- asks store
ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
let dhSecret = C.dh' dhPubKey srvDhPrivKey
tknId <- getId
regCode <- getRegCode
tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode
atomically $ addNtfToken st tknId tkn
atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
withNtfLog (`logCreateToken` tkn)
incNtfStat tknCreated
pure (corrId, "", NRTknId tknId srvDhPubKey)
NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
status <- readTVarIO tknStatus
(corrId,tknId,) <$> case cmd of
TNEW (NewNtfTkn _ _ dhPubKey) -> do
logDebug "TNEW - registered token"
let dhSecret = C.dh' dhPubKey srvDhPrivKey
-- it is required that DH secret is the same, to avoid failed verifications if notification is delaying
if tknDhSecret == dhSecret
then do
atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
pure $ NRTknId ntfTknId srvDhPubKey
else pure $ NRErr AUTH
TVFY code -- this allows repeated verification for cases when client connection dropped before server response
| (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
logDebug "TVFY - token verified"
st <- asks store
atomically $ writeTVar tknStatus NTActive
tIds <- atomically $ removeInactiveTokenRegistrations st tkn
forM_ tIds cancelInvervalNotifications
withNtfLog $ \s -> logTokenStatus s tknId NTActive
incNtfStat tknVerified
pure NROk
| otherwise -> do
logDebug "TVFY - incorrect code or token status"
pure $ NRErr AUTH
TCHK -> do
logDebug "TCHK"
pure $ NRTkn status
TRPL token' -> do
logDebug "TRPL - replace token"
st <- asks store
regCode <- getRegCode
atomically $ do
removeTokenRegistration st tkn
writeTVar tknStatus NTRegistered
let tkn' = tkn {token = token', tknRegCode = regCode}
addNtfToken st tknId tkn'
writeTBQueue pushQ (tkn', PNVerification regCode)
withNtfLog $ \s -> logUpdateToken s tknId token' regCode
incNtfStat tknDeleted
incNtfStat tknCreated
pure NROk
TDEL -> do
logDebug "TDEL"
st <- asks store
qs <- atomically $ deleteNtfToken st tknId
forM_ qs $ \SMPQueueNtf {smpServer, notifierId} ->
atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
cancelInvervalNotifications tknId
withNtfLog (`logDeleteToken` tknId)
incNtfStat tknDeleted
pure NROk
TCRN 0 -> do
logDebug "TCRN 0"
atomically $ writeTVar tknCronInterval 0
cancelInvervalNotifications tknId
withNtfLog $ \s -> logTokenCron s tknId 0
pure NROk
TCRN int
| int < 20 -> pure $ NRErr QUOTA
| otherwise -> do
logDebug "TCRN"
atomically $ writeTVar tknCronInterval int
atomically (TM.lookup tknId intervalNotifiers) >>= \case
Nothing -> runIntervalNotifier int
Just IntervalNotifier {interval, action} ->
unless (interval == int) $ do
uninterruptibleCancel action
runIntervalNotifier int
withNtfLog $ \s -> logTokenCron s tknId int
pure NROk
where
runIntervalNotifier interval = do
action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
let notifier = IntervalNotifier {action, token = tkn, interval}
atomically $ TM.insert tknId notifier intervalNotifiers
where
intervalNotifier delay = forever $ do
threadDelay delay
atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
NtfReqNew corrId (ANE SSubscription newSub) -> do
logDebug "SNEW - new subscription"
st <- asks store
subId <- getId
sub <- atomically $ mkNtfSubData subId newSub
resp <-
atomically (addNtfSubscription st subId sub) >>= \case
Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
_ -> pure $ NRErr AUTH
withNtfLog (`logCreateSubscription` sub)
incNtfStat subCreated
pure (corrId, "", resp)
NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
status <- readTVarIO subStatus
(corrId,subId,) <$> case cmd of
SNEW (NewNtfSub _ _ notifierKey) -> do
logDebug "SNEW - existing subscription"
-- TODO retry if subscription failed, if pending or AUTH do nothing
pure $
if notifierKey == registeredNKey
then NRSubId subId
else NRErr AUTH
SCHK -> do
logDebug "SCHK"
pure $ NRSub status
SDEL -> do
logDebug "SDEL"
st <- asks store
atomically $ deleteNtfSubscription st subId
atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
withNtfLog (`logDeleteSubscription` subId)
incNtfStat subDeleted
pure NROk
PING -> pure NRPong
getId :: m NtfEntityId
getId = getRandomBytes =<< asks (subIdBytes . config)
getRegCode :: m NtfRegCode
getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
getRandomBytes :: Int -> m ByteString
getRandomBytes n = do
gVar <- asks idsDrg
atomically (C.pseudoRandomBytes n gVar)
cancelInvervalNotifications :: NtfTokenId -> m ()
cancelInvervalNotifications tknId =
atomically (TM.lookupDelete tknId intervalNotifiers)
>>= mapM_ (uninterruptibleCancel . action)
withNtfLog :: (MonadUnliftIO m, MonadReader NtfEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
withNtfLog action = liftIO . mapM_ action =<< asks storeLog
incNtfStat :: (MonadUnliftIO m, MonadReader NtfEnv m) => (NtfServerStats -> TVar Int) -> m ()
incNtfStat statSel = do
stats <- asks serverStats
atomically $ modifyTVar (statSel stats) (+ 1)
saveServerStats :: (MonadUnliftIO m, MonadReader NtfEnv m) => m ()
saveServerStats =
asks (serverStatsBackupFile . config)
>>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
where
saveStats f stats = do
logInfo $ "saving server stats to file " <> T.pack f
B.writeFile f $ strEncode stats
logInfo "server stats saved"
restoreServerStats :: (MonadUnliftIO m, MonadReader NtfEnv m) => m ()
restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
where
restoreStats f = whenM (doesFileExist f) $ do
logInfo $ "restoring server stats from file " <> T.pack f
liftIO (strDecode <$> B.readFile f) >>= \case
Right d -> do
s <- asks serverStats
atomically $ setNtfServerStats s d
renameFile f $ f <> ".bak"
logInfo "server stats restored"
Left e -> do
logInfo $ "error restoring server stats: " <> T.pack e
liftIO exitFailure
@@ -1,165 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Notifications.Server.Env where
import Control.Concurrent (ThreadId)
import Control.Concurrent.Async (Async)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.System (SystemTime)
import Data.Word (Word16)
import Data.X509.Validation (Fingerprint (..))
import Network.Socket
import qualified Network.TLS as T
import Numeric.Natural
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Server.Stats
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Notifications.Server.StoreLog
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
data NtfServerConfig = NtfServerConfig
{ transports :: [(ServiceName, ATransport)],
subIdBytes :: Int,
regCodeBytes :: Int,
clientQSize :: Natural,
subQSize :: Natural,
pushQSize :: Natural,
smpAgentCfg :: SMPClientAgentConfig,
apnsConfig :: APNSPushClientConfig,
inactiveClientExpiration :: Maybe ExpirationConfig,
storeLogFile :: Maybe FilePath,
resubscribeDelay :: Int, -- microseconds
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
-- stats config - see SMP server config
logStatsInterval :: Maybe Int,
logStatsStartTime :: Int,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath
}
defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration =
ExpirationConfig
{ ttl = 7200, -- 2 hours
checkInterval = 3600 -- seconds, 1 hour
}
data NtfEnv = NtfEnv
{ config :: NtfServerConfig,
subscriber :: NtfSubscriber,
pushServer :: NtfPushServer,
store :: NtfStore,
storeLog :: Maybe (StoreLog 'WriteMode),
idsDrg :: TVar ChaChaDRG,
serverIdentity :: C.KeyHash,
tlsServerParams :: T.ServerParams,
serverIdentity :: C.KeyHash,
serverStats :: NtfServerStats
}
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
idsDrg <- newTVarIO =<< drgNew
store <- atomically newNtfStore
storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
data NtfSubscriber = NtfSubscriber
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
newSubQ :: TBQueue (NtfEntityRec 'Subscription),
smpAgent :: SMPClientAgent
}
newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
newNtfSubscriber qSize smpAgentCfg = do
smpSubscribers <- TM.empty
newSubQ <- newTBQueue qSize
smpAgent <- newSMPClientAgent smpAgentCfg
pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
data SMPSubscriber = SMPSubscriber
{ newSubQ :: TQueue (NtfEntityRec 'Subscription),
subThreadId :: TVar (Maybe (Weak ThreadId))
}
newSMPSubscriber :: STM SMPSubscriber
newSMPSubscriber = do
newSubQ <- newTQueue
subThreadId <- newTVar Nothing
pure SMPSubscriber {newSubQ, subThreadId}
data NtfPushServer = NtfPushServer
{ pushQ :: TBQueue (NtfTknData, PushNotification),
pushClients :: TMap PushProvider PushProviderClient,
intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
apnsConfig :: APNSPushClientConfig
}
data IntervalNotifier = IntervalNotifier
{ action :: Async (),
token :: NtfTknData,
interval :: Word16
}
newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
newNtfPushServer qSize apnsConfig = do
pushQ <- newTBQueue qSize
pushClients <- TM.empty
intervalNotifiers <- TM.empty
pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
c <- apnsPushProviderClient <$> createAPNSPushClient (apnsProviderHost pp) apnsConfig
atomically $ TM.insert pp c pushClients
pure c
getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
getPushClient s@NtfPushServer {pushClients} pp =
atomically (TM.lookup pp pushClients) >>= maybe (newPushClient s pp) pure
data NtfRequest
= NtfReqNew CorrId ANewNtfEntity
| forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
data NtfServerClient = NtfServerClient
{ rcvQ :: TBQueue NtfRequest,
sndQ :: TBQueue (Transmission NtfResponse),
sessionId :: ByteString,
connected :: TVar Bool,
activeAt :: TVar SystemTime
}
newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
newNtfServerClient qSize sessionId ts = do
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
connected <- newTVar True
activeAt <- newTVar ts
return NtfServerClient {rcvQ, sndQ, sessionId, connected, activeAt}
@@ -1 +0,0 @@
local.env
@@ -1,374 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
module Simplex.Messaging.Notifications.Server.Push.APNS where
import Control.Exception (Exception)
import Control.Logger.Simple
import Control.Monad.Except
import Crypto.Hash.Algorithms (SHA256 (..))
import qualified Crypto.PubKey.ECC.ECDSA as EC
import qualified Crypto.PubKey.ECC.Types as ECT
import Crypto.Random (ChaChaDRG, drgNew)
import qualified Crypto.Store.PKCS8 as PK
import Data.ASN1.BinaryEncoding (DER (..))
import Data.ASN1.Encoding
import Data.ASN1.Types
import Data.Aeson (FromJSON, ToJSON, (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Builder (lazyByteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.CaseInsensitive as CI
import Data.Int (Int64)
import Data.Map.Strict (Map)
import Data.Text (Text)
import qualified Data.Text as T
import Data.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 (EncNMsgMeta)
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 PNMessageData
| PNAlert Text
| PNCheckMessages
deriving (Show)
data PNMessageData = PNMessageData
{ smpQueue :: SMPQueueNtf,
ntfTs :: SystemTime,
nmsgNonce :: C.CbNonce,
encNMsgMeta :: EncNMsgMeta
}
deriving (Show)
instance StrEncoding PNMessageData where
strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
strP = do
(smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
deriving (Show, Generic)
instance ToJSON APNSNotification where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data APNSNotificationBody
= APNSBackground {contentAvailable :: Int}
| APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text}
| APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text}
deriving (Show, Generic)
apnsJSONOptions :: J.Options
apnsJSONOptions = J.defaultOptions {J.omitNothingFields = True, J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'}
instance ToJSON APNSNotificationBody where
toJSON = J.genericToJSON apnsJSONOptions
toEncoding = J.genericToEncoding apnsJSONOptions
type APNSNotificationData = Map Text Text
data APNSAlertBody = APNSAlertObject {title :: Text, subtitle :: Text, body :: Text} | APNSAlertText Text
deriving (Show)
instance ToJSON APNSAlertBody where
toEncoding = \case
APNSAlertObject {title, subtitle, body} -> J.pairs $ "title" .= title <> "subtitle" .= subtitle <> "body" .= body
APNSAlertText t -> JE.text t
toJSON = \case
APNSAlertObject {title, subtitle, body} -> J.object ["title" .= title, "subtitle" .= subtitle, "body" .= body]
APNSAlertText t -> J.String t
-- APNS notification types
--
-- Visible alerts:
-- {
-- "aps" : {
-- "alert" : {
-- "title" : "Game Request",
-- "subtitle" : "Five Card Draw",
-- "body" : "Bob wants to play poker"
-- },
-- "badge" : 9,
-- "sound" : "bingbong.aiff",
-- "category" : "GAME_INVITATION"
-- },
-- "gameID" : "12345678"
-- }
--
-- Simple text alert:
-- {"aps":{"alert":"you have a new message"}}
--
-- Background notification to fetch content
-- {"aps":{"content-available":1}}
--
-- Mutable content notification that must be shown but can be processed before before being shown (up to 30 sec)
-- {
-- "aps" : {
-- "category" : "SECRET",
-- "mutable-content" : 1,
-- "alert" : {
-- "title" : "Secret Message!",
-- "body" : "(Encrypted)"
-- },
-- },
-- "ENCRYPTED_DATA" : "Salted__·öîQÊ$UDì_¶Ù∞èΩ^¬%gq∞NÿÒQùw"
-- }
data APNSPushClientConfig = APNSPushClientConfig
{ tokenTTL :: Int64,
authKeyFileEnv :: String,
authKeyAlg :: Text,
authKeyIdEnv :: String,
paddedNtfLength :: Int,
appName :: ByteString,
appTeamId :: Text,
apnsPort :: ServiceName,
http2cfg :: HTTP2ClientConfig
}
deriving (Show)
apnsProviderHost :: PushProvider -> HostName
apnsProviderHost = \case
PPApnsTest -> "localhost"
PPApnsDev -> "api.sandbox.push.apple.com"
PPApnsProd -> "api.push.apple.com"
defaultAPNSPushClientConfig :: APNSPushClientConfig
defaultAPNSPushClientConfig =
APNSPushClientConfig
{ tokenTTL = 1800, -- 30 minutes
authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
authKeyAlg = "ES256",
authKeyIdEnv = "APNS_KEY_ID",
paddedNtfLength = 512,
appName = "chat.simplex.app",
appTeamId = "5NN7GUYB6T",
apnsPort = "443",
http2cfg = defaultHTTP2ClientConfig
}
data APNSPushClient = APNSPushClient
{ https2Client :: TVar (Maybe HTTP2Client),
privateKey :: EC.PrivateKey,
jwtHeader :: JWTHeader,
jwtToken :: TVar (JWTToken, SignedJWTToken),
nonceDrg :: TVar ChaChaDRG,
apnsHost :: HostName,
apnsCfg :: APNSPushClientConfig
}
createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
https2Client <- newTVarIO Nothing
void $ connectHTTPS2 apnsHost apnsCfg https2Client
privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
authKeyId <- T.pack <$> getEnv authKeyIdEnv
let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
nonceDrg <- drgNew >>= newTVarIO
pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg}
getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken
getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, tokenTTL}, privateKey, jwtHeader, jwtToken} = do
(jwt, signedJWT) <- readTVarIO jwtToken
age <- jwtTokenAge jwt
if age < tokenTTL
then pure signedJWT
else do
t@(_, signedJWT') <- mkApnsJWTToken appTeamId jwtHeader privateKey
atomically $ writeTVar jwtToken t
pure signedJWT'
where
jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
mkApnsJWTToken appTeamId jwtHeader privateKey = do
jwt <- mkJWTToken jwtHeader appTeamId
signedJWT <- signedJWTToken privateKey jwt
pure (jwt, signedJWT)
connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
case r of
Right client -> atomically . writeTVar https2Client $ Just client
Left e -> putStrLn $ "Error connecting to APNS: " <> show e
pure r
where
disconnected = atomically $ writeTVar https2Client Nothing
getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
getApnsHTTP2Client APNSPushClient {https2Client, apnsHost, apnsCfg} =
readTVarIO https2Client >>= maybe (connectHTTPS2 apnsHost apnsCfg https2Client) (pure . Right)
disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
disconnectApnsHTTP2Client APNSPushClient {https2Client} =
readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
ntfCategoryCheckMessage :: Text
ntfCategoryCheckMessage = "NTF_CAT_CHECK_MESSAGE"
apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
PNVerification (NtfRegCode code) ->
encrypt code $ \code' ->
apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
PNMessage pnMessageData ->
encrypt (strEncode pnMessageData) $ \ntfData ->
apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
where
encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
apn aps notificationData = APNSNotification {aps, notificationData}
apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or another app event", category = Just ntfCategoryCheckMessage}
apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
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, Exception)
type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
-- this is not a newtype on purpose to have a correct JSON encoding as a record
data APNSErrorResponse = APNSErrorResponse {reason :: Text}
deriving (Generic, FromJSON)
apnsPushProviderClient :: APNSPushClient -> PushProviderClient
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do
http2 <- liftHTTPS2 $ getApnsHTTP2Client c
nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
req <- liftIO $ apnsRequest c tknStr apnsNtf
HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
let status = H.responseStatus response
reason' = maybe "" reason $ J.decodeStrict' respBody
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
result status reason'
where
result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
result status reason'
| status == Just N.ok200 = pure ()
| status == Just N.badRequest400 =
case reason' of
"BadDeviceToken" -> throwError PPTokenInvalid
"DeviceTokenNotForTopic" -> throwError PPTokenInvalid
"TopicDisallowed" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.forbidden403 = case reason' of
"ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
"InvalidProviderToken" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.gone410 = throwError PPTokenInvalid
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token
| otherwise = err status reason'
err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
err s r = throwError $ PPResponseError s r
liftHTTPS2 a = ExceptT $ first PPConnection <$> a
hApnsTopic :: HeaderName
hApnsTopic = CI.mk "apns-topic"
hApnsPushType :: HeaderName
hApnsPushType = CI.mk "apns-push-type"
hApnsPriority :: HeaderName
hApnsPriority = CI.mk "apns-priority"
@@ -1,26 +0,0 @@
#!/bin/sh
export TEAM_ID=5NN7GUYB6T
# export APNS_KEY_FILE=""
# export APNS_KEY_ID=""
export TOPIC=chat.simplex.app
# export DEVICE_TOKEN=
export APNS_HOST_NAME=api.sandbox.push.apple.com
export JWT_ISSUE_TIME=$(date +%s)
export JWT_HEADER=$(printf '{"alg":"ES256","kid":"%s"}' "${APNS_KEY_ID}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
export JWT_CLAIMS=$(printf '{"iss":"%s","iat":%d}' "${TEAM_ID}" "${JWT_ISSUE_TIME}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
export JWT_HEADER_CLAIMS="${JWT_HEADER}.${JWT_CLAIMS}"
export JWT_SIGNED_HEADER_CLAIMS=$(printf "${JWT_HEADER_CLAIMS}" | openssl dgst -binary -sha256 -sign "${APNS_KEY_FILE}" | openssl base64 -e -A | tr -- '+/' '-_' | tr -d =)
export AUTHENTICATION_TOKEN="${JWT_HEADER}.${JWT_CLAIMS}.${JWT_SIGNED_HEADER_CLAIMS}"
# simple alert
# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"alert":"you have a new message"},"data":{"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
# background notification
# curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: background" --header "apns-priority: 5" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"content-available":1}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
# mutable-content notification
# NTF_CAT_CHECK_MESSAGE category will not show alert if the app is in foreground
curl -v --header "apns-topic: $TOPIC" --header "apns-push-type: alert" --header "authorization: bearer $AUTHENTICATION_TOKEN" --data '{"aps":{"category": "NTF_CAT_CHECK_MESSAGE__SECRET", "mutable-content": 1, "alert":"received encrypted message"}, "data": {"test":"123"}}' --http2 https://${APNS_HOST_NAME}/3/device/${DEVICE_TOKEN}
@@ -1,113 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Notifications.Server.Stats where
import Control.Applicative (optional)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B
import Data.Time.Clock (UTCTime)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
import Simplex.Messaging.Protocol (NotifierId)
import Simplex.Messaging.Server.Stats
import UnliftIO.STM
data NtfServerStats = NtfServerStats
{ fromTime :: TVar UTCTime,
tknCreated :: TVar Int,
tknVerified :: TVar Int,
tknDeleted :: TVar Int,
subCreated :: TVar Int,
subDeleted :: TVar Int,
ntfReceived :: TVar Int,
ntfDelivered :: TVar Int,
activeTokens :: PeriodStats NtfTokenId,
activeSubs :: PeriodStats NotifierId
}
data NtfServerStatsData = NtfServerStatsData
{ _fromTime :: UTCTime,
_tknCreated :: Int,
_tknVerified :: Int,
_tknDeleted :: Int,
_subCreated :: Int,
_subDeleted :: Int,
_ntfReceived :: Int,
_ntfDelivered :: Int,
_activeTokens :: PeriodStatsData NtfTokenId,
_activeSubs :: PeriodStatsData NotifierId
}
newNtfServerStats :: UTCTime -> STM NtfServerStats
newNtfServerStats ts = do
fromTime <- newTVar ts
tknCreated <- newTVar 0
tknVerified <- newTVar 0
tknDeleted <- newTVar 0
subCreated <- newTVar 0
subDeleted <- newTVar 0
ntfReceived <- newTVar 0
ntfDelivered <- newTVar 0
activeTokens <- newPeriodStats
activeSubs <- newPeriodStats
pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
getNtfServerStatsData s = do
_fromTime <- readTVar $ fromTime (s :: NtfServerStats)
_tknCreated <- readTVar $ tknCreated s
_tknVerified <- readTVar $ tknVerified s
_tknDeleted <- readTVar $ tknDeleted s
_subCreated <- readTVar $ subCreated s
_subDeleted <- readTVar $ subDeleted s
_ntfReceived <- readTVar $ ntfReceived s
_ntfDelivered <- readTVar $ ntfDelivered s
_activeTokens <- getPeriodStatsData $ activeTokens s
_activeSubs <- getPeriodStatsData $ activeSubs s
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
setNtfServerStats s d = do
writeTVar (fromTime (s :: NtfServerStats)) (_fromTime (d :: NtfServerStatsData))
writeTVar (tknCreated s) (_tknCreated d)
writeTVar (tknVerified s) (_tknVerified d)
writeTVar (tknDeleted s) (_tknDeleted d)
writeTVar (subCreated s) (_subCreated d)
writeTVar (subDeleted s) (_subDeleted d)
writeTVar (ntfReceived s) (_ntfReceived d)
writeTVar (ntfDelivered s) (_ntfDelivered d)
setPeriodStats (activeTokens s) (_activeTokens d)
setPeriodStats (activeSubs s) (_activeSubs d)
instance StrEncoding NtfServerStatsData where
strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
B.unlines
[ "fromTime=" <> strEncode _fromTime,
"tknCreated=" <> strEncode _tknCreated,
"tknVerified=" <> strEncode _tknVerified,
"tknDeleted=" <> strEncode _tknDeleted,
"subCreated=" <> strEncode _subCreated,
"subDeleted=" <> strEncode _subDeleted,
"ntfReceived=" <> strEncode _ntfReceived,
"ntfDelivered=" <> strEncode _ntfDelivered,
"activeTokens:",
strEncode _activeTokens,
"activeSubs:",
strEncode _activeSubs
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
_tknCreated <- "tknCreated=" *> strP <* A.endOfLine
_tknVerified <- "tknVerified=" *> strP <* A.endOfLine
_tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
_subCreated <- "subCreated=" *> strP <* A.endOfLine
_subDeleted <- "subDeleted=" *> strP <* A.endOfLine
_ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
_ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
_ <- "activeTokens:" <* A.endOfLine
_activeTokens <- strP <* A.endOfLine
_ <- "activeSubs:" <* A.endOfLine
_activeSubs <- strP <* optional A.endOfLine
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
@@ -1,202 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Notifications.Server.Store where
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Word (Word16)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (whenM, ($>>=))
data NtfStore = NtfStore
{ tokens :: TMap NtfTokenId NtfTknData,
-- multiple registrations exist to protect from malicious registrations if token is compromised
tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
subscriptions :: TMap NtfSubscriptionId NtfSubData,
tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
}
newNtfStore :: STM NtfStore
newNtfStore = do
tokens <- TM.empty
tokenRegistrations <- TM.empty
subscriptions <- TM.empty
tokenSubscriptions <- TM.empty
subscriptionLookup <- TM.empty
pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
data NtfTknData = NtfTknData
{ ntfTknId :: NtfTokenId,
token :: DeviceToken,
tknStatus :: TVar NtfTknStatus,
tknVerifyKey :: C.APublicVerifyKey,
tknDhKeys :: C.KeyPair 'C.X25519,
tknDhSecret :: C.DhSecretX25519,
tknRegCode :: NtfRegCode,
tknCronInterval :: TVar Word16
}
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
tknStatus <- newTVar NTRegistered
tknCronInterval <- newTVar 0
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
data NtfSubData = NtfSubData
{ ntfSubId :: NtfSubscriptionId,
smpQueue :: SMPQueueNtf,
notifierKey :: NtfPrivateSignKey,
tokenId :: NtfTokenId,
subStatus :: TVar NtfSubStatus
}
data NtfEntityRec (e :: NtfEntity) where
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
getNtfToken st tknId = TM.lookup tknId (tokens st)
addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
TM.insert tknId tkn $ tokens st
TM.lookup token regs >>= \case
Just tIds -> TM.insert regKey tknId tIds
_ -> do
tIds <- TM.singleton regKey tknId
TM.insert token tIds regs
where
regs = tokenRegistrations st
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
getNtfTokenRegistration :: NtfStore -> NewNtfEntity 'Token -> STM (Maybe NtfTknData)
getNtfTokenRegistration st (NewNtfTkn token tknVerifyKey _) =
TM.lookup token (tokenRegistrations st)
$>>= TM.lookup regKey
$>>= (`TM.lookup` tokens st)
where
regKey = C.toPubKey C.pubKeyBytes tknVerifyKey
removeInactiveTokenRegistrations :: NtfStore -> NtfTknData -> STM [NtfTokenId]
removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
TM.lookup token (tokenRegistrations st)
>>= maybe (pure []) removeRegs
where
removeRegs :: TMap ByteString NtfTokenId -> STM [NtfTokenId]
removeRegs tknRegs = do
tIds <- filter ((/= tId) . snd) . M.assocs <$> readTVar tknRegs
forM_ tIds $ \(regKey, tId') -> do
TM.delete regKey tknRegs
TM.delete tId' $ tokens st
-- TODO remove token subscriptions as in deleteNtfToken
pure $ map snd tIds
removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
TM.lookup token (tokenRegistrations st) >>= mapM_ removeReg
where
removeReg regs =
TM.lookup k regs
>>= mapM_ (\tId' -> when (tId == tId') $ TM.delete k regs)
k = C.toPubKey C.pubKeyBytes tknVerifyKey
deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
deleteNtfToken st tknId = do
TM.lookupDelete tknId (tokens st)
>>= mapM_
( \NtfTknData {token, tknVerifyKey} ->
TM.lookup token regs
>>= mapM_
( \tIds -> do
TM.delete (regKey tknVerifyKey) tIds
whenM (TM.null tIds) $ TM.delete token regs
)
)
-- TODO refactor
qs <-
TM.lookupDelete tknId (tokenSubscriptions st)
>>= mapM
( readTVar
>=> mapM
( \subId -> do
TM.lookupDelete subId (subscriptions st)
>>= mapM
( \NtfSubData {smpQueue} ->
TM.delete smpQueue (subscriptionLookup st) $> smpQueue
)
)
. S.toList
)
pure $ maybe [] catMaybes qs
where
regs = tokenRegistrations st
regKey = C.toPubKey C.pubKeyBytes
getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
getNtfSubscription st subId =
TM.lookup subId (subscriptions st)
findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData)
findNtfSubscription st smpQueue = do
TM.lookup smpQueue (subscriptionLookup st)
$>>= \subId -> TM.lookup subId (subscriptions st)
findNtfSubscriptionToken :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfTknData)
findNtfSubscriptionToken st smpQueue = do
findNtfSubscription st smpQueue
$>>= \NtfSubData {tokenId} -> getActiveNtfToken st tokenId
getActiveNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
getActiveNtfToken st tknId =
getNtfToken st tknId $>>= \tkn@NtfTknData {tknStatus} -> do
tStatus <- readTVar tknStatus
pure $ if tStatus == NTActive then Just tkn else Nothing
mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
subStatus <- newTVar NSNew
pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
TM.lookup tokenId (tokenSubscriptions st) >>= maybe newTokenSub pure >>= insertSub
where
newTokenSub = do
ts <- newTVar S.empty
TM.insert tokenId ts $ tokenSubscriptions st
pure ts
insertSub ts = do
modifyTVar' ts $ S.insert subId
TM.insert subId sub $ subscriptions st
TM.insert smpQueue subId (subscriptionLookup st)
-- return Nothing if subscription existed before
pure $ Just ()
deleteNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM ()
deleteNtfSubscription st subId = do
TM.lookupDelete subId (subscriptions st)
>>= mapM_
( \NtfSubData {smpQueue, tokenId} -> do
TM.delete smpQueue $ subscriptionLookup st
ts_ <- TM.lookup tokenId (tokenSubscriptions st)
forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
)
@@ -1,227 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Notifications.Server.StoreLog
( StoreLog,
NtfStoreLogRecord (..),
readWriteNtfStore,
logCreateToken,
logTokenStatus,
logUpdateToken,
logTokenCron,
logDeleteToken,
logCreateSubscription,
logSubscriptionStatus,
logDeleteSubscription,
closeStoreLog,
)
where
import Control.Concurrent.STM
import Control.Monad (void)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B
import Data.Word (Word16)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Util (whenM)
import System.Directory (doesFileExist, renameFile)
import System.IO
data NtfStoreLogRecord
= CreateToken NtfTknRec
| TokenStatus NtfTokenId NtfTknStatus
| UpdateToken NtfTokenId DeviceToken NtfRegCode
| TokenCron NtfTokenId Word16
| DeleteToken NtfTokenId
| CreateSubscription NtfSubRec
| SubscriptionStatus NtfSubscriptionId NtfSubStatus
| DeleteSubscription NtfSubscriptionId
data NtfTknRec = NtfTknRec
{ ntfTknId :: NtfTokenId,
token :: DeviceToken,
tknStatus :: NtfTknStatus,
tknVerifyKey :: C.APublicVerifyKey,
tknDhKeys :: C.KeyPair 'C.X25519,
tknDhSecret :: C.DhSecretX25519,
tknRegCode :: NtfRegCode,
tknCronInterval :: Word16
}
mkTknData :: NtfTknRec -> STM NtfTknData
mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
tknStatus <- newTVar status
tknCronInterval <- newTVar cronInt
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
mkTknRec :: NtfTknData -> STM NtfTknRec
mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
tknStatus <- readTVar status
tknCronInterval <- readTVar cronInt
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
data NtfSubRec = NtfSubRec
{ ntfSubId :: NtfSubscriptionId,
smpQueue :: SMPQueueNtf,
notifierKey :: NtfPrivateSignKey,
tokenId :: NtfTokenId,
subStatus :: NtfSubStatus
}
mkSubData :: NtfSubRec -> STM NtfSubData
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
subStatus <- newTVar status
pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
mkSubRec :: NtfSubData -> STM NtfSubRec
mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
subStatus <- readTVar status
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
instance StrEncoding NtfStoreLogRecord where
strEncode = \case
CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
TokenStatus tknId tknStatus -> strEncode (Str "TSTATUS", tknId, tknStatus)
UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
strP =
A.choice
[ "TCREATE " *> (CreateToken <$> strP),
"TSTATUS " *> (TokenStatus <$> strP_ <*> strP),
"TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
"TCRON " *> (TokenCron <$> strP_ <*> strP),
"TDELETE " *> (DeleteToken <$> strP),
"SCREATE " *> (CreateSubscription <$> strP),
"SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
"SDELETE " *> (DeleteSubscription <$> strP)
]
instance StrEncoding NtfTknRec where
strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} =
B.unwords
[ "tknId=" <> strEncode ntfTknId,
"token=" <> strEncode token,
"tokenStatus=" <> strEncode tknStatus,
"verifyKey=" <> strEncode tknVerifyKey,
"dhKeys=" <> strEncode tknDhKeys,
"dhSecret=" <> strEncode tknDhSecret,
"regCode=" <> strEncode tknRegCode,
"cron=" <> strEncode tknCronInterval
]
strP = do
ntfTknId <- "tknId=" *> strP_
token <- "token=" *> strP_
tknStatus <- "tokenStatus=" *> strP_
tknVerifyKey <- "verifyKey=" *> strP_
tknDhKeys <- "dhKeys=" *> strP_
tknDhSecret <- "dhSecret=" *> strP_
tknRegCode <- "regCode=" *> strP_
tknCronInterval <- "cron=" *> strP
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
instance StrEncoding NtfSubRec where
strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
B.unwords
[ "subId=" <> strEncode ntfSubId,
"smpQueue=" <> strEncode smpQueue,
"notifierKey=" <> strEncode notifierKey,
"tknId=" <> strEncode tokenId,
"subStatus=" <> strEncode subStatus
]
strP = do
ntfSubId <- "subId=" *> strP_
smpQueue <- "smpQueue=" *> strP_
notifierKey <- "notifierKey=" *> strP_
tokenId <- "tknId=" *> strP_
subStatus <- "subStatus=" *> strP
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
logNtfStoreRecord = writeStoreLogRecord
logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode
logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
readWriteNtfStore f st = do
whenM (doesFileExist f) $ do
readNtfStore f st
renameFile f $ f <> ".bak"
s <- openWriteStoreLog f
writeNtfStore s st
pure s
readNtfStore :: FilePath -> NtfStore -> IO ()
readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
where
addNtfLogRecord s = case strDecode s of
Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
Right lr -> atomically $ case lr of
CreateToken r@NtfTknRec {ntfTknId} -> do
tkn <- mkTknData r
addNtfToken st ntfTknId tkn
TokenStatus tknId status ->
getNtfToken st tknId
>>= mapM_ (\NtfTknData {tknStatus} -> writeTVar tknStatus status)
UpdateToken tknId token' tknRegCode ->
getNtfToken st tknId
>>= mapM_
( \tkn@NtfTknData {tknStatus} -> do
removeTokenRegistration st tkn
writeTVar tknStatus NTRegistered
addNtfToken st tknId tkn {token = token', tknRegCode}
)
TokenCron tknId cronInt ->
getNtfToken st tknId
>>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
DeleteToken tknId ->
void $ deleteNtfToken st tknId
CreateSubscription r@NtfSubRec {ntfSubId} -> do
sub <- mkSubData r
void $ addNtfSubscription st ntfSubId sub
SubscriptionStatus subId status ->
getNtfSubscription st subId
>>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
DeleteSubscription subId ->
deleteNtfSubscription st subId
writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
writeNtfStore s NtfStore {tokens, subscriptions} = do
atomically (readTVar tokens >>= mapM mkTknRec)
>>= mapM_ (writeStoreLogRecord s . CreateToken)
atomically (readTVar subscriptions >>= mapM mkSubRec)
>>= mapM_ (writeStoreLogRecord s . CreateSubscription)
@@ -1,72 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Notifications.Transport where
import Control.Monad.Except
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Transport
import Simplex.Messaging.Version
ntfBlockSize :: Int
ntfBlockSize = 512
supportedNTFServerVRange :: VersionRange
supportedNTFServerVRange = mkVersionRange 1 1
data NtfServerHandshake = NtfServerHandshake
{ ntfVersionRange :: VersionRange,
sessionId :: SessionId
}
data NtfClientHandshake = NtfClientHandshake
{ -- | agreed SMP notifications server protocol version
ntfVersion :: Version,
-- | server identity - CA certificate fingerprint
keyHash :: C.KeyHash
}
instance Encoding NtfServerHandshake where
smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
smpEncode (ntfVersionRange, sessionId)
smpP = do
(ntfVersionRange, sessionId) <- smpP
pure NtfServerHandshake {ntfVersionRange, sessionId}
instance Encoding NtfClientHandshake where
smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
smpP = do
(ntfVersion, keyHash) <- smpP
pure NtfClientHandshake {ntfVersion, keyHash}
-- | Notifcations server transport handshake.
ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfServerHandshake c kh ntfVRange = do
let th@THandle {sessionId} = ntfTHandle c
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
getHandshake th >>= \case
NtfClientHandshake {ntfVersion, keyHash}
| keyHash /= kh ->
throwError $ TEHandshake IDENTITY
| ntfVersion `isCompatible` ntfVRange -> do
pure (th :: THandle c) {thVersion = ntfVersion}
| otherwise -> throwError $ TEHandshake VERSION
-- | Notifcations server client transport handshake.
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfClientHandshake c keyHash ntfVRange = do
let th@THandle {sessionId} = ntfTHandle c
NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
if sessionId /= sessId
then throwError TEBadSession
else case ntfVersionRange `compatibleVersion` ntfVRange of
Just (Compatible ntfVersion) -> do
sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
pure (th :: THandle c) {thVersion = ntfVersion}
Nothing -> throwError $ TEHandshake VERSION
ntfTHandle :: Transport c => c -> THandle c
ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}
@@ -1,193 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Notifications.Types where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time (UTCTime)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer)
data NtfTknAction
= NTARegister
| NTAVerify NtfRegCode -- code to verify token
| NTACheck
| NTADelete
deriving (Show)
instance Encoding NtfTknAction where
smpEncode = \case
NTARegister -> "R"
NTAVerify code -> smpEncode ('V', code)
NTACheck -> "C"
NTADelete -> "D"
smpP =
A.anyChar >>= \case
'R' -> pure NTARegister
'V' -> NTAVerify <$> smpP
'C' -> pure NTACheck
'D' -> pure NTADelete
_ -> fail "bad NtfTknAction"
instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode
instance ToField NtfTknAction where toField = toField . smpEncode
data NtfToken = NtfToken
{ deviceToken :: DeviceToken,
ntfServer :: NtfServer,
ntfTokenId :: Maybe NtfTokenId,
-- | key used by the ntf server to verify transmissions
ntfPubKey :: C.APublicVerifyKey,
-- | key used by the ntf client to sign transmissions
ntfPrivKey :: C.APrivateSignKey,
-- | client's DH keys (to repeat registration if necessary)
ntfDhKeys :: C.KeyPair 'C.X25519,
-- | shared DH secret used to encrypt/decrypt notifications e2e
ntfDhSecret :: Maybe C.DhSecretX25519,
-- | token status
ntfTknStatus :: NtfTknStatus,
-- | pending token action and the earliest time
ntfTknAction :: Maybe NtfTknAction,
ntfMode :: NotificationsMode
}
deriving (Show)
newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
NtfToken
{ deviceToken,
ntfServer,
ntfTokenId = Nothing,
ntfPubKey,
ntfPrivKey,
ntfDhKeys,
ntfDhSecret = Nothing,
ntfTknStatus = NTNew,
ntfTknAction = Just NTARegister,
ntfMode
}
data NtfSubAction = NtfSubNTFAction NtfSubNTFAction | NtfSubSMPAction NtfSubSMPAction
deriving (Show)
isDeleteNtfSubAction :: NtfSubAction -> Bool
isDeleteNtfSubAction = \case
NtfSubNTFAction a -> case a of
NSACreate -> False
NSACheck -> False
NSADelete -> True
NtfSubSMPAction a -> case a of
NSASmpKey -> False
NSASmpDelete -> True
type NtfActionTs = UTCTime
data NtfSubNTFAction
= NSACreate
| NSACheck
| NSADelete
deriving (Show)
instance Encoding NtfSubNTFAction where
smpEncode = \case
NSACreate -> "N"
NSACheck -> "C"
NSADelete -> "D"
smpP =
A.anyChar >>= \case
'N' -> pure NSACreate
'C' -> pure NSACheck
'D' -> pure NSADelete
_ -> fail "bad NtfSubNTFAction"
instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode
instance ToField NtfSubNTFAction where toField = toField . smpEncode
data NtfSubSMPAction
= NSASmpKey
| NSASmpDelete
deriving (Show)
instance Encoding NtfSubSMPAction where
smpEncode = \case
NSASmpKey -> "K"
NSASmpDelete -> "D"
smpP =
A.anyChar >>= \case
'K' -> pure NSASmpKey
'D' -> pure NSASmpDelete
_ -> fail "bad NtfSubSMPAction"
instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode
instance ToField NtfSubSMPAction where toField = toField . smpEncode
data NtfAgentSubStatus
= -- | subscription started
NASNew
| -- | state after NKEY - notifier ID is assigned to queue on SMP server
NASKey
| -- | state after SNEW - subscription created on notification server
NASCreated NtfSubStatus
| -- | state after SDEL (subscription is deleted on notification server)
NASOff
| -- | state after NDEL (notifier credentials are deleted on SMP server)
-- Can only exist transiently - if subscription record was updated by notification supervisor mid worker operation,
-- and hence got updated instead of being fully deleted in the database post operation by worker
NASDeleted
deriving (Eq, Show)
instance Encoding NtfAgentSubStatus where
smpEncode = \case
NASNew -> "NEW"
NASKey -> "KEY"
NASCreated status -> "CREATED " <> smpEncode status
NASOff -> "OFF"
NASDeleted -> "DELETED"
smpP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NASNew
"KEY" -> pure NASKey
"CREATED" -> do
_ <- A.space
NASCreated <$> smpP
"OFF" -> pure NASOff
"DELETED" -> pure NASDeleted
_ -> fail "bad NtfAgentSubStatus"
instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
data NtfSubscription = NtfSubscription
{ connId :: ConnId,
smpServer :: SMPServer,
ntfQueueId :: Maybe NotifierId,
ntfServer :: NtfServer,
ntfSubId :: Maybe NtfSubscriptionId,
ntfSubStatus :: NtfAgentSubStatus
}
deriving (Show)
newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> NtfSubscription
newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus =
NtfSubscription
{ connId,
smpServer,
ntfQueueId,
ntfServer,
ntfSubId = Nothing,
ntfSubStatus
}
+16 -71
View File
@@ -1,20 +1,16 @@
{-# 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 qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum, toLower)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isAlphaNum)
import Data.Time.Clock (UTCTime)
import Data.Time.ISO8601 (parseISO8601)
import Data.Typeable (Typeable)
@@ -26,7 +22,16 @@ import Simplex.Messaging.Util ((<$?>))
import Text.Read (readMaybe)
base64P :: Parser ByteString
base64P = decode <$?> paddedBase64 rawBase64P
base64P = decode <$?> base64StringP
base64StringP :: Parser ByteString
base64StringP = paddedBase64 rawBase64P
base64UriP :: Parser ByteString
base64UriP = U.decode <$?> base64UriStringP
base64UriStringP :: Parser ByteString
base64UriStringP = paddedBase64 rawBase64UriP
paddedBase64 :: Parser ByteString -> Parser ByteString
paddedBase64 raw = (<>) <$> raw <*> pad
@@ -36,8 +41,8 @@ paddedBase64 raw = (<>) <$> raw <*> pad
rawBase64P :: Parser ByteString
rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
-- rawBase64UriP :: Parser ByteString
-- rawBase64UriP = 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
@@ -48,12 +53,6 @@ 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)
@@ -73,63 +72,9 @@ parseString :: (ByteString -> Either String a) -> (String -> a)
parseString p = either error id . p . B.pack
blobFieldParser :: Typeable k => Parser k -> FieldParser k
blobFieldParser = blobFieldDecoder . parseAll
blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k
blobFieldDecoder dec = \case
blobFieldParser p = \case
f@(Field (SQLBlob b) _) ->
case dec b of
case parseAll p 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
}
File diff suppressed because it is too large Load Diff
+239 -573
View File
@@ -5,8 +5,6 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -25,60 +23,31 @@
-- and optional append only log of SMP queue records.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
disconnectTransport,
verifyCmdSignature,
dummyVerifyCmd,
)
where
module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where
import Control.Logger.Simple
import Control.Concurrent.STM (stateTVar)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight, partitionEithers)
import Data.Functor (($>))
import Data.List (intercalate)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Type.Equality
import GHC.TypeLits (KnownNat)
import Data.Time.Clock
import Network.Socket (ServiceName)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding (Encoding (smpEncode))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (hPutStrLn)
import System.Mem.Weak (deRefWeak)
import UnliftIO.Concurrent
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.IO
import UnliftIO.STM
@@ -96,294 +65,182 @@ 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 = 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
restoreServerStats
restoreServerMessages
raceAny_
( serverThread s subscribedQ subscribers subscriptions cancelSub :
serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg
)
`finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
runSMPServerBlocking started cfg@ServerConfig {transports} = do
env <- newEnv cfg
runReaderT smpServer env
where
runServer :: (ServiceName, ATransport) -> m ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams (runClient t)
smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
smpServer = do
s <- asks server
raceAny_ (serverThread s : map runServer transports)
`finally` withLog closeStoreLog
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
runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t)
serverThread :: MonadUnliftIO m' => Server -> m' ()
serverThread Server {subscribedQ, subscribers} = forever $ do
atomically updateSubscribers >>= \case
Just (rId, Client {rcvQ}) ->
void . forkIO . atomically $
writeTBQueue (sndQ c) [(CorrId "", qId, END)]
atomically $ TM.lookupDelete qId (clientSubs c)
writeTBQueue rcvQ (CorrId "", rId, Cmd SBroker END)
_ -> pure ()
where
updateSubscribers :: STM (Maybe (RecipientId, Client))
updateSubscribers = do
(rId, c) <- readTBQueue subscribedQ
stateTVar subscribers (\cs -> (M.lookup rId cs, M.insert rId c cs)) >>= \case
Just c' -> clientToBeNotified rId c c'
_ -> pure Nothing
clientToBeNotified :: RecipientId -> Client -> Client -> STM (Maybe (RecipientId, Client))
clientToBeNotified rId c c'@Client {connected}
| clientId c /= clientId c' = do
yes <- readTVar connected
pure $ if yes then Just (rId, c') else Nothing
| otherwise = pure Nothing
expireMessagesThread_ :: ServerConfig -> [m ()]
expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
expireMessagesThread_ _ = []
expireMessages :: ExpirationConfig -> m ()
expireMessages expCfg = do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
let interval = checkInterval expCfg * 1000000
forever $ do
threadDelay interval
old <- liftIO $ expireBeforeEpoch expCfg
rIds <- M.keysSet <$> readTVarIO ms
forM_ rIds $ \rId ->
atomically (getMsgQueue ms rId quota)
>>= atomically . (`deleteExpiredMsgs` old)
serverStatsThread_ :: ServerConfig -> [m ()]
serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
[logServerStats logStatsStartTime interval serverStatsLogFile]
serverStatsThread_ _ = []
logServerStats :: Int -> Int -> FilePath -> m ()
logServerStats startAt logInterval statsFilePath = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
let interval = 1000000 * logInterval
withFile statsFilePath AppendMode $ \h -> liftIO $ do
hSetBuffering h LineBuffering
forever $ do
ts <- getCurrentTime
fromTime' <- atomically $ swapTVar fromTime ts
qCreated' <- atomically $ swapTVar qCreated 0
qSecured' <- atomically $ swapTVar qSecured 0
qDeleted' <- atomically $ swapTVar qDeleted 0
msgSent' <- atomically $ swapTVar msgSent 0
msgRecv' <- atomically $ swapTVar msgRecv 0
ps <- atomically $ periodStatCounts activeQueues ts
hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayCount ps, weekCount ps, monthCount ps]
threadDelay interval
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
smpVRange <- asks $ smpServerVRange . config
liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
Right th -> runClientTransport th
Left _ -> pure ()
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 ()
runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
runClientTransport th@THandle {thVersion, sessionId} = do
runClientTransport th = do
q <- asks $ tbqSize . config
ts <- liftIO getSystemTime
c <- atomically $ newClient q thVersion sessionId ts
s <- asks server
expCfg <- asks $ inactiveClientExpiration . config
raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
c <- atomically $ newClient s q
raceAny_ [send th c, client c s, receive th c]
`finally` clientDisconnected c
where
disconnectThread_ c (Just expCfg) = [disconnectTransport th c activeAt expCfg]
disconnectThread_ _ _ = []
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
atomically . mapM_ (modifyTVar cs . M.update deleteCurrentClient) $ M.keys subs
where
deleteCurrentClient :: Client -> Maybe Client
deleteCurrentClient c'
| sameClientSession c c' = Nothing
| clientId c == clientId 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
_ -> return ()
cancelSub :: MonadUnliftIO m => TVar Sub -> m ()
cancelSub sub =
readTVarIO sub >>= \case
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
_ -> return ()
receive :: forall c m. (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
receive th Client {rcvQ, sndQ, activeAt} = forever $ do
ts <- L.toList <$> tGet th
atomically . writeTVar activeAt =<< liftIO getSystemTime
as <- partitionEithers <$> mapM cmdAction ts
write sndQ $ fst as
write rcvQ $ snd as
where
cmdAction :: SignedTransmission Cmd -> m (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId, queueId, ERR e)
Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
where
verified = \case
VRVerified qr -> Right (qr, (corrId, queueId, cmd))
VRFailed -> Left (corrId, queueId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
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
send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-- TODO the line below can return Lefts, but we ignore it and do not disconnect the client
void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
atomically . writeTVar activeAt =<< liftIO getSystemTime
send h Client {sndQ} = forever $ do
t <- atomically $ readTBQueue sndQ
liftIO $ tPut h ("", serializeTransmission t)
mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission
mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command)
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
where
tOrder :: Transmission BrokerMsg -> Int
tOrder (_, _, cmd) = case cmd of
MSG {} -> 0
_ -> 1
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
data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
verifyTransmission ::
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m VerificationResult
verifyTransmission sig_ signed queueId cmd = do
case cmd of
Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SSender PING -> pure $ VRVerified Nothing
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
where
verifyCmd :: SParty p -> (QueueRec -> Bool) -> m VerificationResult
verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd
verifyCmd party f = do
st <- asks queueStore
q_ <- atomically (getQueue st party queueId)
pure $ case q_ of
Right q -> Just q `verified` f q
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
verified q cond = if cond then VRVerified q else VRFailed
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
where
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
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
-- 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
dummyPublicKey :: C.Signature a -> C.PublicKey a
dummyPublicKey = \case
C.SignatureEd25519 _ -> dummyKeyEd25519
C.SignatureEd448 _ -> dummyKeyEd448
dummyKey128 :: C.PublicKey
dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw=="
dummyKeyEd25519 :: C.PublicKey 'C.Ed25519
dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
dummyKey256 :: C.PublicKey
dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9"
dummyKeyEd448 :: C.PublicKey 'C.Ed448
dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
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=="
client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
forever $
atomically (readTBQueue rcvQ)
>>= mapM processCommand
>>= processCommand
>>= atomically . writeTBQueue sndQ
where
processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
processCommand (qr_, (corrId, queueId, cmd)) = do
processCommand :: Transmission -> m Transmission
processCommand (corrId, queueId, cmd) = do
st <- asks queueStore
case cmd of
Cmd SSender command ->
case command of
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
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 -> withQueue (`subscribeQueue` queueId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> secureQueue_ st sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
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
where
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
createQueue :: QueueStore -> RecipientPublicKey -> m Transmission
createQueue st rKey =
checkKeySize rKey addSubscribe
where
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
let qr = qRec ids
atomically (addQueue st qr) >>= \case
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
Left e -> pure $ ERR e
Right _ -> do
addSubscribe =
addQueueRetry 3 >>= \case
Left e -> return $ ERR e
Right (rId, sId) -> do
withLog (`logCreateById` rId)
stats <- asks serverStats
atomically $ modifyTVar (qCreated stats) (+ 1)
subscribeQueue qr rId $> IDS (qik ids)
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
logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
logCreateById s rId =
@@ -396,335 +253,144 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
n <- asks $ queueIdBytes . config
liftM2 (,) (randomId n) (randomId n)
secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission
secureQueue_ st sKey = do
withLog $ \s -> logSecureQueue s queueId sKey
stats <- asks serverStats
atomically $ modifyTVar (qSecured stats) (+ 1)
atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey
addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
addQueueNotifier_ st notifierKey dhKey = do
(rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
let rcvNtfDhSecret = C.dh' dhKey privDhKey
(corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
where
addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> m BrokerMsg
addNotifierRetry 0 _ _ = pure $ ERR INTERNAL
addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
notifierId <- randomId =<< asks (queueIdBytes . config)
let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
atomically (addQueueNotifier st queueId ntfCreds) >>= \case
Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
Left e -> pure $ ERR e
Right _ -> do
withLog $ \s -> logAddNotifier s queueId ntfCreds
pure $ NID notifierId rcvPublicDhKey
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
deleteQueueNotifier_ :: QueueStore -> m (Transmission BrokerMsg)
deleteQueueNotifier_ st = do
withLog (`logDeleteNotifier` queueId)
okResp <$> atomically (deleteQueueNotifier st queueId)
suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
suspendQueue_ :: QueueStore -> m Transmission
suspendQueue_ st = do
withLog (`logSuspendQueue` queueId)
withLog (`logDeleteQueue` queueId)
okResp <$> atomically (suspendQueue st queueId)
subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
subscribeQueue qr rId =
atomically (TM.lookup rId subscriptions) >>= \case
Nothing ->
atomically newSub >>= deliver
Just sub ->
readTVarIO sub >>= \case
Sub {subThread = ProhibitSub} ->
-- cannot use SUB in the same connection where GET was used
pure (corrId, rId, ERR $ CMD PROHIBITED)
s ->
atomically (tryTakeTMVar $ delivered s) >> deliver sub
where
newSub :: STM (TVar Sub)
newSub = do
subscribeQueue :: RecipientId -> m Transmission
subscribeQueue rId =
atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId
getSubscription :: RecipientId -> STM Sub
getSubscription rId = do
subs <- readTVar subscriptions
case M.lookup rId subs of
Just s -> tryTakeTMVar (delivered s) $> s
Nothing -> do
writeTBQueue subscribedQ (rId, clnt)
sub <- newTVar =<< newSubscription NoSub
TM.insert rId sub subscriptions
pure sub
deliver :: TVar Sub -> m (Transmission BrokerMsg)
deliver sub = do
q <- getStoreMsgQueue rId
msg_ <- atomically $ tryPeekMsg q
deliverMessage qr rId sub q msg_
s <- newSubscription
writeTVar subscriptions $ M.insert rId s subs
return s
getMessage :: QueueRec -> m (Transmission BrokerMsg)
getMessage qr =
atomically (TM.lookup queueId subscriptions) >>= \case
Nothing ->
atomically newSub >>= getMessage_
Just sub ->
readTVarIO sub >>= \case
s@Sub {subThread = ProhibitSub} ->
atomically (tryTakeTMVar $ delivered s)
>> getMessage_ s
-- cannot use GET in the same connection where there is an active subscription
_ -> pure (corrId, queueId, ERR $ CMD PROHIBITED)
unsubscribeQueue :: m ()
unsubscribeQueue = do
sub <- atomically . stateTVar subscriptions $
\cs -> (M.lookup queueId cs, M.delete queueId cs)
mapM_ cancelSub sub
acknowledgeMsg :: m Transmission
acknowledgeMsg =
atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
>>= \case
Just (Just s) -> 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
where
newSub :: STM Sub
newSub = do
s <- newSubscription ProhibitSub
sub <- newTVar s
TM.insert queueId sub subscriptions
pure s
getMessage_ :: Sub -> m (Transmission BrokerMsg)
getMessage_ s = do
q <- getStoreMsgQueue queueId
atomically $
tryPeekMsg q >>= \case
Just msg ->
let encMsg = encryptMsg qr msg
in setDelivered s msg $> (corrId, queueId, MSG encMsg)
_ -> pure (corrId, queueId, OK)
mkMessage :: m Message
mkMessage = do
msgId <- asks (msgIdBytes . config) >>= randomId
ts <- liftIO getCurrentTime
return $ Message {msgId, ts, msgBody}
withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
withQueue action = maybe (pure $ err AUTH) action qr_
storeMessage :: QueueRec -> m Transmission
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
subscribeNotifications :: m (Transmission BrokerMsg)
subscribeNotifications = atomically $ do
unlessM (TM.member queueId ntfSubscriptions) $ do
writeTBQueue ntfSubscribedQ (queueId, clnt)
TM.insert queueId () ntfSubscriptions
pure ok
acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
acknowledgeMsg qr msgId = do
atomically (TM.lookup queueId subscriptions) >>= \case
Nothing -> pure $ err NO_MSG
Just sub ->
atomically (getDelivered sub) >>= \case
Just s -> do
q <- getStoreMsgQueue queueId
case s of
Sub {subThread = ProhibitSub} -> do
msgDeleted <- atomically $ tryDelMsg q msgId
when msgDeleted updateStats
pure ok
_ -> do
(msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
when msgDeleted updateStats
deliverMessage qr queueId sub q msg_
_ -> pure $ err NO_MSG
deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m Transmission
deliverMessage tryPeek rId = \case
Sub {subThread = NoSub} -> do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
q <- atomically $ getMsgQueue ms rId quota
atomically (tryPeek q) >>= \case
Nothing -> forkSub q $> ok
Just msg -> atomically setDelivered $> mkResp corrId rId (msgCmd msg)
_ -> return ok
where
getDelivered :: TVar Sub -> STM (Maybe Sub)
getDelivered sub = do
s@Sub {delivered} <- readTVar sub
tryTakeTMVar delivered $>>= \msgId' ->
if msgId == msgId' || B.null msgId
then pure $ Just s
else putTMVar delivered msgId' $> Nothing
updateStats :: m ()
updateStats = do
stats <- asks serverStats
atomically $ modifyTVar (msgRecv stats) (+ 1)
atomically $ updatePeriodStats (activeQueues stats) queueId
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
| otherwise = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
mapM mkMessage (C.maxLenBS msgBody) >>= \case
Left _ -> pure $ err LARGE_MSG
Right msg -> do
ms <- asks msgStore
ServerConfig {messageExpiration, msgQueueQuota} <- asks config
old <- liftIO $ mapM expireBeforeEpoch messageExpiration
ntfNonceDrg <- asks idsDrg
resp@(_, _, sent) <- atomically $ do
q <- getMsgQueue ms (recipientId qr) msgQueueQuota
mapM_ (deleteExpiredMsgs q) old
ifM (isFull q) (pure $ err QUOTA) $ do
when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
writeMsg q msg
pure ok
when (sent == OK) $ do
stats <- asks serverStats
atomically $ modifyTVar (msgSent stats) (+ 1)
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure resp
where
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
mkMessage body = do
msgId <- randomId =<< asks (msgIdBytes . config)
msgTs <- liftIO getSystemTime
pure $ Message msgId msgTs msgFlags body
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
trySendNotification msg ntfNonceDrg =
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
unlessM (isFullTBQueue sndQ) $ do
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
let msgMeta = NMsgMeta {msgId, msgTs}
encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
pure . (cbNonce,) $ fromRight "" encNMsgMeta
deliverMessage :: QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
deliverMessage qr rId sub q msg_ = do
readTVarIO sub >>= \case
s@Sub {subThread = NoSub} ->
case msg_ of
Just msg ->
let encMsg = encryptMsg qr msg
in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
_ -> forkSub $> ok
_ -> pure ok
where
forkSub :: m ()
forkSub = do
atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
t <- mkWeakThreadId =<< forkIO subscriber
atomically . modifyTVar sub $ \case
forkSub :: MsgQueue -> m ()
forkSub q = do
atomically . setSub $ \s -> s {subThread = SubPending}
t <- forkIO $ subscriber q
atomically . setSub $ \case
s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
s -> s
where
subscriber = atomically $ do
msg <- peekMsg q
let encMsg = encryptMsg qr msg
writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
s <- readTVar sub
void $ setDelivered s msg
writeTVar sub s {subThread = NoSub}
encryptMsg :: QueueRec -> Message -> RcvMessage
encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody}
| thVersion == 1 || thVersion == 2 = encrypt msgBody
| otherwise = encrypt $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
where
encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
encrypt body =
let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId) body
in RcvMessage msgId msgTs msgFlags encBody
subscriber :: MsgQueue -> m ()
subscriber q = atomically $ do
msg <- peekMsg q
writeTBQueue sndQ $ mkResp (CorrId "") rId (msgCmd msg)
setSub (\s -> s {subThread = NoSub})
void setDelivered
setDelivered :: Sub -> Message -> STM Bool
setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
setSub :: (Sub -> Sub) -> STM ()
setSub f = modifyTVar subscriptions $ M.adjust f rId
getStoreMsgQueue :: RecipientId -> m MsgQueue
getStoreMsgQueue rId = do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
atomically $ getMsgQueue ms rId quota
setDelivered :: STM (Maybe Bool)
setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
delQueueAndMsgs :: QueueStore -> m Transmission
delQueueAndMsgs st = do
withLog (`logDeleteQueue` queueId)
ms <- asks msgStore
stats <- asks serverStats
atomically $ modifyTVar (qDeleted stats) (+ 1)
atomically $
deleteQueue st queueId >>= \case
Left e -> pure $ err e
Left e -> return $ err e
Right _ -> delMsgQueue ms queueId $> ok
ok :: Transmission BrokerMsg
ok = (corrId, queueId, OK)
ok :: Transmission
ok = mkResp corrId queueId OK
err :: ErrorType -> Transmission BrokerMsg
err e = (corrId, queueId, ERR e)
err :: ErrorType -> Transmission
err = mkResp corrId queueId . ERR
okResp :: Either ErrorType () -> Transmission BrokerMsg
okResp :: Either ErrorType () -> Transmission
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 ByteString
randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded
randomId n = do
gVar <- asks idsDrg
atomically (C.pseudoRandomBytes n gVar)
atomically (randomBytes n gVar)
saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
where
saveMessages f = do
logInfo $ "saving messages to file " <> T.pack f
ms <- asks msgStore
liftIO . withFile f WriteMode $ \h ->
readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
logInfo "messages saved"
where
saveQueueMsgs ms h rId =
atomically (flushMsgQueue ms rId)
>>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
where
restoreMessages f = whenM (doesFileExist f) $ do
logInfo $ "restoring messages from file " <> T.pack f
st <- asks queueStore
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
Left e -> do
logError . T.pack $ "error restoring messages: " <> e
liftIO exitFailure
_ -> do
renameFile f $ f <> ".bak"
logInfo "messages restored"
where
restoreMsg st ms quota s = do
r <- liftEither . first (msgErr "parsing") $ strDecode s
case r of
MLRv3 rId msg -> addToMsgQueue rId msg
MLRv1 rId encMsg -> do
qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
msg' <- updateMsgV1toV3 qr encMsg
addToMsgQueue rId msg'
where
addToMsgQueue rId msg = do
full <- atomically $ do
q <- getMsgQueue ms rId quota
ifM (isFull q) (pure True) (writeMsg q msg $> False)
when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
let nonce = C.cbNonce msgId
msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
pure Message {msgId, msgTs, msgFlags, msgBody}
msgErr :: Show e => String -> e -> String
msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
saveServerStats =
asks (serverStatsBackupFile . config)
>>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
where
saveStats f stats = do
logInfo $ "saving server stats to file " <> T.pack f
B.writeFile f $ strEncode stats
logInfo "server stats saved"
restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
where
restoreStats f = whenM (doesFileExist f) $ do
logInfo $ "restoring server stats from file " <> T.pack f
liftIO (strDecode <$> B.readFile f) >>= \case
Right d -> do
s <- asks serverStats
atomically $ setServerStats s d
renameFile f $ f <> ".bak"
logInfo "server stats restored"
Left e -> do
logInfo $ "error restoring server stats: " <> T.pack e
liftIO exitFailure
randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
randomBytes n gVar = do
g <- readTVar gVar
let (bytes, g') = randomBytesGenerate n g
writeTVar gVar g'
return bytes

Some files were not shown because too many files have changed in this diff Show More